Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -163,10 +163,15 @@ chmod a+x $@ deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm + make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) + +mtest-reaper: $(PREFIX)/bin/mtest-reaper # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard @@ -177,10 +182,11 @@ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm ext-tests/.fslckout : $(MTQA_FOSSIL) @@ -251,15 +257,19 @@ datashare-testing/spublish : spublish.scm $(OFILES) csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +datashare-testing/sauthorize : sretrieve.scm megatest-version.o margs.o configf.o process.o common.o + csc sauthorize.scm megatest-version.o margs.o configf.o process.o common.o -o datashare-testing/sauthorize + sretrieve/sretrieve : datashare-testing/sretrieve csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ - srfi-1 posix regex regex-case srfi-69 + srfi-1 posix regex regex-case srfi-69 # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" @@ -282,5 +292,6 @@ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -39,10 +39,11 @@ get-run-status get-run-stats get-targets get-target ;; register-run + get-tests-tags get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs @@ -61,10 +62,12 @@ synchash-get )) (define api:write-queries '( + get-keys-write ;; dummy "write" query to force server start + ;; SERVERS start-server kill-server ;; TESTS @@ -111,10 +114,11 @@ ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") @@ -167,10 +171,11 @@ ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) @@ -186,10 +191,11 @@ ;;====================================================================== ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) ((get-keys) (db:get-keys dbstruct)) + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server ((get-key-vals) (apply db:get-key-vals dbstruct params)) ((get-target) (apply db:get-target dbstruct params)) ((get-targets) (db:get-targets dbstruct)) ;; ARCHIVES @@ -239,10 +245,11 @@ ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -46,17 +46,23 @@ (define (client:connect iface port) (case (server:get-transport) ((rpc) (rpc:client-connect iface port)) ((http) (http:client-connect iface port)) ((zmq) (zmq:client-connect iface port)) - (else (rpc:client-connect iface port)))) + (else + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (5)") + (exit)))) (define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) (case (server:get-transport) - ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) + ((rpc) (let ((res (client:setup-rpc run-id remaining-tries: remaining-tries))) + (remote-conndat-set! *runremote* res) + res)) ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects)) - (else (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) + (else + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (6)") + (exit)))) ;; (client:setup-rpc run-id)))) ;; (define (client:login-no-auto-setup server-info run-id) ;; (case (server:get-transport) ;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) ;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) @@ -152,10 +158,30 @@ ;; ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; + +(define (client:setup-rpc run-id #!key (remaining-tries 10) (failed-connects 0)) + (debug:print-info 2 *default-log-port* "client:setup-rpc remaining-tries=" remaining-tries) + (let* ((server-dat (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id)) + (num-available (tasks:num-in-available-state (db:delay-if-busy (tasks:open-db)) run-id))) + (cond + ((<= remaining-tries 0) + (debug:print-error 0 *default-log-port* "failed to start or connect to server for run-id " run-id) + (exit 1)) + (server-dat + (debug:print-info 4 *default-log-port* "client:setup-rpc server-dat=" server-dat ", remaining-tries=" remaining-tries) + + (rpc-transport:client-setup run-id server-dat remaining-tries: remaining-tries)) + (else + (if (< num-available 2) + (server:try-running run-id)) + (thread-sleep! (+ 2 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. + (client:setup run-id remaining-tries: (- remaining-tries 1)))))) + + (define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin @@ -165,22 +191,12 @@ (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) (hostname (tasks:hostinfo-get-hostname server-dat)) (port (tasks:hostinfo-get-port server-dat)) - (start-res (case *transport-type* - ((http)(http-transport:client-connect iface port)) - ;;((nmsg)(nmsg-transport:client-connect hostname port)) - )) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res)) - ;; ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id))) - ;; (if logininfo - ;; (car (vector-ref logininfo 1)) - ;; #f))) - - ))) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res))) (if (and start-res ping-res) (begin (remote-conndat-set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res) (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) @@ -209,11 +225,11 @@ (if (< num-available 2) (server:try-running run-id)) (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) -;; keep this as a function to ease future +;; keep this as a function to ease future ;; this is unused, not porting for rpc -BB (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) ;; ;; client:signal-handler Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -18,10 +18,12 @@ (import (prefix base64 base64:)) (declare (unit common)) (include "common_records.scm") +(include "thunk-utils.scm") + ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) @@ -60,13 +62,24 @@ (if (not cxt) (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) (let ((cxt-mutex (cxt-mutex cxt))) (mutex-unlock! *context-mutex*) (mutex-lock! cxt-mutex) - (let ((res (proc cxt))) - (mutex-unlock! cxt-mutex) - res)))) + ;; here we guard proc with exception handler so + ;; no matter how proc succeeds or fails, + ;; the cxt-mutex will be unlocked afterward. + (let* ((EXCEPTION-SYMBOL (gensym)) ;; use a generated symbol + (guarded-proc ;; to avoid collision + (lambda args + (let* ((res (condition-case + (apply proc args) + [x () (cons EXCEPTION-SYMBOL x)]))) + (mutex-unlock! cxt-mutex) + (if (and (pair? res) (eq? (car res) EXCEPTION)) + (abort (cdr res)) + res))))) + (guarded-proc cxt))))) (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data @@ -90,23 +103,33 @@ (define *db-stats-mutex* (make-mutex)) ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server (define *db-write-access* #t) ;; db sync -(define *db-last-write* 0) ;; used to record last touch of db (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another -(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* and *db-last-write* +(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) (define *db-cache-path* #f) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg +(define *transport-type* #f) ;; override with [server] transport http|rpc|nmsg + +(define *DEFAULT-TRANSPORT* "http") +(define (common:set-transport-type) + (set! *transport-type* + (string->symbol + (or + (args:get-arg "-transport") + (configf:lookup *configdat* "server" "transport") + *DEFAULT-TRANSPORT*))) + *transport-type*) + (define *runremote* #f) ;; if set up for server communication this will hold (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) (define *server-info* #f) @@ -135,10 +158,18 @@ (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) +(defstruct remote + (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) + (server-url (if *toppath* (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*) #f)) + (last-server-check 0) ;; last time we checked to see if the server was alive + (conndat #f) + (transport *transport-type*) + (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds + ;; launching and hosts (defstruct host (reachable #f) (last-update 0) (last-used 0) @@ -531,26 +562,28 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) - (let ((ohh (common:on-homehost?)) - (srv (args:get-arg "-server"))) - ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) (and (common:on-homehost?) - (args:get-arg "-server")))) + (args:get-arg "-server"))) + +;; (let ((ohh (common:on-homehost?)) +;; (srv (args:get-arg "-server"))) +;; (and ohh srv))) + ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps (define (common:sync-to-megatest.db dbstruct) (let ((start-time (current-seconds)) (res (db:multi-db-sync dbstruct 'new2old))) (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds") + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds"))) + (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)))) res)) ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; @@ -557,19 +590,20 @@ (define (common:watchdog) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) - (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync) + (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)) (if legacy-sync (let ((dbstruct (db:setup))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () + ;;(BB> "watchdog loop. pid="(current-process-id)) ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) - (let* ((need-sync (>= *db-last-write* *db-last-sync*)) ;; no sync since last write + (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write (sync-in-progress *db-sync-in-progress*) (should-sync (> (- (current-seconds) *db-last-sync*) 5)) ;; sync every five seconds minimum (will-sync (and (or need-sync should-sync) (not sync-in-progress))) (start-time (current-seconds))) @@ -606,44 +640,65 @@ (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)))))))) (define (std-exit-procedure) + (on-exit (lambda () 0)) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated + (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) - (close-output-port *default-log-port*) + (if (and *runremote* + (remote-conndat *runremote*)) + (begin + (http-client#close-all-connections!))) ;; for http-client + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry - (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff - (thread-sleep! 2)) - (debug:print 4 *default-log-port* " ... done") - ) + (begin + (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff + (begin + (thread-sleep! 2))) + (debug:print 4 *default-log-port* " ... done") + ) "clean exit"))) + + ;; let's try to clean up open sockets + (if *runremote* + (case (remote-transport *runremote*) + ((http) #t) + ((rpc) (rpc:close-all-connections!)) + (else + (debug:print-info 0 *default-log-port* "Transport "(remote-transport *runremote*)" not supported")))) + (thread-start! th1) (thread-start! th2) - (thread-join! th1)))) + (thread-join! th1) + ) + ) + + 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") @@ -779,20 +834,24 @@ (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) - (let* ((rtestpatt (if rconf (runconfigs-get rconf "TESTPATT") #f)) - (args-testpatt (or (args:get-arg "-testpatt") - (args:get-arg "-runtests") - "%")) - (testpatt (or (and (equal? args-testpatt "%") - rtestpatt) - args-testpatt))) - (if rtestpatt (debug:print-info 0 *default-log-port* "TESTPATT from runconfigs: " rtestpatt)) - testpatt)) - + (let* ((tagexpr (args:get-arg "-tagexpr")) + (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) + (testpatt-key (if (args:get-arg "-mode") (args:get-arg "-mode") "TESTPATT")) + (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) + (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) + (cond + (tags-testpatt + (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) + tags-testpatt) + ((and (equal? args-testpatt "%") rtestpatt) + (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) + rtestpatt) + (else args-testpatt)))) + (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree")))) @@ -1084,11 +1143,12 @@ (lambda ()(list (read)(read)(read))))) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read)))))) ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads -;; returns list (normalized-proc-load normalized-core-load 1m 5m 15m ncores nthreads) +;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. +;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; (define (common:get-normalized-cpu-load remote-host) (let ((data (if remote-host (with-input-from-pipe (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") @@ -1143,51 +1203,89 @@ (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; -(define (common:get-least-loaded-host hosts-raw) +;; return list of +;; ( reachable? cpuload update-time ) +(define (common:get-host-info hostname) + (let* ((loadinfo (rmt:get-latest-host-load hostname)) + (load (car loadinfo)) + (load-sample-time (cdr loadinfo)) + (load-sample-age (- (current-seconds) load-sample-time)) + (loadinfo-timeout-seconds 20) + (host-last-update-timeout-seconds 10) + (host-rec (hash-table-ref/default *host-loads* hostname #f)) + ) + (cond + ((< load-sample-age loadinfo-timeout-seconds) + (list #t + load-sample-time + load)) + ((and host-rec + (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds))) + (list #t + (host-last-update host-rec) + (host-last-cpuload host-rec ))) + ((common:unix-ping hostname) + (list #t + (current-seconds) + (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) + (else + (list #f 0 -1))))) + +(define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw))) - (if (null? hosts) - #f - ;; - ;; stategy: - ;; sort by last-used and normalized-load - ;; if last-updated > 15 seconds then re-update - ;; take the host with the lowest load with the lowest last-used (i.e. not used for longest time) - ;; - (let ((best-host #f) - (curr-time (current-seconds))) - (for-each - (lambda (hostname) - (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) - (if h - h - (let ((h (make-host))) - (hash-table-set! *host-loads* hostname h) - h)))) - ;; if host hasn't been pinged in 15 sec update it's data - (ping-good (if (< (- curr-time (host-last-update rec)) 15) - (host-reachable rec) - (or (host-reachable rec) - (begin - (host-reachable-set! rec (common:unix-ping hostname)) - (host-last-update-set! rec curr-time) - (host-last-cpuload-set! rec (common:get-normalized-cpu-load hostname)) - (host-reachable rec)))))) - (cond - ((not best-host) - (set! best-host hostname)) - ((and ping-good - (< (alist-ref 'adj-core-load (host-last-cpuload rec)) - (alist-ref 'adj-core-load - (host-last-cpuload (hash-table-ref *host-loads* best-host))))) - (set! best-host hostname))))) - hosts) - best-host)))) + (for-each + (lambda (hostname) + (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (host-info (common:get-host-info hostname)) + (is-reachable (car host-info)) + (last-reached-time (cadr host-info)) + (load (caddr host-info))) + (host-reachable-set! rec is-reachable) + (host-last-update-set! rec last-reached-time) + (host-last-cpuload-set! rec load))) + hosts))) + +(define (common:get-least-loaded-host hosts-raw) + (let* ((hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw)) + (best-host #f) + (best-load 99999) + (curr-time (current-seconds))) + (common:update-host-loads-table hosts) + (for-each + (lambda (hostname) + (let* ((rec + (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (reachable (host-reachable rec)) + (load (host-last-cpuload rec))) + (cond + ((not reachable) #f) + ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut + (+ best-load (/ (random 250) 1000)) ) + (set! best-load load) + (set! best-host hostname))))) + hosts) + best-host)) + + + (define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -133,10 +133,57 @@ (if (equal? this-func "BB>") (set! location this-loc)))) stack) (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args))) (apply debug:print dp-args)))) + +(define *BBpp_custom_expanders_list* (make-hash-table)) + + + +;; register hash tables with BBpp. +(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: + (cons hash-table? hash-table->alist)) + +;; test name converter +(define (BBpp_custom_converter arg) + (let ((res #f)) + (for-each + (lambda (custom-type-name) + (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) + (custom-type-test (car custom-type-info)) + (custom-type-converter (cdr custom-type-info))) + (when (and (not res) (custom-type-test arg)) + (set! res (custom-type-converter arg))))) + (hash-table-keys *BBpp_custom_expanders_list*)) + (if res (BBpp_ res) arg))) + +(define (BBpp_ arg) + (cond + ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) + ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) + ((hash-table? arg) + (let ((al (hash-table->alist arg))) + (BBpp_ (cons HASH_TABLE: al)))) + ((null? arg) '()) + ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) + ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) + (else (BBpp_custom_converter arg)))) + +;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp +(define (BBpp arg) + (pp (BBpp_ arg))) + +;(use define-macro) +(define-syntax inspect + (syntax-rules () + [(_ x) + ;; (with-output-to-port (current-error-port) + (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) + ;; ) + ] + [(_ x y ...) (begin (inspect x) (inspect y ...))])) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -290,10 +290,21 @@ ;; runs summary view tests-tree ;; used in newdashboard ) +;; register tabdat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle +(hash-table-set! *BBpp_custom_expanders_list* TABDAT: + (cons dboard:tabdat? + (lambda (tabdat-item) + (filter + (lambda (alist-entry) + (member (car alist-entry) + '(allruns-by-id allruns))) ;; FIELDS OF INTEREST + (dboard:tabdat->alist tabdat-item))))) + (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:tabdat-test-patts-use vec) @@ -360,10 +371,24 @@ ((last-update 0) : fixnum) ;; last query to db got records from before last-update ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items (db-path #f) ) + +;; register dboard:rundat with BBpp +;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle +(hash-table-set! *BBpp_custom_expanders_list* RUNDAT: + (cons dboard:rundat? + (lambda (tabdat-item) + (filter + (lambda (alist-entry) + (member (car alist-entry) + '(run run-data-offset ))) ;; FIELDS OF INTEREST + (dboard:rundat->alist tabdat-item))))) + + + (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began (make-dboard:rundat run: run tests: (or tests (make-hash-table)) @@ -623,10 +648,12 @@ (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) + ;;(BB> "In update-rundat") + ;;(inspect allruns runs-hash) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; @@ -740,11 +767,17 @@ (run-struct (or run-struct (dboard:rundat-make-init run: run tests: tests-ht key-vals: key-vals))) - (new-res (if (null? all-test-ids) res (cons run-struct res))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (db:get-value-by-header (dboard:rundat-run b) header "id")))))) (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) @@ -3391,10 +3424,13 @@ ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) + ;;(BB> "dashboard:runs-tab-updater") + ;;(inspect tabdat) + (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) Index: datashare-testing/.sretrieve.config ================================================================== --- datashare-testing/.sretrieve.config +++ datashare-testing/.sretrieve.config @@ -1,8 +1,8 @@ [settings] base-dir /tmp/delme_data -allowed-users matt +allowed-users matt allowed-chars [0-9a-zA-Z\-\.]+ allowed-sub-paths [0-9a-zA-Z\-\.]+ [database] location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -335,10 +335,11 @@ (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) (mutex-unlock! *db-multi-sync-mutex*) (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-sync* start-t) + (set! *db-last-access* start-t) (mutex-unlock! *db-multi-sync-mutex*))) ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) @@ -1497,26 +1498,33 @@ (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (sqlite3:execute - db - (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" - (string-intersperse (map conc all-ids) ",") - ");") - run-id)))) - - ;; Now do rollups for the toplevel tests - ;; - ;; (db:delay-if-busy dbdat) - (for-each - (lambda (toptest) - (let ((test-name (list-ref toptest 3))) -;; (run-id (list-ref toptest 5))) - (db:top-test-set-per-pf-counts dbstruct run-id test-name))) - toplevels))) + (for-each + (lambda (test-id) + (db:test-set-status-state dbstruct run-id test-id "COMPLETE" "DEAD" "Test failed to complete")) + all-ids)))))) + +;; ALL REPLACED BY THE BLOCK ABOVE +;; +;; (sqlite3:execute +;; db +;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" +;; (string-intersperse (map conc all-ids) ",") +;; ");") +;; run-id)))) +;; +;; ;; Now do rollups for the toplevel tests +;; ;; +;; ;; (db:delay-if-busy dbdat) +;; (for-each +;; (lambda (toptest) +;; (let ((test-name (list-ref toptest 3))) +;; ;; (run-id (list-ref toptest 5))) +;; (db:top-test-set-per-pf-counts dbstruct run-id test-name))) +;; toplevels))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) (db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) @@ -2039,11 +2047,12 @@ (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) db - "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;" + run-id) ;; add the per run counts to res (for-each (lambda (state) (set! res (cons (list run-name state (hash-table-ref curr state)) res))) (sort (hash-table-keys curr) string>=)) (set! curr (make-hash-table)))))) @@ -2588,10 +2597,13 @@ )) 0))))) ;; DEBUG FIXME - need to merge this v.155 query correctly ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?) ;; AND NOT (uname = 'n/a' AND item_path = '');" + +;; tags: '("tag%" "tag2" "%ag6") +;; ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING (define (db:estimated-tests-remaining dbstruct run-id) (db:with-db @@ -3469,10 +3481,28 @@ (set! res (cons (vector state status count) res))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" run-id testname) res)) + + +(define (db:get-latest-host-load dbstruct raw-hostname) + (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) + (res (cons -1 0)) + (mydb (db:dbdat-get-db (db:get-db dbstruct 0))) + ) + (db:with-db + dbstruct + 0 + #f + (lambda (db) + (sqlite3:for-each-row + (lambda (cpuload update-time) (set! res (cons cpuload update-time))) + db + "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" + hostname))) res )) + (define (db:set-top-level-from-items dbstruct run-id testname) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (summ (db:get-state-status-summary db run-id testname)) @@ -3609,10 +3639,29 @@ res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== + +;; returns a hash table of tags to tests +;; +(define (db:get-tests-tags dbstruct) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) + (res (make-hash-table))) + (sqlite3:for-each-row + (lambda (testname tags-in) + (let ((tags (string-split tags-in ","))) + (for-each + (lambda (tag) + (hash-table-set! res tag + (delete-duplicates + (cons testname (hash-table-ref/default res tag '()))))) + tags))) + db + "SELECT testname,tags FROM test_meta") + res)) ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (db:with-db Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -84,11 +84,11 @@ ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) - (set! *db-last-access* (current-seconds)) + (set! *db-lastaccess* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) @@ -217,11 +217,11 @@ (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) - (res #f) + (res (vector #f "uninitialized")) (success #t) (sparams (db:obj->string params transport: 'http))) (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) @@ -335,11 +335,11 @@ ;; (define (http-transport:client-connect iface port) (let* ((api-url (conc "http://" iface ":" port "/api")) (api-uri (uri-reference (conc "http://" iface ":" port "/api"))) (api-req (make-request method: 'POST uri: api-uri)) - (server-dat (vector iface port api-uri api-url api-req (current-seconds)))) + (server-dat (vector iface port api-uri api-url api-req (current-seconds) 'http))) server-dat)) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; @@ -398,12 +398,12 @@ (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access (set! *dbstruct-db* (db:setup)) ;; run-id)) (set! server-going #t) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") (server:write-dotserver *toppath* (conc iface ":" port)) - (delete-file* (conc *toppath* "/.starting-server"))) - (begin ;; gotta exit nicely + (server:dotserver-starting-remove)) + (begin ;; gotta exit nicely (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision") (http-transport:server-shutdown server-id port)))))) ;; when things go wrong we don't want to be doing the various queries too often ;; so we strive to run this stuff only every four seconds or so. @@ -486,11 +486,11 @@ ;; (thread-sleep! rem-time) ;; (thread-sleep! 4))) ;; fallback for if the math is changed ... (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) - (debug:print-info 0 *default-log-port* "Starting to shutdown the server.") + (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up @@ -520,14 +520,11 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) - (with-output-to-file - (conc *toppath* "/.starting-server") - (lambda () - (print (current-process-id) " on " (get-host-name)))) + (server:dotserver-starting) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) @@ -540,23 +537,24 @@ (begin (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0)) (begin ;; ok, no server detected, clean out any lingering records (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding"))) - (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) + (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id 'http)) (remtries 4)) (if (not server-id) (if (> remtries 0) (begin (thread-sleep! 2) - (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) + (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id 'http) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") - (delete-file* (conc *toppath* "/.starting-server")) + + (server:dotserver-starting-remove) )) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") @@ -638,11 +636,11 @@ "Average non-cached time " (if (eq? *number-non-write-queries* 0) "n/a (no queries)" (/ *total-non-write-delay* *number-non-write-queries*)) " ms" - "Last access" (seconds->time-string *db-last-access*) "" + "Last access" (seconds->time-string *last-db-access*) "" ""))) (mutex-unlock! *heartbeat-mutex*) res)) (define (http-transport:runs linkpath) DELETED inteldate.scm Index: inteldate.scm ================================================================== --- inteldate.scm +++ /dev/null @@ -1,180 +0,0 @@ -(use srfi-19) -(use test) -(use format) -(use regex) -(declare (unit inteldate)) -;; utility procedures to convert among -;; different ways to express date (inteldate, seconds since epoch, isodate) -;; -;; samples: -;; isodate -> "2016-01-01" -;; inteldate -> "16ww01.5" -;; seconds -> 1451631600 - -;; procedures provided: -;; ==================== -;; seconds->isodate -;; seconds->inteldate -;; -;; isodate->seconds -;; isodate->inteldate -;; -;; inteldate->seconds -;; inteldate->isodate - -;; srfi-19 used extensively; this doc is better tha the eggref: -;; http://srfi.schemers.org/srfi-19/srfi-19.html - -;; Author: brandon.j.barclay@intel.com 16ww18.6 - -(define (date->seconds date) - (inexact->exact - (string->number - (date->string date "~s")))) - -(define (seconds->isodate seconds) - (let* ((date (seconds->date seconds)) - (result (date->string date "~Y-~m-~d"))) - result)) - -(define (isodate->seconds isodate) - "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K" - (let* ((numlist (map string->number (string-split isodate "-"))) - (raw-year (car numlist)) - (year (if (< raw-year 100) (+ raw-year 2000) raw-year)) - (month (list-ref numlist 1)) - (day (list-ref numlist 2)) - (date (make-date 0 0 0 0 day month year)) - (seconds (date->seconds date))) - - seconds)) - -;; adapted from perl Intel::WorkWeek perl module -;; intel year consists of numbered weeks starting from week 1 -;; week 1 is the week containing jan 1 of the year -;; days of week are numbered starting from 0 on sunday -;; intel year does not match calendar year in workweek 1 -;; before jan1. -(define (seconds->inteldate-values seconds) - (define (date-difference->seconds d1 d2) - (- (date->seconds d1) (date->seconds d2))) - - (let* ((thisdate (seconds->date seconds)) - (thisdow (string->number (date->string thisdate "~w"))) - - (year (date-year thisdate)) - ;; intel workweek 1 begins on sunday of week containing jan1 - (jan1 (make-date 0 0 0 0 1 1 year)) - (jan1dow (date-week-day jan1)) - (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow)))) - - (ww01_delta_seconds (date-difference->seconds thisdate ww01)) - (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) )))) - - ;; we could be in ww1 of next year - (this-saturday (seconds->date - (+ seconds - (* 60 60 24 (- 6 thisdow))))) - (this-week-ends-next-year? - (> (date-year this-saturday) year)) - (intelyear - (if this-week-ends-next-year? - (add1 year) - year)) - (intelweek - (if this-week-ends-next-year? - 1 - wwnum_initial))) - (values intelyear intelweek thisdow))) - -(define (seconds->inteldate seconds) - (define (string-leftpad in width pad-char) - (let* ((unpadded-str (->string in)) - (padlen_temp (- width (string-length unpadded-str))) - (padlen (if (< padlen_temp 0) 0 padlen_temp)) - (padding - (fold conc "" - (map (lambda (x) (->string pad-char)) (iota padlen))))) - (conc padding unpadded-str))) - (define (zeropad num width) - (string-leftpad num width #:0)) - - (let-values (((intelyear intelweek day-of-week-num) - (seconds->inteldate-values seconds))) - (let ((intelyear-str - (zeropad - (->string - (if (> intelyear 1999) - (- intelyear 2000) intelyear)) - 2)) - (intelweek-str - (zeropad (->string intelweek) 2)) - (dow-str (->string day-of-week-num))) - (conc intelyear-str "ww" intelweek-str "." dow-str)))) - -(define (isodate->inteldate isodate) - (seconds->inteldate - (isodate->seconds isodate))) - -(define (inteldate->seconds inteldate) - (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate))) - (if - (not match) - #f - (let* ( - (intelyear-raw (string->number (list-ref match 1))) - (intelyear (if (< intelyear-raw 100) - (+ intelyear-raw 2000) - intelyear-raw)) - (intelww (string->number (list-ref match 2))) - (dayofweek (string->number (list-ref match 3))) - - (day-of-seconds (* 60 60 24 )) - (week-of-seconds (* day-of-seconds 7)) - - - ;; get seconds at ww1.0 - (new-years-date (make-date 0 0 0 0 1 1 intelyear)) - (new-years-seconds - (date->seconds new-years-date)) - (new-years-dayofweek (date-week-day new-years-date)) - (ww1.0_seconds (- new-years-seconds - (* day-of-seconds - new-years-dayofweek))) - (workweek-adjustment (* week-of-seconds (sub1 intelww))) - (weekday-adjustment (* dayofweek day-of-seconds)) - - (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment))) - result)))) - -(define (inteldate->isodate inteldate) - (seconds->isodate (inteldate->seconds inteldate))) - -(define (inteldate-tests) - (test-group - "date conversion tests" - (let ((test-table - '(("16ww01.5" . "2016-01-01") - ("16ww18.5" . "2016-04-29") - ("1999ww33.5" . "1999-08-13") - ("16ww18.4" . "2016-04-28") - ("16ww18.3" . "2016-04-27") - ("13ww01.0" . "2012-12-30") - ("13ww52.6" . "2013-12-28") - ("16ww53.3" . "2016-12-28")))) - (for-each - (lambda (test-pair) - (let ((inteldate (car test-pair)) - (isodate (cdr test-pair))) - (test - (conc "(isodate->inteldate "isodate ") => "inteldate) - inteldate - (isodate->inteldate isodate)) - - (test - (conc "(inteldate->isodate "inteldate ") => "isodate) - isodate - (inteldate->isodate inteldate)))) - test-table)))) - -;(inteldate-tests) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -122,10 +122,22 @@ (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 (pid (process-run "/bin/bash" (list "-c" cmd)))) + + (with-output-to-file "Makefile.ezsteps" + (lambda () + (print stepname ".log :") + (print "\t" cmd) + (if (file-exists? (conc stepname ".logpro")) + (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log")) + (print) + (print stepname " : " stepname ".log") + (print)) + #:append) + (rmt:test-set-top-process-pid run-id test-id pid) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) @@ -316,15 +328,15 @@ (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes)) - (cpu-load (get-cpu-load)) + (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (disk-free (get-df (current-directory)))) - (let ((new-cpu-load (let* ((load (get-cpu-load)) + (let ((new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (delta (abs (- load cpu-load)))) - (if (> delta 0.6) ;; don't bother updating with small changes + (if (> delta 0.1) ;; don't bother updating with small changes load #f))) (new-disk-free (let* ((df (get-df (current-directory))) (delta (abs (- df disk-free)))) (if (> delta 200) ;; ignore changes under 200 Meg @@ -816,10 +828,11 @@ (set! *configstatus* 'partial)) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping + (common:set-transport-type) (let* ((linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))) (if linktree (begin (if (not (file-exists? linktree)) @@ -846,11 +859,14 @@ (directory-exists? *toppath*)) (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) (begin - (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area."))) + (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") + ;;(exit 1) + #f + )) *toppath*)) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) @@ -861,11 +877,11 @@ (if res (cdr res) (begin (if (common:low-noise-print 20 "No valid disks or no disk with enough space") (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) - (exit 1))))))) + (exit 1))))))) ;; TODO - move the exit to the calling location and return #f ;; Desired directory structure: ;; ;; - - -. ;; | @@ -1053,30 +1069,35 @@ ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* ((item-path (item-list->path itemdat))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5")))) (if (> launch-delay delta) (begin (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds") (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) - (set! *last-launch* (current-seconds)) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) - (list - (list "MT_RUN_AREA_HOME" *toppath*) - (list "MT_TEST_NAME" test-name) - (list "MT_RUNNAME" runname) - (list "MT_ITEMPATH" item-path) - )) - (let* ((tregistry (tests:get-all)) + (append + (list + (list "MT_RUN_AREA_HOME" *toppath*) + (list "MT_TEST_NAME" test-name) + (list "MT_RUNNAME" runname) + (list "MT_ITEMPATH" item-path) + ) + itemdat)) + (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed + ;; for tconfig, why do we allow fallback to test-conf? (tconfig (or (tests:get-testconfig test-name tregistry #t force-create: #t) - test-conf)) ;; force re-read now that all vars are set + (begin + (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.") + test-conf))) ;; force re-read now that all vars are set (useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) (if ush (if (equal? ush "no") ;; must use "no" to NOT use shell #f ush) @@ -1112,11 +1133,10 @@ (mt-bindir-path #f) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) - ;; (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) @@ -1130,10 +1150,11 @@ ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED" #f) + ;; (pp (hash-table->alist tconfig)) (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) @@ -1184,10 +1205,11 @@ ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 *default-log-port* "Launching " work-area) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 *default-log-port* "fullcmd: " fullcmd) + (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible. (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) @@ -1211,10 +1233,11 @@ (conc cmdstr " >> mt_launch.log 2>&1"))) (car fullcmd)) (if useshell '() (cdr fullcmd))))) + (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) (with-output-to-file "mt_launch.log" (lambda () (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -93,10 +93,12 @@ -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context -status : Applies to runs, tests or steps depending on context + -mode key : load testpatt from in runconfigs instead of default TESTPATT + -tagexpr tag1,tag2%,.. : select tests with tags matching expression Test helpers (for use inside tests) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test @@ -209,11 +211,13 @@ ":state" "-state" ":status" "-status" "-list-runs" - "-testpatt" + "-testpatt" + "-mode" + "-tagexpr" "-itempatt" "-setlog" "-set-toplog" "-runstep" "-logpro" @@ -327,10 +331,11 @@ args:arg-hash 0)) ;; Add args that use remargs here ;; + (if (and (not (null? remargs)) (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") @@ -699,13 +704,11 @@ ;; Server? Start up here. ;; (let ((tl (launch:setup)) ;; (run-id (and (args:get-arg "-run-id") ;; (string->number (args:get-arg "-run-id")))) - (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) - ;; (if run-id - ;; (begin + (transport-type *transport-type* )) (server:launch 0 transport-type) (set! *didsomething* #t))) ;; ;; (debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id"))) ;; ;; ;; Not a server? This section will decide how to communicate @@ -1851,13 +1854,11 @@ (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - ;; now can find our db - ;; keep this one local - (open-run-close runs:update-all-test_meta #f) + (runs:update-all-test_meta #f) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== @@ -1986,17 +1987,15 @@ ;;====================================================================== ;; Exit and clean up ;;====================================================================== -(if *runremote* (close-all-connections!)) ;; for http-client - (if (not *didsomething*) (debug:print 0 *default-log-port* help)) -(set! *time-to-exit* #t) (thread-join! *watchdog*) +(set! *time-to-exit* #t) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -6,17 +6,18 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== - +;; (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) +(declare (uses rpc-transport)) ;;(declare (uses nmsg-transport)) (include "common_records.scm") ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! @@ -24,18 +25,10 @@ ;; generate entries for ~/.megatestrc with the following ;; ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u -(defstruct remote - (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) - (server-url (if *toppath* (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*) #f)) - (last-server-check 0) ;; last time we checked to see if the server was alive - (conndat #f) - (transport *transport-type*) - (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds - ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup @@ -94,23 +87,38 @@ ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3") (rmt:open-qry-close-locally cmd 0 params)) + + ;; on homehost and this is a write, we already have a server, but server has died + ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + (not (member cmd api:read-only-queries)) ;; this is a write + (remote-server-url *runremote*) ;; have a server + (not (server:read-dotserver *toppath*))) ;; server has died. + (set! *runremote* #f) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") + (rmt:send-receive cmd rid params attemptnum: attemptnum)) + ;; on homehost and this is a write, we already have a server ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write (remote-server-url *runremote*)) ;; have a server (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4") (rmt:open-qry-close-locally cmd 0 params)) - ;; on homehost and this is a write, we have a server (we know because case 4 checked) - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost - (not (member cmd api:read-only-queries))) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") - (rmt:open-qry-close-locally cmd 0 params)) + + ;; commented by bb; this was blocking server passive start on write on homehost (case 5) + ;; ;; on homehost and this is a write, we have a server (we know because case 4 checked) + ;; ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ;; (not (member cmd api:read-only-queries))) + ;; (mutex-unlock! *rmt-mutex*) + ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") + ;; (rmt:open-qry-close-locally cmd 0 params)) + + ;; no server contact made and this is a write, passively start a server ((and (not (remote-server-url *runremote*)) (not (member cmd api:read-only-queries))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") (let ((serverconn (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call @@ -133,11 +141,16 @@ ((and (not (cdr (remote-hh-dat *runremote*))) ;; are we on a homehost? (not (remote-conndat *runremote*))) ;; and no connection (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*)) (mutex-unlock! *rmt-mutex*) (tasks:start-and-wait-for-server (tasks:open-db) 0 15) - (remote-conndat-set! *runremote* (rmt:get-connection-info 0)) ;; calls client:setup which calls client:setup-http + (let* ((cinfo (rmt:get-connection-info 0)) + (transport (if cinfo + (vector-ref cinfo 6) + (server:get-transport)))) ;; TODO: replace with tasks:server-dat-accessor-?? for transport + (remote-conndat-set! *runremote* cinfo) ;; calls client:setup which calls client:setup-http + (remote-transport-set! *runremote* transport)) (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; all set up if get this far, dispatch the query ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 7") @@ -150,20 +163,24 @@ (dat (case (remote-transport *runremote*) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away (http-transport:client-api-send-receive 0 conninfo cmd params) ((commfail)(vector #f "communications fail")) ((exn)(vector #f "other fail" (print-call-chain))))) + ((rpc) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away + (rpc-transport:client-api-send-receive 0 conninfo cmd params) + ((commfail)(vector #f "communications fail")) + ((exn)(vector #f "other fail" (print-call-chain))))) (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported") + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (1)") (exit)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat) (if success (case (remote-transport *runremote*) - ((http) res) + ((http rpc) res) (else (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown") (exit 1))) (begin (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) @@ -257,20 +274,28 @@ ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) - (set! *db-last-write* start-time) ;; the oldest "write" + (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) + (transport (or (remote-transport *runremote*) (server:get-transport))) (res (handle-exceptions exn #f - (http-transport:client-api-send-receive run-id connection-info cmd params)))) + (case transport + ((http) (http-transport:client-api-send-receive run-id connection-info cmd params)) + ((rpc) (rpc-transport:client-api-send-receive run-id connection-info cmd params)) + (else + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (2)") + (exit)) + + )))) (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) ;; ;; Wrap json library for strings (why the ports crap in the first place?) @@ -310,20 +335,30 @@ ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; (define (rmt:login-no-auto-client-setup connection-info) (case *transport-type* ;; run-id of 0 is just a placeholder - ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) + ((http rpc)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) + (else + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (3)") + (exit)) + + ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))) )) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) + +;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host +(define (rmt:get-latest-host-load hostname) + (rmt:send-receive 'get-latest-host-load 0 (list hostname))) + ;; (define (rmt:sync-inmem->db run-id) ;; (rmt:send-receive 'sync-inmem->db run-id '())) (define (rmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr @@ -330,10 +365,17 @@ (rmt:send-receive 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) + +;;====================================================================== +;; T E S T M E T A +;;====================================================================== + +(define (rmt:get-tests-tags) + (rmt:send-receive 'get-tests-tags #f '())) ;;====================================================================== ;; K E Y S ;;====================================================================== @@ -345,10 +387,15 @@ (define (rmt:get-keys) (if *db-keys* *db-keys* (let ((res (rmt:send-receive 'get-keys #f '()))) (set! *db-keys* res) res))) + +(define (rmt:get-keys-write) ;; dummy query to force server start + (let ((res (rmt:send-receive 'get-keys-write #f '()))) + (set! *db-keys* res) + res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; (define (rmt:get-key-vals run-id) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2016, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -21,208 +21,621 @@ (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (include "common_records.scm") (include "db_records.scm") + +(define *heartbeat-mutex* (make-mutex)) +(define *server-loop-heart-beat* (current-seconds)) + ;; procstr is the name of the procedure to be called as a string -(define (rpc-transport:autoremote procstr params) - (handle-exceptions - exn - (begin - (debug:print 1 *default-log-port* "Remote failed for " proc " " params) - (apply (eval (string->symbol procstr)) params)) - ;; (if *runremote* - ;; (apply (eval (string->symbol (conc "remote:" procstr))) params) - (apply (eval (string->symbol procstr)) params))) +(define (rpc-transport:autoremote procstr params) ;; may be unused, I think api-exec deprecates this one. + (let* ((procsym (if (symbol? procstr) + procstr + (string->symbol (->string procstr)))) + (res + (begin + (apply (eval procsym) params)))) + res)) + + +;; rpc receiver +(define (rpc-transport:api-exec cmd params) + (let* ( (resdat (api:execute-requests *dbstruct-db* (vector cmd params))) ;; #( flag result ) + (flag (vector-ref resdat 0)) + (res (vector-ref resdat 1))) + + (mutex-lock! *heartbeat-mutex*) + + (set! *last-db-access* (current-seconds)) ;; bump *last-db-access*; this will renew keep-running thread's lease on life for another (server:get-timeout) seconds + ;;(BB> "in api-exec; last-db-access updated to "*last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + + res)) + + +;; retry an operation (depends on srfi-18) +;; ================== +;; idea here is to avoid spending time on coding retrying something. Trying to be generic here. +;; +;; Exception handling: +;; ------------------- +;; if evaluating the thunk results in exception, it will be retried. +;; on last try, if final-failure-returns-actual is true, the exception will be re-thrown to caller. +;; +;; look at options below #!key to see how to configure behavior +;; +;; +(define (retry-thunk + the-thunk + #!key ;;;; options below + (accept-result? (lambda (x) x)) ;; retry if predicate applied to thunk's result is false + (retries 4) ;; how many tries + (failure-value #f) ;; return this on final failure, unless following option is enabled: + (final-failure-returns-actual #f) ;; on failure, on the last try, just return the result, not failure-value + + (retry-delay 0.1) ;; delay between tries + (back-off-factor 1) ;; multiply retry-delay by this factor on retry + (random-delay 0.1) ;; add a random portion of this value to wait + + (chatty #f) ;; print status as we go, for debugging. + ) + + (when chatty (print) (print "Entered retry-thunk") (print "-=-=-=-=-=-")) + (let* ((guarded-thunk ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. + (lambda () + (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision + (res + (condition-case + (the-thunk) ;; this is what we are guarding the execution of + [x () (cons EXCEPTION x)] + ))) + (cond + ((and (pair? res) (eq? (car res) EXCEPTION)) + (if chatty + (print " - the-thunk threw exception >"(cdr res)"<")) + (cons 'exception (cdr res))) + (else + (if chatty + (print " - the-thunk returned result >"res"<")) + (cons 'regular-result res))))))) + + (let loop ((guarded-res (guarded-thunk)) + (retries-left retries) + (fail-wait retry-delay)) + (if chatty (print " ==========")) + (let* ((wait-time (+ fail-wait (+ (* fail-wait back-off-factor) + (* random-delay + (/ (random 1024) 1024) )))) + (res-type (car guarded-res)) + (res-value (cdr guarded-res))) + (cond + ((and (eq? res-type 'regular-result) (accept-result? res-value)) + (if chatty (print " + return result that satisfied accept-result? >"res-value"<")) + res-value) + + ((> retries-left 0) + (if chatty (print " - sleep "wait-time)) + (thread-sleep! wait-time) + (if chatty (print " + retry ["retries-left" tries left]")) + (loop (guarded-thunk) + (sub1 retries-left) + wait-time)) + + ((eq? res-type 'regular-result) + (if final-failure-returns-actual + (begin + (if chatty (print " + last try failed- return the result >"res-value"<")) + res-value) + (begin + (if chatty (print " + last try failed- return canned failure value >"failure-value"<")) + failure-value))) + + (else ;; no retries left; result was not accepted and res-type can only be 'exception + (if final-failure-returns-actual + (begin + (if chatty (print " + last try failed with exception- re-throw it >"res-value"<")) + (abort res-value)); re-raise the exception. TODO: find a way for call-history to show as though from entry to this function + (begin + (if chatty (print " + last try failed with exception- return canned failure value >"failure-value"<")) + failure-value)))))))) + + +(define (rpc-transport:server-shutdown server-id rpc:listener ) ;;#!key (from-on-exit #f)) + ;;(on-exit (lambda () #t)) ;; turn off on-exit stuff + ;;(tcp-close rpc:listener) ;; gotta exit nicely + ;;(tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "stopped") + + + ;; TODO: (low) the following is extraordinaritly slow. Maybe we don't even need portlogger for rpc anyway?? the exception-based failover when ports are taken is fast! + ;;(portlogger:open-run-close portlogger:set-port (rpc:default-server-port) "released") + + (set! *time-to-exit* #t) + ;;(if *dbstruct-db* (db:sync-touched *dbstruct-db* *run-id* force-sync: #t)) + + (server:remove-dotserver-file *toppath* "anyhost:anyport" force: #t) + (tasks:server-delete-record (db:delay-if-busy (tasks:open-db)) server-id " rpc-transport:keep-running complete") + + (rpc:close-all-connections!) + ;;(BB> "Before (exit) (from-on-exit="from-on-exit")") + ;;(unless from-on-exit (exit)) ;; sometimes we hang (around) here with 100% cpu. + ;;(BB> "After") + ;; strace reveals endless: + ;; getrusage(RUSAGE_SELF, {ru_utime={413, 917868}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 9874}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 13874}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 105880}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 109880}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 201886}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 205886}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 297892}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 301892}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 393898}, ru_stime={0, 60003}, ...}) = 0 + ;; getrusage(RUSAGE_SELF, {ru_utime={414, 397898}, ru_stime={0, 60003}, ...}) = 0 + ;; make a post to chicken-users w/ http://paste.call-cc.org/paste?id=60a4b66a29ccf7d11359ea866db642c970735978 + + + ;; (if from-on-exit + ;; ;; avoid above condition! End current process externally since 1 in 20 (exit)'s result in hung, 100% cpu zombies. (see above) + + (system (conc "kill -9 "(current-process-id))) + ) + ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (rpc-transport:launch run-id) - (let* ((tdbdat (tasks:open-db))) - (BB> "rpc-transport:launch fired for run-id="run-id) - (set! *run-id* run-id) - (if (args:get-arg "-daemonize") - (daemon:ize)) - (if (server:check-if-running run-id) - (begin - (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") - (exit 0))) - (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) - (remtries 4)) - (if (not server-id) - (if (> remtries 0) - (begin - (thread-sleep! 2) - (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) - (- remtries 1))) - (begin - ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") - (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " rpc-transport:launch"))) - (begin - (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) - (exit)))))) + (set! *run-id* run-id) + + ;; ;; send to background if requested + ;; (when (args:get-arg "-daemonize") + ;; (daemon:ize) + ;; (when *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it + ;; (current-error-port *alt-log-file*) + ;; (current-output-port *alt-log-file*))) + + ;; double check we dont alrady have a running server for this run-id + (when (and (server:read-dotserver *toppath*) + (server:check-if-running run-id)) + (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") + (exit 0)) + + ;; did not find server running, let's clean up the table of dead servers + (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy (tasks:open-db)) run-id "notresponding") + + (server:dotserver-starting) + + + + + + ;; let's get a server-id for this server + ;; if at first we do not suceed, try 3 more times. + (let ((server-id (retry-thunk + (lambda () (tasks:server-lock-slot (db:delay-if-busy (tasks:open-db)) run-id 'rpc)) + chatty: #f + final-failure-returns-actual: #t + retries: 4))) + (when (not server-id) ;; dang we couldn't get a server-id. + ;; since we didn't get the server lock we are going to clean up and bail out + + + (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (tasks:server-delete-records-for-this-pid (db:delay-if-busy (tasks:open-db)) " rpc-transport:launch") + (server:dotserver-starting-remove) + (exit 1)) + + ;; we got a server-id (and a corresponding entry in servers table in globally shared mdb) + ;; all systems go. Proceed to setup rpc server. + (rpc-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + run-id + server-id) + (exit))) + +(define *rpc-listener-port* #f) +(define *rpc-listener-port-bind-timestamp* #f) + +(define *on-exit-flag #f) + +(define (rpc-transport:server-dat-get-iface vec) (vector-ref vec 0)) +(define (rpc-transport:server-dat-get-port vec) (vector-ref vec 1)) +(define (rpc-transport:server-dat-get-last-access vec) (vector-ref vec 5)) +(define (rpc-transport:server-dat-get-transport vec) (vector-ref vec 6)) +(define (rpc-transport:server-dat-update-last-access vec) + (if (vector? vec) + (vector-set! vec 5 (current-seconds)) + (begin + (print-call-chain (current-error-port)) + (debug:print-error 0 *default-log-port* "call to rpc-transport:server-dat-update-last-access with non-vector!!")))) + + +(define *api-exec-ht* (make-hash-table)) +(define *api-exec-mutex* (make-mutex)) +;; let's see if caching the rpc stub curbs thread-profusion on server side +(define (rpc-transport:get-api-exec iface port) + (mutex-lock! *api-exec-mutex*) + (let* ((lu (hash-table-ref/default *api-exec-ht* (cons iface port) #f))) + (if lu + (begin + (mutex-unlock! *api-exec-mutex*) + lu) + (let ((res (rpc:procedure 'api-exec iface port))) + (hash-table-set! *api-exec-ht* (cons iface port) res) + (mutex-unlock! *api-exec-mutex*) + res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; this client-side procedure makes rpc call to server and returns result +;; +(define (rpc-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) + ;;(BB> "entered rpc-transport:client-api-send-receive with run-id="run-id " serverdat="serverdat" cmd="cmd" params="params" numretries="numretries) + (if (not (vector? serverdat)) + (begin + (BB> "WHAT?? for run-id="run-id", serverdat="serverdat) + (print-call-chain) + (rpc:close-all-connections!) + (exit 1))) + (let* ((iface (rpc-transport:server-dat-get-iface serverdat)) + (port (rpc-transport:server-dat-get-port serverdat)) + (res #f) + (api-exec (rpc-transport:get-api-exec iface port)) ;; chached by host/port. may need to clear... + (send-receive (lambda () + (tcp-buffer-size 0) + (set! res (retry-thunk + (lambda () + (condition-case + ;;(vector #t (run-remote cmd params)) + (vector 'success (api-exec cmd params)) + [x (exn i/o net) (vector 'comms-fail (conc "communications fail ["(->string x)"]") x)] + [x () (vector 'other-fail "other fail ["(->string x)"]" x)])) + chatty: #f + accept-result?: (lambda(x) + (and (vector? x) (vector-ref x 0))) + retries: 8 + back-off-factor: 1.5 + random-wait: 0.2 + retry-delay: 0.1 + final-failure-returns-actual: #t)) + ;;(BB> "HEY res="res) + res + )) + (th1 (make-thread send-receive "send-receive")) + (time-out-reached #f) + (time-out (lambda () + (thread-sleep! 45) + (set! time-out-reached #t) + (thread-terminate! th1) + + #f)) + + (th2 (make-thread time-out "time out"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (thread-terminate! th2) + ;;(BB> "alt got res="res) + (debug:print-info 11 *default-log-port* "got res=" res) + (if (vector? res) + (case (vector-ref res 0) + ((success) (vector #t (vector-ref res 1))) + ( + (comms-fail other-fail) + ;;(comms-fail) + (debug:print 0 *default-log-port* "WARNING: comms failure for rpc request >>"res"<<") + ;;(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #f (vector-ref res 1))) + (else + (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref res 1)) + (debug:print 0 *default-log-port* " client call chain:") + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " server call chain:") + (pp (vector-ref res 1) (current-error-port)) + (signal (vector-ref res 2)))) + (signal (make-composite-condition + (make-property-condition + 'timeout + 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) + + (define (rpc-transport:run hostn run-id server-id) (debug:print 2 *default-log-port* "Attempting to start the rpc server ...") ;; (trace rpc:publish-procedure!) - (rpc:publish-procedure! 'server:login server:login) - (rpc:publish-procedure! 'testing (lambda () "Just testing")) + ;;====================================================================== + ;; start of publish-procedure section + ;;====================================================================== + (rpc:publish-procedure! 'server:login server:login) ;; this allows client to validate it is the same megatest instance as the server. No security here, just making sure we're in the right room. + (rpc:publish-procedure! + 'testing + (lambda () + "Just testing")) + + ;; procedure to receive arbitrary API request from client's rpc:send-receive/rpc-transport:client-api-send-receive + (rpc:publish-procedure! 'rpc-transport:autoremote rpc-transport:autoremote) + ;; can use this to run most anything at the remote + (rpc:publish-procedure! 'api-exec rpc-transport:api-exec) + + + ;;====================================================================== + ;; end of publish-procedure section + ;;====================================================================== + (let* ((db #f) - (hostname (get-host-name)) - (ipaddrstr (let ((ipstr (if (string=? "-" hostn) + (hostname (let ((res (get-host-name))) res)) + (server-start-time (current-seconds)) + (server-timeout (server:get-timeout)) + (ipaddrstr (let* ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) - #f))) - (if ipstr ipstr hostn))) ;; hostname))) - (start-port (open-run-close tasks:server-get-next-port tasks:open-db)) + #f)) + (res (if ipstr ipstr hostn))) + res)) ;; hostname))) + (start-port (let ((res (portlogger:open-run-close portlogger:find-port))) ;; BB> TODO: remove portlogger! + res)) (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; rpc:listener is the tcp-listen result from inside the find-free-port-and-open complex. + ;; It is our handle on the listening tcp port + ;; We will attach this to our rpc server with rpc:make-server in thread th1 . + (rpc:listener (rpc-transport:find-free-port-and-open start-port)) (th1 (make-thread (lambda () - ((rpc:make-server rpc:listener) #t)) + ;;(BB> "BEFORE rpc:make-server") + ((rpc:make-server rpc:listener) #t) + ;;(BB> "BEFORE rpc:make-server") + ) "rpc:server")) - ;; (cute (rpc:make-server rpc:listener) "rpc:server") - ;; 'rpc:server)) - (hostname (if (string=? "-" hostn) + + + (hostname (if (string=? "-" hostn) (get-host-name) hostn)) (ipaddrstr (if (string=? "-" hostn) (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f)) - (portnum (rpc:default-server-port)) - (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum)) - (tdb (tasks:open-db))) + (string-intersperse + (map number->string + (u8vector->list + (hostname->ip hostn))) ".") + )) + (portnum (let ((res (rpc:default-server-port))) res)) + (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))) + + (when (not (equal? ipaddrstr (server:get-best-guess-address (get-host-name)))) + + (debug:print 0 *default-log-port* "Error: This host "(ip->string (hostname->ip (get-host-name)))" ("(get-host-name)") is not the homehost "ipaddrstr" ("(ip->hostname (string->ip ipaddrstr))"; Cannot proceed.") + (server:dotserver-starting-remove) + (tcp-close rpc:listener) ;; gotta exit nicely and free up that tcp port + (exit)) + + (tasks:server-set-interface-port (db:delay-if-busy (tasks:open-db)) server-id ipaddrstr portnum) + + ;;============================================================ + ;; activate thread th1 to attach opened tcp port to rpc server + ;;============================================================= (thread-start! th1) (set! db *dbstruct-db*) - (open-run-close tasks:server-set-interface-port - tasks:open-db - server-id - ipaddrstr portnum) + (debug:print 0 *default-log-port* "Server started on " host:port) - - ;; (trace rpc:publish-procedure!) - ;; (rpc:publish-procedure! 'server:login server:login) - ;; (rpc:publish-procedure! 'testing (lambda () "Just testing")) - - ;;====================================================================== - ;; ;; end of publish-procedure section - ;;====================================================================== - ;; - (on-exit (lambda () - (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped"))) - - (set! *rpc:listener* rpc:listener) - (tasks:server-set-state! tdb server-id "running") - (set! *dbstruct-db* (db:setup run-id)) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - (let loop ((count 0)) - (thread-sleep! 5) ;; no need to do this very often - (let ((numrunning -1)) ;; (db:get-count-tests-running db))) - (if (or (> numrunning 0) - (> (+ *db-last-access* 60)(current-seconds))) - (begin - (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *db-last-access*)) - (loop (+ 1 count))) - (begin - (debug:print-info 0 *default-log-port* "Starting to shutdown the server side") - (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop") - (thread-sleep! 10) - (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) - (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") - )))))) - -(define (rpc-transport:find-free-port-and-open port) + ;;(BB> "before SELF-TEST") + (if (retry-thunk (lambda () + (rpc-transport:self-test run-id ipaddrstr portnum)) + final-failure-returns-actual: #t ;; TODO: remove this line + ) + (debug:print 0 *default-log-port* "INFO: rpc self test passed!") + (begin + (debug:print 0 *default-log-port* "Error: rpc listener did not pass self test. Shutting down. On: " host:port) + (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "dead") + (tcp-close rpc:listener) ;; gotta exit nicely and free up that tcp port + (rpc-transport:server-shutdown server-id rpc:listener) + (server:dotserver-starting-remove) + (exit))) + + + + + ;;(on-exit (lambda () + ;; (rpc-transport:server-shutdown server-id rpc:listener from-on-exit: #t))) + + ;; check again for running servers for this run-id in case one has snuck in since we checked last in rpc-transport:launch + (if (not (equal? server-id (tasks:server-am-i-the-server? (db:delay-if-busy (tasks:open-db)) run-id)));; try to ensure no double registering of servers + (begin ;; i am not the server, another server snuck in and beat this one to the punch + (tcp-close rpc:listener) ;; gotta exit nicely and free up that tcp port + (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "collision") + (server:dotserver-starting-remove)) + + (begin ;; i am the server + ;; setup the in-memory db + (set! *dbstruct-db* (db:setup run-id)) + (db:get-db *dbstruct-db* run-id) + + ;; at this point, satisfied server has started + ;; let's make it official + (server:write-dotserver *toppath* (conc ipaddrstr ":" portnum)) + (mutex-lock! *heartbeat-mutex*) + (set! *last-db-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*) + (set! *rpc:listener* rpc:listener) + (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "running") ;; update our mdb servers entry + + + + ;; this let loop will hold open this thread until we want the server to shut down. + ;; if no requests received within the last 20 seconds : + ;; database hasnt changed in ?? + ;; + + + + ;; keep-running loop: polls last-db-access to see if we have timed out. keep running if not. + (let loop ((count 0) + (bad-sync-count 0)) + (BB> "keep running: count = "count) + ;; Use this opportunity to sync the inmemdb to db + + (let ((start-time (current-milliseconds)) + (sync-time #f) + (rem-time #f)) + + ;; following is now done in common:watchdog, commenting out. sync-time will now be 0; can live with that. + ;; ;; inmemddb is a dbstruct + ;; (condition-case + ;; (db:sync-touched *dbstruct-db* *run-id* force-sync: #t) + ;; ((sync-failed)(cond + ;; ((> bad-sync-count 10) ;; time to give up + ;; (rpc-transport:server-shutdown server-id rpc:listener)) + ;; (else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop + ;; (thread-sleep! 5) + ;; (loop count (+ bad-sync-count 1))))) + ;; ((exn) + ;; (debug:print-error 0 *default-log-port* "error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server ") + ;; (rpc-transport:server-shutdown server-id rpc:listener))) + + (set! sync-time (- (current-milliseconds) start-time)) + (set! rem-time (quotient (- 4000 sync-time) 1000)) + (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time) + + (if (and (<= rem-time 4) + (> rem-time 0)) + (thread-sleep! rem-time) + (thread-sleep! 4))) ;; fallback for if the math is changed ... + + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1) bad-sync-count)) + + ;; BB: don't see how this is possible with RPC + ;; ;; Check that iface and port have not changed (can happen if server port collides) + ;; (mutex-lock! *heartbeat-mutex*) + ;; (set! sdat *server-info*) + ;; (mutex-unlock! *heartbeat-mutex*) + + ;; (if (or (not (equal? sdat (list iface port))) + ;; (not server-id)) + ;; (begin + ;; (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info") + ;; (set! iface (car sdat)) + ;; (set! port (cadr sdat)))) + + ;; Transfer *last-db-access* to last-access to use in checking that we are still alive + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + + ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout) + ;; + ;; no_traffic, no running tests, if server 0, no running servers + ;; + ;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) + ;; + (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) + (adjusted-timeout (if (> hrs-since-start 1) + (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour + server-timeout))) + (if (common:low-noise-print 120 "server timeout") + (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout)) + (if (and *server-run* + (> (+ last-access server-timeout) + (current-seconds))) + (begin + (if (common:low-noise-print 120 "server continuing") + (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) + ;; + ;; Consider implementing some smarts here to re-insert the record or kill self is + ;; the db indicates so + ;; + (if (tasks:server-am-i-the-server? (db:delay-if-busy (tasks:open-db)) run-id) + (tasks:server-set-state! (db:delay-if-busy (tasks:open-db)) server-id "running")) + ;; + (loop 0 bad-sync-count)) + (begin + ;;(BB> "SERVER SHUTDOWN CALLED! last-access="last-access" current-seconds="(current-seconds)" server-timeout="server-timeout) + + (rpc-transport:server-shutdown server-id rpc:listener))))) + ;; end new loop + )))) + + +(define (rpc-transport:find-free-port-and-open port #!key ) (handle-exceptions exn - (begin + (begin (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") - (rpc-transport:find-free-port-and-open (+ port 1))) + (rpc-transport:find-free-port-and-open (add1 port))) (rpc:default-server-port port) + (set! *rpc-listener-port* port) ;; a bit paranoid about rpc:default-server-port parameter not changing across threads (as params are wont to do). keeping this global in my back pocket in case this causes problems + (set! *rpc-listener-port-bind-timestamp* (current-milliseconds)) ;; may want to test how long it has been since the last bind attempt happened... (tcp-read-timeout 240000) - (tcp-listen (rpc:default-server-port) 10000))) - + (tcp-buffer-size 0) ;; gotta do this because http-transport undoes it. + (tcp-listen (rpc:default-server-port) 10000) + )) + (define (rpc-transport:ping run-id host port) (handle-exceptions exn (begin - (print "SERVER_NOT_FOUND") + (print "SERVER_NOT_FOUND exn="exn) (exit 1)) (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) - (if (and (list? login-res) - (car login-res)) + (if login-res (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1)))))) -(define (rpc-transport:client-setup run-id #!key (remtries 10)) - (if *runremote* - (begin - (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected") - #f) - (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER")) - (if host-info - (let ((iface (car host-info)) - (port (cadr host-info)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) - (if ping-res - (let ((server-dat (list iface port #f #f #f))) - (hash-table-set! *runremote* run-id server-dat) - server-dat) - (begin - (server:try-running run-id) - (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) - (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) - (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if server-db-info - (let* ((iface (tasks:hostinfo-get-interface server-db-info)) - (port (tasks:hostinfo-get-port server-db-info)) - (server-dat (list iface port #f #f #f)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) - (if start-res - (begin - (hash-table-set! *runremote* run-id server-dat) - server-dat) - (begin - (server:try-running run-id) - (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) - (begin - (server:try-running run-id) - (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))))))) -;; -;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) -;; (if (and port -;; (string->number port)) -;; (let ((portn (string->number port))) -;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port) -;; (handle-exceptions -;; exn -;; (begin -;; (debug:print-error 0 *default-log-port* "Failed to open a connection to the server at host: " host " port: " port) -;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) -;; ;; (open-run-close -;; ;; (lambda (db . param) -;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) -;; ;; #f) -;; (set! *runremote* #f)) -;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server -;; ((rpc:procedure 'server:login host portn) *toppath*)) -;; (begin -;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port) -;; (set! *runremote* (vector host portn))) -;; (begin -;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port) -;; (set! *runremote* #f))))) -;; (debug:print-info 2 *default-log-port* "no server available"))))) - +(define (rpc-transport:self-test run-id host port) + (if (not host) + (abort "host not set.")) + (if (not port) + (abort "port not set.")) + (tcp-buffer-size 0) ;; gotta do this because http-transport undoes it. + (let* ((testing-res ((rpc:procedure 'testing host port))) + (login-res ((rpc:procedure 'server:login host port) *toppath*)) + (res (and login-res (equal? testing-res "Just testing")))) + + (if login-res + (begin + ;;(BB> "Self test PASS. login-res="login-res" testing-res="testing-res" *toppath*="*toppath*) + #t) + (begin + (BB> "Self test fail. login-res="login-res" testing-res="testing-res" *toppath*="*toppath*) + + #f)) + res)) + +(define (rpc-transport:client-setup run-id server-dat #!key (remaining-tries 10)) + ;;(BB> "entered rpc-transport:client-setup with run-id="run-id" and server-dat="server-dat" and retries="remaining-tries) + (tcp-buffer-size 0) + (debug:print-info 0 *default-log-port* "rpc-transport:client-setup run-id="run-id" server-dat=" server-dat ", remaining-tries=" remaining-tries) + (let* ((iface (tasks:hostinfo-get-interface server-dat)) + (hostname (tasks:hostinfo-get-hostname server-dat)) + (port (tasks:hostinfo-get-port server-dat)) + (runremote-server-dat (vector iface port #f #f #f (current-seconds) 'rpc)) ;; http version := (vector iface port api-uri api-url api-req (current-seconds) 'http ) + (ping-res (retry-thunk (lambda () ;; make 3 attempts to ping. + ((rpc:procedure 'server:login iface port) *toppath*)) + chatty: #f + retries: 3))) + ;; we got here from rmt:get-connection-info on the condition that *runremote* has no entry for run-id... + (if ping-res + (begin + (debug:print-info 0 *default-log-port* "rpc-transport:client-setup CONNECTION ESTABLISHED run-id="run-id" server-dat=" server-dat) + runremote-server-dat) + (begin ;; login failed but have a server record, clean out the record and try again + (debug:print-info 0 *default-log-port* "rpc-transport:client-setup UNABLE TO CONNECT run-id="run-id" server-dat=" server-dat) + (tasks:kill-server-run-id run-id) + (tasks:server-force-clean-run-record (db:delay-if-busy (tasks:open-db)) run-id iface port + " rpc-transport:client-setup (server-dat = #t)") + (if (> remaining-tries 2) + (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little + (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time + (server:try-running run-id) + (thread-sleep! 5) ;; give server a little time to start up + (client:setup run-id remaining-tries: (sub1 remaining-tries)))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1958,10 +1958,23 @@ (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) + +;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." +;; +(define (runs:get-tests-matching-tags tagpatt) + (let* ((tagdata (rmt:get-tests-tags)) + (res '())) ;; list of tests that match one or more tags + (for-each + (lambda (tag) + (if (patt-list-match tag tagpatt) + (set! res (append (hash-table-ref tagdata tag))))) + (hash-table-keys tagdata)) + res)) + ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each ADDED sample-sauth-paths.scm Index: sample-sauth-paths.scm ================================================================== --- /dev/null +++ sample-sauth-paths.scm @@ -0,0 +1,4 @@ +(define *db-path* "/path/to/db") +(define *exe-path* "/path/to/store/suids") +(define *exe-src* "/path/to/spublish/and/sretrieve/executables") +(define *sauth-path* "/path/to/production/sauthorize/exe") ADDED sauth-common.scm Index: sauth-common.scm ================================================================== --- /dev/null +++ sauth-common.scm @@ -0,0 +1,263 @@ + +;; Create the sqlite db +(define (sauthorize:db-do proc) + (if (or (not *db-path*) + (not (file-exists? *db-path*))) + (begin + (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!") + (exit 1))) + (if (and *db-path* + (directory? *db-path*) + (file-read-access? *db-path*)) + (let* ((dbpath (conc *db-path* "/sauthorize.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit 1)) + ; (print "calling proc " proc "db path " dbpath ) + (call-with-database + dbpath + (lambda (db) + ;(print 0 "calling proc " proc " on db " db) + (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout + (if (not dbexists)(sauthorize:initialize-db db)) + (proc db))))) + (print 0 "ERROR: invalid path for storing database: " *db-path*))) + +;;execute a query +(define (sauthorize:db-qry db qry) + (exec (sql db qry))) + + +(define (sauthorize:do-as-calling-user proc) + (let ((eid (current-effective-user-id)) + (cid (current-user-id))) + (if (not (eq? eid cid)) ;; running suid + (set! (current-effective-user-id) cid)) + ;(print 0 "cid " cid " eid:" eid) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + + +(define (run-cmd cmd arg-list) + ; (print (current-effective-user-id)) + ;(handle-exceptions +; exn +; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert)) + (let ((pid (process-run cmd arg-list))) + (process-wait pid)) +) +;) + + +(define (regster-log inl usr-id area-id cmd) + (sauth-common:shell-do-as-adm + (lambda () + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )"))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Check user types +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;check if a user is an admin +(define (is-admin username) + (let* ((admin #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) + (if (not (null? data-row)) + (let ((col (car data-row))) + (if (equal? col "yes") + (set! admin #t))))))) +admin)) + + +;;check if a user is an read-admin +(define (is-read-admin username) + (let* ((admin #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) + (if (not (null? data-row)) + (let ((col (car data-row))) + (if (equal? col "read-admin") + (set! admin #t))))))) +admin)) + + +;;check if user has specifc role for a area +(define (is-user role username area) + (let* ((has-access #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'"))))) + (if (not (null? data-row)) + (begin + (let* ((access-type (car data-row)) + (exdate (cadr data-row))) + (if (not (null? exdate)) + (begin + (let ((valid (is-access-valid exdate))) + ;(print valid) + (if (and (equal? access-type role) + (equal? valid #t)) + (set! has-access #t)))) + (print "Access expired")))))))) + ;(print has-access) +has-access)) + +(define (is-access-valid exp-str) + (let* ((ret-val #f ) + (date-parts (string-split exp-str "/")) + (yr (string->number (car date-parts))) + (month (string->number(car (cdr date-parts)))) + (day (string->number(caddr date-parts))) + (exp-date (make-date 0 0 0 0 day month yr ))) + ;(print exp-date) + ;(print (current-date)) + (if (> (date-compare exp-date (current-date)) 0) + (set! ret-val #t)) + ;(print ret-val) + ret-val)) + + +;check if area exists +(define (area-exists area) + (let* ((area-defined #f)) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) + (if (not (null? data-row)) + (set! area-defined #t))))) +area-defined)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Get Record from database +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;gets area id by code +(define (get-area area) + (let* ((area-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) + (set! area-defined data-row)))) +area-defined)) + +;get id of users table by user name +(define (get-user user) + (let* ((user-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'"))))) + (set! user-defined data-row)))) +user-defined)) + +;get permissions id by userid and area id +(define (get-perm userid areaid) + (let* ((user-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid))))) + (set! user-defined data-row)))) + +user-defined)) + +(define (get-restrictions base-path usr) +(let* ((user-defined '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'"))))) + ;(print data-row) + (set! user-defined data-row)))) + ; (print user-defined) + (if (null? user-defined) + "" + (car user-defined)))) + + +(define (get-obj-by-path path) + (let* ((obj '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'"))))) + (set! obj data-row)))) +obj)) + +(define (get-obj-by-code code ) + (let* ((obj '())) + (sauthorize:db-do (lambda (db) + (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'"))))) + (set! obj data-row)))) +;(print obj) +obj)) + + + +;; function to validate the users input for target path and resolve the path +;; TODO: Check for restriction in subpath +(define (sauth-common:resolve-path new current allowed-sheets) + (let* ((target-path (append current (string-split new "/"))) + (target-path-string (string-join target-path "/")) + (normal-path (normalize-pathname target-path-string)) + (normal-list (string-split normal-path "/")) + (ret '())) + (if (string-contains normal-path "..") + (begin + (print "ERROR: Path " new " resolved outside target area ") + #f) + (if(equal? normal-path ".") + ret + (if (not (member (car normal-list) allowed-sheets)) + (begin + (print "ERROR: Permision denied to " new ) + #f) + normal-list))))) + +(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )) + (usr (current-user-name) ) ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + #f + (let* ((sheet (car resolved-path)) + (restricted-areas (get-restrictions base-path usr)) + (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*")) + (target-path (if (null? (cdr resolved-path)) + base-path + (conc base-path "/" (string-join (cdr resolved-path) "/"))))) + ; (print restricted-areas) + (if (and (not (equal? restricted-areas "" )) + (string-match (regexp restrictions) target-path)) + (begin + (print "Access denied to " (string-join resolved-path "/")) + ;(exit 1) + #f) + target-path))) + #f))) + +(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) + (if (and (null? base-path-list) (equal? ext-path "") ) + (print (string-intersperse top-areas " ")) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))) + ;(print resolved-path) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print (string-intersperse top-areas " ")) + (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path))) + (print target-path) + (if (not (equal? target-path #f)) + (begin + (cond + ((null? tail-cmd-list) + (run (pipe + (ls "-lrt" ,target-path)))) + ((not (equal? (car tail-cmd-list) "|")) + (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!")) + (else + (run (pipe + (ls "-lrt" ,target-path) + (begin (system (string-join (cdr tail-cmd-list)))))) + ) +))) +)))))) + ADDED sauthorize.scm Index: sauthorize.scm ================================================================== --- /dev/null +++ sauthorize.scm @@ -0,0 +1,544 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use defstruct) +(use scsh-process) + +(use srfi-18) +(use srfi-19) +(use refdb) + +(use sql-de-lite srfi-1 posix regex regex-case srfi-69) +(declare (uses common)) + +(declare (uses configf)) +(declare (uses margs)) +(declare (uses megatest-version)) + +(include "megatest-fossil-hash.scm") +;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. +(include "sauth-paths.scm") +(include "sauth-common.scm") + +;; +;; GLOBALS +;; +(define *verbosity* 1) +(define *logging* #f) +(define *exe-name* (pathname-file (car (argv)))) +(define *sretrieve:current-tab-number* 0) +(define *args-hash* (make-hash-table)) +(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]] + + list : list areas $USER's can access + log : get listing of recent activity. + sauth list-area-user : list the users that can access the area. + sauth open --group : Open up an area. User needs to be the owner of the area to open it. + --code + --retrieve|--publish + sauth grant --area : Grant permission to read or write to a area that is alrady opend up. + --expiration yyyy/mm/dd --retrieve|--publish + [--restrict ] + sauth read-shell : Open sretrieve shell for reading. + sauth write-shell : Open spublish shell for writing. + +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) ;; " + +;;====================================================================== +;; RECORDS +;;====================================================================== + +;;====================================================================== +;; DB +;;====================================================================== + +;; replace (strftime('%s','now')), with datetime('now')) +(define (sauthorize:initialize-db db) + (for-each + (lambda (qry) + (exec (sql db qry))) + (list + "CREATE TABLE IF NOT EXISTS actions + (id INTEGER PRIMARY KEY, + cmd TEXT NOT NULL, + user_id INTEGER NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')), + area_id INTEGER NOT NULL, + comment TEXT DEFAULT '' NOT NULL, + action_type TEXT NOT NULL);" + "CREATE TABLE IF NOT EXISTS users + (id INTEGER PRIMARY KEY, + username TEXT NOT NULL, + is_admin TEXT NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')) + );" + "CREATE TABLE IF NOT EXISTS areas + (id INTEGER PRIMARY KEY, + basepath TEXT NOT NULL, + code TEXT NOT NULL, + exe_name TEXT NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')) + );" + "CREATE TABLE IF NOT EXISTS permissions + (id INTEGER PRIMARY KEY, + access_type TEXT NOT NULL, + user_id INTEGER NOT NULL, + datetime TIMESTAMP DEFAULT (datetime('now','localtime')), + area_id INTEGER NOT NULL, + restriction TEXT DEFAULT '' NOT NULL, + expiration TIMESTAMP DEFAULT NULL);" + ))) + + + + +(define (get-access-type args) + (let loop ((hed (car args)) + (tal (cdr args))) + (cond + ((equal? hed "--retrieve") + "retrieve") + ((equal? hed "--publish") + "publish") + ((equal? hed "--area-admin") + "area-admin") + ((equal? hed "--writer-admin") + "writer-admin") + ((equal? hed "--read-admin") + "read-admin") + + ((null? tal) + #f) + (else + (loop (car tal)(cdr tal)))))) + + + +;; check if user can gran access to an area +(define (can-grant-perm username access-type area) + (let* ((isadmin (is-admin username)) + (is-area-admin (is-user "area-admin" username area )) + (is-read-admin (is-user "read-admin" username area) ) + (is-writer-admin (is-user "writer-admin" username area) ) ) + (cond + ((equal? isadmin #t) + #t) + ((equal? is-area-admin #t ) + #t) + ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve")) + #t) + ((and (equal? is-read-admin #t ) (equal? access-type "retrieve")) + #t) + + (else + #f)))) + +(define (sauthorize:list-areausers area ) + (sauthorize:db-do (lambda (db) + (print "Users having access to " area ":") + (query (for-each-row + (lambda (row) + (let* ((exp-date (cadr row))) + (if (is-access-valid exp-date) + (apply print (intersperse row " | ")))))) + (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'")))))) + + + + +; check if executable exists +(define (exe-exist exe access-type) + (let* ((filepath (conc *exe-path* "/" access-type "/" exe))) + ; (print filepath) + (if (file-exists? filepath) + #t + #f))) + +(define (copy-exe access-type exe-name group) + (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type))) + (let* ((spath (conc *exe-src* "/s" access-type)) + (dpath (conc *exe-path* "/" access-type "/" exe-name))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd "/bin/cp" (list spath dpath )) + (if (equal? access-type "publish") + (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) + (begin + (if (equal? group "none") + (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) + (begin + (run-cmd "/bin/chgrp" (list group dpath)) + (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath)))))))) + (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type))))) + +(define (get-exe-name path group) + (let ((name "")) + (sauthorize:do-as-calling-user + (lambda () + (if (equal? (current-effective-user-id) (file-owner path)) + (set! name (conc (current-user-name) "_" group)) + (begin + (print "You cannot open areas that you dont own!!") + (exit 1))))) +name)) + +;check if a paths/codes are vaid and if area is alrady open +(define (open-area group path code access-type) + (let* ((exe-name (get-exe-name path group)) + (path-obj (get-obj-by-path path)) + (code-obj (get-obj-by-code code))) + ;(print path-obj) + (cond + ((not (null? path-obj)) + (if (equal? code (car path-obj)) + (begin + (if (equal? exe-name (cadr path-obj)) + (begin + (if (not (exe-exist exe-name access-type)) + (copy-exe access-type exe-name group) + (begin + (print "Area already open!!") + (exit 1)))) + (begin + (if (not (exe-exist exe-name access-type)) + (copy-exe access-type exe-name group)) + ;; update exe-name in db + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj))))) + ))) + (begin + (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type ) + (exit 1)))) + + ((not (null? code-obj)) + (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) + (exit 1)) + (else + ; (print (exe-exist exe-name access-type)) + (if (not (exe-exist exe-name access-type)) + (copy-exe access-type exe-name group)) + (sauthorize:db-do (lambda (db) + ;(print (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")) + (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")))))))) + +(define (user-has-open-perm user path access) + (let* ((has-access #f) + (eid (current-user-id))) + (cond + ((is-admin user) + (set! has-access #t )) + ((and (is-read-admin user) (equal? access "retrieve")) + (set! has-access #t )) + (else + (print "User " user " does not have permission to open areas"))) + has-access)) + + +;;check if user has group access +(define (is-group-washed req_grpid current-grp-list) + (let loop ((hed (car current-grp-list)) + (tal (cdr current-grp-list))) + (cond + ((equal? hed req_grpid) + #t) + ((null? tal) + #f) + (else + (loop (car tal)(cdr tal)))))) + +;create executables with appropriate suids +(define (sauthorize:open user path group code access-type) + (let* ((gpid (group-information group)) + (req_grpid (if (equal? group "none") + group + (if (equal? gpid #f) + #f + (caddr gpid)))) + (current-grp-list (get-groups)) + (valid-grp (if (equal? group "none") + group + (is-group-washed req_grpid current-grp-list)))) + (if (and (not (equal? group "none")) (equal? valid-grp #f )) + (begin + (print "Group " group " is not washed in the current xterm!!") + (exit 1)))) + (if (not (file-write-access? path)) + (begin + (print "You can open areas owned by yourself. You do not have permissions to open path." path) + (exit 1))) + (if (user-has-open-perm user path access-type) + (begin + ;(print "here") + (open-area group path code access-type) + (sauthorize:grant user user code "2017/12/25" "read-admin" "") + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )")))) + (print "Area has " path " been opened for " access-type )))) + +(define (sauthorize:grant auser guser area exp-date access-type restrict) + ; check if user exist + (let* ((area-obj (get-area area)) + (auser-obj (get-user auser)) + (user-obj (get-user guser))) + + (if (null? user-obj) + (begin + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') ")))) + (set! user-obj (get-user guser)))) + (let* ((perm-obj (get-perm (car user-obj) (car area-obj)))) + (if(null? perm-obj) + (begin + ;; insert permissions + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')"))))) + (begin + ;update permissions + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj))))))) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )")))) + (print "Permission has been sucessfully granted to user " guser)))) + +(define (sauthorize:process-action username action . args) + (case (string->symbol action) + ((grant) + (if (< (length args) 6) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0)) + (guser (car args)) + (restrict (or (args:get-arg "--restrict") "")) + (area (or (args:get-arg "--area") "")) + (exp-date (or (args:get-arg "--expiration") "")) + (access-type (get-access-type remargs))) + ; (print "version " guser " restrict " restrict ) + ; (print "area " area " exp-date " exp-date " access-type " access-type) + (cond + ((equal? guser "") + (print "Username not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? area "") + (print "Area not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? access-type #f) + (print "Access type not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? exp-date "") + (print "Date of expiration not found!! Try \"sauthorize help\" for useage ") + (exit 1))) + (if (not (area-exists area)) + (begin + (print "Area does not exisit!!") + (exit 1))) + (if (can-grant-perm username access-type area) + (begin + (print "calling sauthorize:grant ") + (sauthorize:grant username guser area exp-date access-type restrict)) + (begin + (print "User " username " does not have permission to grant permissions to area " area "!!") + (exit 1))))) + ((list-area-user) + (if (not (equal? (length args) 1)) + (begin + (print "Missing argument area code to list-area-user ") + (exit 1))) + (let* ((area (car args))) + (if (not (area-exists area)) + (begin + (print "Area does not exisit!!") + (exit 1))) + + (sauthorize:list-areausers area ) + )) + ((read-shell) + (if (not (equal? (length args) 1)) + (begin + (print "Missing argument area code to read-shell ") + (exit 1))) + (let* ((area (car args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "retrieve"))) + (begin + (print "Area " area " is not open for reading!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area )))))) + ((write-shell) + (if (not (equal? (length args) 1)) + (begin + (print "Missing argument area code to read-shell ") + (exit 1))) + (let* ((area (car args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "publish"))) + (begin + (print "Area " area " is not open for Writing!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area)))))) + ((publish) + (if (< (length args) 2) + (begin + (print "Missing argument to publish. \n publish [opts] ") + (exit 1))) + (let* ((action (car args)) + (area (cadr args)) + (cmd-args (cddr args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "publish"))) + (begin + (print "Area " area " is not open for writing!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) + + ((retrieve) + (if (< (length args) 2) + (begin + (print "Missing argument to publish. \n publish [opts] ") + (exit 1))) + (let* ((action (car args)) + (area (cadr args)) + (cmd-args (cddr args)) + (code-obj (get-obj-by-code area))) + (if (or (null? code-obj) + (not (exe-exist (cadr code-obj) "retrieve"))) + (begin + (print "Area " area " is not open for reading!!") + (exit 1))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) + + + + ((open) + (if (< (length args) 6) + (begin + (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open --group --code --retrieve|--publish") + (exit 1))) + (let* ((remargs (args:get-args args '("--group" "--code") '() args:arg-hash 0)) + (path (car args)) + (group (or (args:get-arg "--group") "")) + (area (or (args:get-arg "--code") "")) + (access-type (get-access-type remargs))) + (cond + ((equal? path "") + (print "path not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? area "") + (print "--code not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((equal? access-type #f) + (print "Access type not found!! Try \"sauthorize help\" for useage ") + (exit 1)) + ((and (not (equal? access-type "publish")) + (not (equal? access-type "retrieve"))) + (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ") + (exit 1))) + + (sauthorize:open username path group area access-type))) + ((area-admin) + (let* ((usr (car args)) + (usr-obj (get-user usr)) + (user-id (car (get-user username)))) + + (if (is-admin username) + (begin + ; (print usr-obj) + (if (null? usr-obj) + (begin + (sauthorize:db-do (lambda (db) + ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")) + (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))))) + (begin + ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) )) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj))))))) + (print "User " usr " is updated with area-admin access!")) + (print "Admin only function")) + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) + + ((register-log) + (if (< (length args) 4) + (print "Invalid arguments")) + ;(print args) + (let* ((cmd-line (car args)) + (user-id (cadr args)) + (area-id (caddr args)) + (user-obj (get-user username)) + (cmd (cadddr args))) + + (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj)))) + (begin + (sauthorize:db-do (lambda (db) + (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" ))))) + (print "You ar not authorised to run this cmd") + +))) + + + (else (print 0 "Unrecognised command " action)))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (username (current-user-name))) + ;; preserve the exe data in the config file + (cond + ;; one-word commands + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((help -h -help --h --help) + (print sauthorize:help)) + ((list) + + (sauthorize:db-do (lambda (db) + (print "My Area accesses: ") + (query (for-each-row + (lambda (row) + (let* ((exp-date (car row))) + (if (is-access-valid exp-date) + (apply print (intersperse (cdr row) " | ")))))) + (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'")))))) + + ((log) + (sauthorize:db-do (lambda (db) + (print "Logs : ") + (query (for-each-row + (lambda (row) + + (apply print (intersperse row " | ")))) + (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id "))))) + (else + (print "ERROR: Unrecognised command. Try \"sauthorize help\"")))) + ;; multi-word commands + ((null? rema)(print sauthorize:help)) + ((>= (length rema) 2) + (apply sauthorize:process-action username (car rema)(cdr rema))) + (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\""))))) + +(main) + + + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -46,20 +46,24 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; -(define (server:launch run-id transport-type) - (BB> "server:launch fired for run-id="run-id" transport-type="transport-type) - (case transport-type - ((http)(http-transport:launch run-id)) - ;;((nmsg)(nmsg-transport:launch run-id)) - ((rpc) (rpc-transport:launch run-id)) - (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))) -;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc") -;; (rpc-transport:launch run-id))))) - +(define (server:launch run-id transport-type-raw) + (let ((transport-type + (cond + ((string? transport-type-raw) (string->symbol transport-type-raw)) + (else transport-type-raw)))) + + ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type) + + (case transport-type + ((http)(http-transport:launch run-id)) + ;;((nmsg)(nmsg-transport:launch run-id)) + ((rpc) (rpc-transport:launch run-id)) + (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))) + ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Get the transport @@ -67,11 +71,11 @@ (if *transport-type* *transport-type* (let ((ttype (string->symbol (or (args:get-arg "-transport") (configf:lookup *configdat* "server" "transport") - "rpc")))) + *DEFAULT-TRANSPORT*)))) (set! *transport-type* ttype) ttype))) ;; Generate a unique signature for this server (define (server:mk-signature) @@ -112,13 +116,15 @@ (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) (logfile (conc *toppath* "/logs/server.log")) (cmdln (conc (common:get-megatest-exe) - " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") - (conc " -daemonize -log " logfile) - "") + " -server " (or target-host "-") " -run-id " 0 + (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") + (conc " -daemonize -log " logfile) + "") + " -transport " (server:get-transport) " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))) ;; we want the remote server to start in *toppath* so push there (push-directory *toppath*) (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") @@ -187,10 +193,22 @@ dotfile (lambda () (read-line))) #f)))) + +(define (server:dotserver-starting) + (with-output-to-file + (conc *toppath* "/.starting-server") + (lambda () + (print (current-process-id) " on " (get-host-name))))) + +(define (server:dotserver-starting-remove) + (delete-file* (conc *toppath* "/.starting-server"))) + + + ;; write a .server file in *toppath* with hostport ;; return #t on success, #f otherwise ;; (define (server:write-dotserver areapath hostport) (let ((lock-file (conc areapath "/.server.lock")) @@ -206,15 +224,15 @@ (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " created") (common:simple-file-release-lock lock-file) res) #f))) -(define (server:remove-dotserver-file areapath hostport) +(define (server:remove-dotserver-file areapath hostport #!key (force #f)) (let ((dotserver (server:read-dotserver areapath)) (server-file (conc areapath "/.server")) (lock-file (conc areapath "/.server.lock"))) - (if (and dotserver (string-match (conc ".*:" hostport "$") dotserver)) ;; port matches, good enough info to decide to remove the file + (if (or force (and dotserver (string-match (conc ".*:" hostport "$") dotserver))) ;; port matches, good enough info to decide to remove the file (if (common:simple-file-lock lock-file) (begin (handle-exceptions exn #f @@ -226,11 +244,11 @@ ;; (define (server:check-if-running areapath) (let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db))) (if dotserver (let* ((res (case *transport-type* - ((http)(server:ping-server dotserver)) + ((http rpc)(server:ping-server dotserver)) ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) ))) (if res dotserver #f)) @@ -265,11 +283,17 @@ (debug:print 0 *default-log-port* "ERROR: bad host:port")) (if do-exit (exit 1)) #f) (let* ((iface (car host-port)) (port (cadr host-port)) - (server-dat (http-transport:client-connect iface port)) + (server-dat + (case (remote-transport *runremote*) + ((http) (http-transport:client-connect iface port)) + ((rpc) (rpc-transport:client-connect iface port)) + (else + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (4)") + (exit)))) (login-res (rmt:login-no-auto-client-setup server-dat))) (if (and (list? login-res) (car login-res)) (begin (print "LOGIN_OK") Index: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -7,10 +7,14 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use defstruct) +(use scsh-process) + +(use refdb) + ;; (use ssax) ;; (use sxml-serializer) ;; (use sxml-modifications) ;; (use regex) @@ -18,10 +22,12 @@ ;; (use regex-case) ;; (use posix) ;; (use json) ;; (use csv) (use srfi-18) +(use srfi-19) + (use format) ;; (require-library ini-file) ;; (import (prefix ini-file ini:)) @@ -39,29 +45,32 @@ ;; (declare (uses server)) (declare (uses megatest-version)) ;; (declare (uses tbd)) (include "megatest-fossil-hash.scm") +;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. +(include "sauth-paths.scm") +(include "sauth-common.scm") + ;; ;; GLOBALS ;; (define *spublish:current-tab-number* 0) (define *args-hash* (make-hash-table)) -(define spublish:help (conc "Usage: spublish [action [params ...]] - - ls : list contents of target area - cp|publish : copy file to target area - mkdir : maks directory in target area - rm : remove file from target area - ln : creates a symlink - log : - +(define spublish:help (conc "Usage: spublish [action [params ...]] + + ls : list contents of target area + cp|publish : copy file to target area + mkdir : maks directory in target area + rm : remove file from target area + ln : creates a symlink + options: -m \"message\" : describe what was done - +Note: All the target locations relative to base path Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -70,10 +79,13 @@ ;;====================================================================== ;;====================================================================== ;; DB ;;====================================================================== + +(define *default-log-port* (current-error-port)) +(define *verbosity* 1) (define (spublish:initialize-db db) (for-each (lambda (qry) (exec (sql db qry))) @@ -149,11 +161,11 @@ (spublish:register-action db "cp" submitter source-path comment))) (let* (;; (target-path (configf:lookup "settings" "target-path")) (th1 (make-thread (lambda () (file-copy source-path targ-path #t)) - (print " ... file " targ-path " copied to" targ-path) + (print " ... file " targ-path " copied to " targ-path) ;; (let ((pid (process-run "cp" (list source-path target-dir)))) ;; (process-wait pid))) "copy thread")) (th2 (make-thread (lambda () @@ -343,10 +355,332 @@ (if (file-exists? (conc hed "/" name)) hed (if (null? tal) #f (loop (car tal)(cdr tal))))))) +;;======================================================================== +;;Shell +;;======================================================================== +(define (spublish:get-accessable-projects area) + (let* ((projects `())) + ; (print "in spublish:get-accessable-projects") + ;(print (spublish:has-permission area)) + (if (spublish:has-permission area) + (set! projects (cons area projects)) + (begin + (print "User cannot access area " area "!!") + (exit 1))) + ; (print "exiting spublish:get-accessable-projects") + projects)) + +;; function to find sheets to which use has access +(define (spublish:has-permission area) + ;(print "in spublish:has-permission") + (let* ((username (current-user-name)) + (ret-val #f)) + (cond + ((equal? (is-admin username) #t) + (set! ret-val #t)) + ((equal? (is-user "publish" username area) #t) + (set! ret-val #t)) + ((equal? (is-user "writer-admin" username area) #t) + (set! ret-val #t)) + + ((equal? (is-user "area-admin" username area) #t) + (set! ret-val #t)) + (else + (set! ret-val #f))) + ; (print ret-val) + ret-val)) + +(define (is_directory target-path) + (let* ((retval #f)) + (sauthorize:do-as-calling-user + (lambda () + ;(print (current-effective-user-id) ) + (if (directory? target-path) + (set! retval #t)))) + ;(print (current-effective-user-id)) + retval)) + + +(define (spublish:shell-cp src-path target-path) + (cond + ((not (file-exists? target-path)) + (print "ERROR: target Directory " target-path " does not exist!!")) + ((not (file-exists? src-path)) + (print "Error: Source path " src-path " does not exist!!" )) + (else + (if (is_directory src-path) + (begin + (let* ((parent-dir src-path) + (start-dir target-path)) + ;(print "parent-dir " parent-dir " start-dir " start-dir) + (run (pipe + (begin (system (conc "cd " parent-dir " ;tar chf - ." ))) + (begin (change-directory start-dir) + ;(print "123") + (run-cmd "tar" (list "xf" "-"))))) + (print "Copied data to " start-dir))) + (begin + (let*((parent-dir (pathname-directory src-path)) + (start-dir target-path) + (filename (if (pathname-extension src-path) + (conc(pathname-file src-path) "." (pathname-extension src-path)) + (pathname-file src-path)))) + ;(print "parent-dir " parent-dir " start-dir " start-dir) + (run (pipe + (begin (system (conc "cd " parent-dir ";tar chf - " filename ))) + (begin (change-directory start-dir) + (run-cmd "tar" (list "xf" "-"))))) + (print "Copied data to " start-dir))))))) + + +(define (spublish:shell-mkdir targ-path) + (if (file-exists? targ-path) + (begin + (print "ERROR: target Directory " targ-path " already exist!!")) + (let* ((th1 (make-thread + (lambda () + (create-directory targ-path #t) + (print " ... dir " targ-path " created")) + "mkdir thread")) + (th2 (make-thread + (lambda () + (let loop () + (thread-sleep! 15) + (display ".") + (flush-output) + (loop))) + "action is happening thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (cons #t "Successfully saved data")))) + + +(define (spublish:shell-rm targ-path) + (if (not (file-exists? targ-path)) + (begin + (print "ERROR: target path " targ-path " does not exist!!")) + (let* ((th1 (make-thread + (lambda () + (delete-file targ-path ) + (print " ... path " targ-path " deleted")) + "rm thread")) + (th2 (make-thread + (lambda () + (let loop () + (thread-sleep! 15) + (display ".") + (flush-output) + (loop))) + "action is happening thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + (cons #t "Successfully saved data")))) + +(define (spublish:shell-ln src-path target-path sub-path) + (if (not (file-exists? sub-path)) + (print "ERROR: Path " sub-path " does not exist!! cannot proceed with link creation!!") + (begin + (if (not (file-exists? src-path)) + (print "ERROR: Path " src-path " does not exist!! cannot proceed with link creation!!") + (begin + (if (file-exists? target-path) + (print "ERROR: Path " target-path "already exist!! cannot proceed with link creation!!") + (begin + (create-symbolic-link src-path target-path ) + (print " ... link " target-path " created")))))))) + +(define (spublish:shell-help) +(conc "Usage: [action [params ...]] + + ls [target path] : list contents of target area. + cd : To change the current directory within the sretrive shell. + pwd : Prints the full pathname of the current directory within the sretrive shell. + mkdir : creates directory. Note it does not create's a path recursive manner. + rm : removes files and emoty directories + cp : copy a file/dir to target path. if src is a dir it automatically makes a recursive copy. + ln TARGET LINK_NAME : creates a symlink +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash) +) + +(define (toplevel-command . args) #f) + +(define (spublish:shell area) + ; (print area) + (use readline) + (let* ((path '()) + (prompt "spublish> ") + (args (argv)) + (usr (current-user-name) ) + (top-areas (spublish:get-accessable-projects area)) + (close-port #f) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (iport (make-readline-port prompt))) + ;(print base-path) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + ; (print "here") + (let loop ((inl (read-line iport))) + (if (not (or (or (eof-object? inl) + (equal? inl "exit")) (port-closed? iport))) + (let* ((parts (string-split inl)) + (cmd (if (null? parts) #f (car parts)))) + (if (and (not cmd) (not (port-closed? iport))) + (loop (read-line)) + (case (string->symbol cmd) + ((cd) + (if (> (length parts) 1) ;; have a parameter + (begin + (let*((arg (cadr parts)) + (resolved-path (sauth-common:resolve-path arg path top-areas)) + (target-path (sauth-common:get-target-path path arg top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (equal? resolved-path #f) (not (file-exists? target-path))) + (print "Invalid argument " arg ".. ") + (begin + (set! path resolved-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd")))) + ))))) + (set! path '()))) + ((pwd) + (if (null? path) + (print "/") + (print "/" (string-join path "/")))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (sauth-common:shell-ls-cmd path "" top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) ) + ((< plen 2) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))) + (else + (if (equal? (car thepath) "|") + (sauth-common:shell-ls-cmd path "" top-areas base-path thepath) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))) + ((mkdir) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "mkdir takes one argument")) + ((< plen 2) + (let*((mk-path (cadr parts)) + (resolved-path (sauth-common:resolve-path mk-path path top-areas)) + (target-path (sauth-common:get-target-path path mk-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " mk-path ".. ") + (begin + (spublish:shell-mkdir target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir"))))))) + ))))) + ((rm) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "rm takes one argument")) + ((< plen 2) + (let*((rm-path (cadr parts)) + (resolved-path (sauth-common:resolve-path rm-path path top-areas)) + (target-path (sauth-common:get-target-path path rm-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " rm-path ".. ") + (begin + (spublish:shell-rm target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm"))))))) + ))))) + + ((cp publish) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((or (null? thepath) (< plen 2)) + (print "cp takes two argument")) + ((< plen 3) + (let*((src-path (car thepath)) + (dest-path (cadr thepath)) + (resolved-path (sauth-common:resolve-path dest-path path top-areas)) + (target-path (sauth-common:get-target-path path dest-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-cp src-path target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp"))))))) + ))))) + ((ln) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((or (null? thepath) (< plen 2)) + (print "ln takes two argument")) + ((< plen 3) + (let*((src-path (car thepath)) + (dest-path (cadr thepath)) + (resolved-path (sauth-common:resolve-path dest-path path top-areas)) + (target-path (sauth-common:get-target-path path dest-path top-areas base-path)) + (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/"))))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-ln src-path target-path sub-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln"))))))) + ))))) + ((exit) + (print "got exit")) + ((help) + (print (spublish:shell-help))) + (else + (print "Got command: " inl)))) + (loop (read-line iport))))))) + ;;====================================================================== ;; MAIN ;;====================================================================== @@ -357,148 +691,110 @@ (if (file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) -(define (spublish:process-action configdat action . args) - (let* ((target-dir (configf:lookup configdat "settings" "target-dir")) - (user (current-user-name)) - (allowed-users (string-split - (or (configf:lookup configdat "settings" "allowed-users") - "")))) - (if (not target-dir) - (begin - (print "[settings]\ntarget-dir /some/path\n\n Is MISSING from the config file!") - (exit))) - (if (null? allowed-users) - (begin - (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") - (exit))) - (if (not (member user allowed-users)) - (begin - (print "User \"" (current-user-name) "\" does not have access. Exiting") - (exit 1))) +(define (spublish:process-action action . args) + ;(print args) + (let* ((usr (current-user-name)) + (user-obj (get-user usr)) + (area (car args)) + (area-obj (get-obj-by-code area)) + (top-areas (spublish:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (remargs (cdr args))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) (case (string->symbol action) ((cp publish) - (if (< (length args) 2) + (if (< (length remargs) 2) (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (print "ERROR: Missing arguments; spublish " ) (exit 1))) - (let* ((remargs (args:get-args args '("-m") '() args:arg-hash 0)) - (dest-dir (cadr args)) - (src-path-in (car args)) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (src-path-in (car filter-args)) + (dest-path (cadr filter-args)) (src-path (with-input-from-pipe (conc "readlink -f " src-path-in) (lambda () (read-line)))) (msg (or (args:get-arg "-m") "")) - (targ-file (pathname-strip-directory src-path))) - (if (not (file-read-access? src-path)) - (begin - (print "ERROR: source file not readable: " src-path) - (exit 1))) - (if (directory? src-path) - (begin - (print "ERROR: source file is a directory, this is not supported yet.") - (exit 1))) - (print "publishing " src-path-in " to " target-dir) - (spublish:validate target-dir dest-dir) - (spublish:cp configdat user src-path target-dir targ-file dest-dir msg))) - ((tar) - (if (< (length args) 1) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((dst-dir (car args)) - (msg (or (args:get-arg "-m") ""))) - (spublish:validate target-dir dst-dir) - (spublish:tar configdat user target-dir dst-dir msg))) - - ((mkdir) - (if (< (length args) 1) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((targ-mk (car args)) - (msg (or (args:get-arg "-m") ""))) - (print "attempting to create directory " targ-mk " in " target-dir) - (spublish:validate target-dir targ-mk) - (spublish:mkdir configdat user target-dir targ-mk msg))) - - ((ln) - (if (< (length args) 2) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((targ-link (car args)) - (link-name (cadr args)) - (sub-path (string-reverse (string-join (cdr (string-split (string-reverse link-name) "/")) "/"))) - (msg (or (args:get-arg "-m") ""))) - (if (> (string-length(string-trim sub-path)) 0) - (begin - (print "attempting to create directory " sub-path " in " target-dir) - (spublish:validate target-dir sub-path) - (print (conc target-dir "/" sub-path ) ) - (print (directory-exists?(conc target-dir "/" sub-path ))) - (if (directory-exists?(conc target-dir "/" sub-path )) - (print "Target Directory " (conc target-dir sub-path ) " exist!!") - (spublish:mkdir configdat user target-dir sub-path msg)))) - - (print "attempting to create link " link-name " in " target-dir) - (spublish:ln configdat user target-dir targ-link link-name msg))) - + (resolved-path (sauth-common:resolve-path (conc area "/" dest-path) `() top-areas)) + (target-path (sauth-common:get-target-path `() (conc area "/" dest-path) top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-cp src-path target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" cp " src-path-in " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cp"))))))))) + ((mkdir) + (if (< (length remargs) 1) + (begin + (print "ERROR: Missing arguments; ") + (exit 1))) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (mk-path (car filter-args)) + (msg (or (args:get-arg "-m") "")) + (resolved-path (sauth-common:resolve-path mk-path (list area) top-areas)) + (target-path (sauth-common:get-target-path (list area) mk-path top-areas base-path))) + (print "attempting to create directory " mk-path ) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " mk-path ".. ") + (begin + (spublish:shell-mkdir target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" mkdir " mk-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "mkdir"))))))))) + ((ln) + (if (< (length remargs) 2) + (begin + (print "ERROR: Missing arguments; " ) + (exit 1))) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (src-path (car filter-args)) + (dest-path (cadr filter-args)) + (resolved-path (sauth-common:resolve-path dest-path (list area) top-areas)) + (target-path (sauth-common:get-target-path (list area) dest-path top-areas base-path)) + (sub-path (conc "/" (string-reverse (string-join (cdr (string-split (string-reverse target-path) "/")) "/"))))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " dest-path ".. ") + (begin + (spublish:shell-ln src-path target-path sub-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" ln " src-path " " dest-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ln"))))))))) ((rm) - (if (< (length args) 1) + (if (< (length remargs) 1) (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (print "ERROR: Missing arguments; ") (exit 1))) - (let* ((targ-file (car args)) - (msg (or (args:get-arg "-m") ""))) - (print "attempting to remove " targ-file " from " target-dir) - (spublish:validate target-dir targ-file) - - (spublish:rm configdat user target-dir targ-file msg))) - ((publish) - (if (< (length args) 3) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) + (rm-path (car filter-args)) + (resolved-path (sauth-common:resolve-path rm-path (list area) top-areas)) + (target-path (sauth-common:get-target-path (list area) rm-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (equal? resolved-path #f) + (print "Invalid argument " rm-path ".. ") + (begin + (spublish:shell-rm target-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\" rm " rm-path "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "rm"))))))))) + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments area!!" ) (exit 1)) - (let* ((srcpath (list-ref args 0)) - (areaname (list-ref args 1)) - (version (list-ref args 2)) - (remargs (args:get-args (drop args 2) - '("-type" ;; link or copy (default is copy) - "-m") - '() - args:arg-hash - 0)) - (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy)) - (comment (or (args:get-arg "-m") "")) - (submitter (current-user-name)) - (quality (args:get-arg "-quality")) - (publish-res (spublish:publish configdat publish-type areaname version comment srcpath submitter quality))) - (if (not (car publish-res)) - (begin - (print "ERROR: " (cdr publish-res)) - (exit 1)))))) - ((list-versions) - (let ((area-name (car args)) ;; version patt full print - (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0)) - (db (spublish:open-db configdat)) - (versions (spublish:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt")))) - ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) - (map (lambda (x) - (if (args:get-arg "-full") - (format #t - "~10a~10a~4a~27a~30a\n" - (vector-ref x 0) - (vector-ref x 1) - (vector-ref x 2) - (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") - (conc "\"" (vector-ref x 4) "\"")) - (print (vector-ref x 0)))) - versions))) + (spublish:shell area))) (else (print "Unrecognised command " action))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc"))) ;; (if (file-exists? debugcontrolf) @@ -506,37 +802,21 @@ (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) - (exe-name (pathname-file (car (argv)))) - (exe-dir (or (pathname-directory prog) - (spublish:find exe-name (string-split (get-environment-variable "PATH") ":")))) - (configdat (spublish:load-config exe-dir exe-name))) + (exe-name (pathname-file (car (argv))))) (cond ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print spublish:help)) - ((list-vars) ;; print out the ini file - (map print (spublish:get-areas configdat))) - ((ls) - (let ((target-dir (configf:lookup configdat "settings" "target-dir"))) - (print "Files in " target-dir) - (system (conc "ls " target-dir)))) - ((log) - (spublish:db-do configdat (lambda (db) - (print "Listing actions") - (query (for-each-row - (lambda (row) - (apply print (intersperse row " | ")))) - (sql db "SELECT * FROM actions"))))) (else (print "ERROR: Unrecognised command. Try \"spublish help\"")))) ;; multi-word commands ((null? rema)(print spublish:help)) ((>= (length rema) 2) - (apply spublish:process-action configdat (car rema)(cdr rema))) + (apply spublish:process-action (car rema)(cdr rema))) (else (print "ERROR: Unrecognised command2. Try \"spublish help\""))))) (main) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -7,43 +7,38 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use defstruct) - -;; (use ssax) -;; (use sxml-serializer) -;; (use sxml-modifications) -;; (use regex) -;; (use srfi-69) -;; (use regex-case) -;; (use posix) -;; (use json) -;; (use csv) -;; (use directory-utils) +(use scsh-process) + (use srfi-18) -(use format) - +(use srfi-19) +;;(use utils) +;;(use format) +(use refdb) ;; (require-library ini-file) ;; (import (prefix ini-file ini:)) (use sql-de-lite srfi-1 posix regex regex-case srfi-69) ;; (import (prefix sqlite3 sqlite3:)) ;; +(declare (uses common)) + (declare (uses configf)) -;; (declare (uses tree)) (declare (uses margs)) -;; (declare (uses dcommon)) -;; (declare (uses launch)) -;; (declare (uses gutils)) -;; (declare (uses db)) -;; (declare (uses synchash)) -;; (declare (uses server)) (declare (uses megatest-version)) -;; (declare (uses tbd)) + (include "megatest-fossil-hash.scm") +;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. +(include "sauth-paths.scm") +(include "sauth-common.scm") + +(define (toplevel-command . args) #f) +(use readline) + ;; ;; GLOBALS ;; (define *verbosity* 1) @@ -51,16 +46,14 @@ (define *exe-name* (pathname-file (car (argv)))) (define *sretrieve:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] - ls : list contents of target area - get : retrieve data for release - -m \"message\" : why retrieved? - cp : copy file to current directory - log : get listing of recent downloads - shell : start a shell-like interface + ls : list contents of target area + get : retrieve path to the data within + -m \"message\" : why retrieved? + shell : start a shell-like interface Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -94,11 +87,11 @@ status TEXT NOT NULL, event_date TEXT NOT NULL);" ))) (define (sretrieve:register-action db action submitter source-path comment) - (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment) + ; (print "(sretrieve:register-action db " db " action " action " submitter " submitter " source-path " source-path " comment " comment) (exec (sql db "INSERT INTO actions (action,retriever,srcpath,comment) VALUES(?,?,?,?)") action submitter source-path @@ -109,15 +102,14 @@ ;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout ;; ...)) ;; Create the sqlite db (define (sretrieve:db-do configdat proc) - (let ((path (configf:lookup configdat "database" "location"))) (if (not path) (begin - (debug:print 0 *default-log-port* "[database]\nlocation /some/path\n\n Is missing from the config file!") + (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") (exit 1))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/" *exe-name* ".db")) @@ -124,37 +116,37 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath + (debug:print 2 "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) - ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath ) + ;;(debug:print 0 "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) - ;;(debug:print 0 *default-log-port* "calling proc " proc " on db " db) + ;;(debug:print 0 "calling proc " proc " on db " db) (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout (if (not dbexists)(sretrieve:initialize-db db)) (proc db))))) - (debug:print-error 0 *default-log-port* "invalid path for storing database: " path)))) + (debug:print 0 "ERROR: invalid path for storing database: " path)))) ;; copy in directory to dest, validation is done BEFORE calling this ;; (define (sretrieve:get configdat retriever version comment) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (datadir (conc base-dir "/" version))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") + (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." ) + (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -173,12 +165,11 @@ (let* ((parent-dir (pathname-directory datadir) ) (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) (change-directory parent-dir) (process-execute "/bin/tar" (list "chfv" "-" filename)) ))) -)) -)) +)))) ;; copy in file to dest, validation is done BEFORE calling this ;; (define (sretrieve:cp configdat retriever file comment) @@ -187,34 +178,34 @@ (datadir (conc base-dir "/" file)) (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") + (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) + (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) (exit 1))) (if (directory? datadir) (begin - (debug:print-error 0 *default-log-port* "(" file ") is a dirctory!! cp cmd works only on files ." ) + (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " ) + (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "cp" retriever datadir comment))) (sretrieve:do-as-calling-user - ;; (debug:print 0 *default-log-port* "ph: "(pathname-directory datadir) "!! " ) + ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " ) (change-directory (pathname-directory datadir)) - ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) ) + ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) (process-execute "/bin/tar" (list "chfv" "-" filename))) )) ;; ls in file to dest, validation is done BEFORE calling this ;; @@ -224,148 +215,44 @@ (datadir (conc base-dir "/" file)) (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") + (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) + (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " ) + (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:do-as-calling-user (lambda () - ;;(change-directory datadir) - ;; (debug:print 0 *default-log-port* "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) - ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line)))) - ;; (debug:print 0 *default-log-port* status) (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) )))) -;;(filter (lambda (x) -;; (not (member x '("." "..")))) -;; (glob "*" ".*")))))))) - (define (sretrieve:validate target-dir targ-mk) (let* ((normal-path (normalize-pathname targ-mk)) (targ-path (conc target-dir "/" normal-path))) (if (string-contains normal-path "..") (begin - (debug:print-error 0 *default-log-port* "Path " targ-mk " resolved outside target area " target-dir ) + (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print-error 0 *default-log-port* "You cannot update data outside " target-dir ".") + (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") (exit 1))) - (debug:print 0 *default-log-port* "Path " targ-mk " is valid.") + (debug:print 0 "Path " targ-mk " is valid.") )) -;; make directory in dest -;; - -(define (sretrieve:mkdir configdat submitter target-dir targ-mk comment) - (let ((targ-path (conc target-dir "/" targ-mk))) - - (if (file-exists? targ-path) - (begin - (debug:print-error 0 *default-log-port* "target Directory " targ-path " already exist!!") - (exit 1))) - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "mkdir" submitter targ-mk comment))) - (let* ((th1 (make-thread - (lambda () - (create-directory targ-path #t) - (debug:print 0 *default-log-port* " ... dir " targ-path " created")) - "mkdir thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) - -;; create a symlink in dest -;; -(define (sretrieve:ln configdat submitter target-dir targ-link link-name comment) - (let ((targ-path (conc target-dir "/" link-name))) - (if (file-exists? targ-path) - (begin - (debug:print-error 0 *default-log-port* "target file " targ-path " already exist!!") - (exit 1))) - (if (not (file-exists? targ-link )) - (begin - (debug:print-error 0 *default-log-port* "target file " targ-link " does not exist!!") - (exit 1))) - - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "ln" submitter link-name comment))) - (let* ((th1 (make-thread - (lambda () - (create-symbolic-link targ-link targ-path ) - (debug:print 0 *default-log-port* " ... link " targ-path " created")) - "symlink thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) - - -;; remove copy of file in dest -;; -(define (sretrieve:rm configdat submitter target-dir targ-file comment) - (let ((targ-path (conc target-dir "/" targ-file))) - (if (not (file-exists? targ-path)) - (begin - (debug:print-error 0 *default-log-port* "target file " targ-path " not found, nothing to remove.") - (exit 1))) - (sretrieve:db-do - configdat - (lambda (db) - (sretrieve:register-action db "rm" submitter targ-file comment))) - (let* ((th1 (make-thread - (lambda () - (delete-file targ-path) - (debug:print 0 *default-log-port* " ... file " targ-path " removed")) - "rm thread")) - (th2 (make-thread - (lambda () - (let loop () - (thread-sleep! 15) - (display ".") - (flush-output) - (loop))) - "action is happening thread"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1)) - (cons #t "Successfully saved data"))) + (define (sretrieve:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) (create-directory trashdir #t) @@ -392,11 +279,11 @@ (define (sretrieve:do-as-calling-user proc) (let ((eid (current-effective-user-id)) (cid (current-user-id))) (if (not (eq? eid cid)) ;; running suid (set! (current-effective-user-id) cid)) - ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id)) + ;; (debug:print 0 "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (sretrieve:find name paths) @@ -417,161 +304,738 @@ ;;====================================================================== ;; SHELL ;;====================================================================== -(define (toplevel-command . args) #f) -(define (sretrieve:shell) + +(define *refdb* "/p/foundry/env/pkgs/chicken/4.10.0_ext/bin/refdb") +(define *refdbloc* "/nfs/site/disks/ch_ciaf_disk023/fdk_gwa_disk003/pjhatwal/fossil/megatest1.60/megatest/datashare-testing/sretrieve_configs") + +;; Create the sqlite db for shell +(define (sretrieve:shell-db-do path proc) + (if (not path) + (begin + (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") + (exit 1))) + (if (and path + (directory? path) + (file-read-access? path)) + (let* ((dbpath (conc path "/" *exe-name* ".db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit 1)) + ;;(debug:print 0 "calling proc " proc "db path " dbpath ) + (call-with-database + dbpath + (lambda (db) + ;;(debug:print 0 "calling proc " proc " on db " db) + (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout + (if (not dbexists)(sretrieve:initialize-db db)) + (proc db))))) + (debug:print 0 "ERROR: invalid path for storing database: " path))) + + + +;; function to find sheets to which use has access +(define (sretrieve:has-permission area) + (let ((username (current-user-name))) + (cond + ((is-admin username) + #t) + ((is-user "retrieve" username area) + #t) + ((is-user "publish" username area) + #t) + ((is-user "writer-admin" username area) + #t) + ((is-user "read-admin" username area) + #t) + ((is-user "area-admin" username area) + #t) + (else + #f)))) + + + + + +(define (sretrieve:get-accessable-projects area) + (let* ((projects `())) + + (if (sretrieve:has-permission area) + (set! projects (cons area projects)) + (begin + (print "User cannot access area " area "!!") + (exit 1))) + ; (print projects) + projects)) + +(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) + (if (and (null? base-path-list) (equal? ext-path "") ) + (print (string-intersperse top-areas " ")) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))) + ;(print resolved-path) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print (string-intersperse top-areas " ")) + (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path))) + ;(print "Resolved path: " target-path) + (if (symbolic-link? target-path) + (set! target-path (conc target-path "/"))) + (if (not (equal? target-path #f)) + (begin + (cond + ((null? tail-cmd-list) + (run (pipe + (ls "-lrt" ,target-path)))) + ((not (equal? (car tail-cmd-list) "|")) + (print "ls cmd cannot accept "(string-join tail-cmd-list) " as an argument!!")) + (else + (run (pipe + (ls "-lrt" ,target-path) + (begin (system (string-join (cdr tail-cmd-list)))))) + )))))))))) + +(define (sretrieve:shell-cat-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) + (data "") ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (not (file-exists? target-path)) (directory? target-path)) + (print "Target path does not exist or is a directory!") + (begin + (cond + ((null? tail-cmd-list) + (run (pipe + (cat ,target-path)))) + ((not (equal? (car tail-cmd-list) "|")) + (print "cat cmd cannot accept "(string-join tail-cmd-list) " as an argument!!")) + (else + (run (pipe + (cat ,target-path) + (begin (system (string-join (cdr tail-cmd-list)))))))))) +))) + (print "Path could not be resolved!!")))) + +(define (get-options cmd-list split-str) + (if (null? cmd-list) + (list '() '()) + (let loop ((hed (car cmd-list)) + (tal (cdr cmd-list)) + (res '())) + (cond + ((equal? hed split-str) + (list res tal)) + ((null? tal) + (list (cons hed res) tal)) + (else + (loop (car tal)(cdr tal)(cons hed res))))))) + + +(define (sretrieve:shell-grep-cmd base-pathlist ext-path top-areas base-path tail-cmd-list) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas )) + (pattern (car tail-cmd-list)) + (pipe-cmd-list (get-options (cdr tail-cmd-list) "|")) + (options (string-join (car pipe-cmd-list))) + (pipe-cmd (cadr pipe-cmd-list)) + (redirect-split (string-split (string-join tail-cmd-list) ">")) ) + (if(and ( > (length redirect-split) 2 )) + (print "sgrep cmd cannot accept > " (string-join redirect-split) " as an argument!!" ) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path))) + (rest-str (string-split (conc " --exclude-dir=" (string-join (string-split restrictions ",") " --exclude-dir=") )))) + (if (not (file-exists? target-path)) + (print "Target path does not exist!") + (begin + (cond + ((and (null? pipe-cmd) (string-null? options)) + (run (pipe + (grep ,pattern ,target-path )))) + ((and (null? pipe-cmd) (not (string-null? options))) + (run (pipe + (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str)))))) + ((and (not (null? pipe-cmd)) (string-null? options)) + (run (pipe + (grep ,exclude-dir ,pattern ,target-path) + (begin (system (string-join pipe-cmd)))))) + (else + (run (pipe + ;(grep ,options ,exclude-dir ,pattern ,target-path) + (begin (process-execute "/usr/bin/grep" (append (list options pattern target-path) rest-str))) + + (begin (system (string-join pipe-cmd))))))) +)))) + (print "Path could not be resolved!!"))))) + + +(define (sretrieve:shell-less-cmd base-pathlist ext-path top-areas base-path) + (let* ((resolved-path (sauth-common:resolve-path ext-path base-pathlist top-areas ))) + (if (not (equal? resolved-path #f)) + (if (null? resolved-path) + (print "Path could not be resolved!!") + (let* ((target-path (sauth-common:get-target-path base-pathlist ext-path top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (not (file-exists? target-path)) (directory? target-path)) + (print "Target path does not exist or is a directory!") + (begin + ;(sretrieve:shell-db-do + ; db-location + ; (lambda (db) + ; (sretrieve:register-action db "less" (current-user-name) target-path (conc "Executing cmd: less " target-path)))) + + (setenv "LESSSECURE" "1") + (run (pipe + (less ,target-path)))))))) + (print "Path could not be resolved!!")))) + + + +(define (sretrieve:shell-lookup base-path) + (let* ((usr (current-user-name)) + (value (get-restrictions base-path usr))) + value)) + + +(define (sretrieve:load-shell-config fname) + (if (file-exists? fname) + (read-config fname #f #f) + )) + + +(define (is_directory target-path) + (let* ((retval #f)) + (sretrieve:do-as-calling-user + (lambda () + ;(print (current-effective-user-id) ) + (if (directory? target-path) + (set! retval #t)))) + ;(print (current-effective-user-id)) + retval)) + +(define (make-exclude-pattern restriction-list ) + (if (null? restriction-list) + "" + (let loop ((hed (car restriction-list)) + (tal (cdr restriction-list)) + (ret-str "")) + (cond + ((null? tal) + (conc ret-str ".+" hed ".*")) + (else + (loop (car tal)(cdr tal)(conc ret-str ".+" hed ".*|")))))) ) + +(define (sretrieve:get-shell-cmd target-path base-path restrictions iport) + (if (not (file-exists? target-path)) + (print "Target path does not exist!") + (begin + (if (not (equal? target-path #f)) + (begin + (if (is_directory target-path) + (begin + (let* ((tmpfile (conc "/tmp/" (current-user-name) "/my-pipe")) + (parent-dir target-path) + (last-dir-name (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (curr-dir (current-directory)) + (start-dir (conc (current-directory) "/" last-dir-name)) + (execlude (make-exclude-pattern (string-split restrictions ",")))) + ; (print tmpfile) + (if (file-exists? start-dir) + (begin + (print last-dir-name " already exist in your work dir. Do you want to over write it? [y|n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (begin + (change-directory parent-dir) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (run (pipe + (tar "chfv" "-" "-T" ,tmpfile ) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory curr-dir) + (system (conc "rm " tmpfile)) ) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (sretrieve:do-as-calling-user + (lambda () + (create-directory start-dir #t))) + (change-directory parent-dir) + ; (print execlude) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (run (pipe + (tar "chfv" "-" "-T" ,tmpfile) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory curr-dir) + (system (conc "rm " tmpfile)))))) + (begin + (let*((parent-dir (pathname-directory target-path)) + (start-dir (current-directory)) + (filename (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (work-dir-file (conc (current-directory) "/" filename))) + (if (file-exists? work-dir-file) + (begin + (print filename " already exist in your work dir. Do you want to over write it? [y|n]") + (let* ((inl (read-line iport))) + (if (equal? inl "y") + (begin + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" ,filename) + (begin (system (conc "cd " start-dir ";tar xUf - " ))))) + (change-directory start-dir)) + (begin + (print "Nothing has been retrieved!! "))))) + (begin + (change-directory parent-dir) + (run (pipe + (tar "chfv" "-" ,filename) + (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir))))))))))) + +(define (sretrieve:get-shell-cmd-line target-path base-path restrictions iport) + (if (not (file-exists? target-path)) + (print "Target path does not exist!") + (begin + (if (not (equal? target-path #f)) + (begin + (if (is_directory target-path) + (begin + (let* ((parent-dir target-path) + (last-dir-name (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (curr-dir (current-directory)) + (start-dir (conc (current-directory) "/" last-dir-name)) + (execlude (make-exclude-pattern (string-split restrictions ","))) + (tmpfile (conc "/tmp/" (current-user-name) "/my-pipe-" (current-process-id)))) + (if (file-exists? start-dir) + (begin + (print last-dir-name " already exist in your work dir.") + (print "Nothing has been retrieved!! ")) + (begin + ; (sretrieve:do-as-calling-user + ; (lambda () + ;(create-directory start-dir #t))) + (change-directory parent-dir) + (create-fifo tmpfile) + (process-fork + (lambda() + (sleep 1) + (with-output-to-file tmpfile + (lambda () + (sretrieve:make_file parent-dir execlude parent-dir))))) + + (process-execute "/bin/tar" (append (list "chfv" "-" "-T" tmpfile) (list "--ignore-failed-read"))) + ;(run (pipe + ;(tar "chfv" "-" "." ) + ;(begin (system (conc "cd " start-dir ";tar xUf - " execlude ))))) + (system (conc "rm " tmpfile)) + (change-directory curr-dir))))) + (begin + (let*((parent-dir (pathname-directory target-path)) + (start-dir (current-directory)) + (filename (if (pathname-extension target-path) + (conc(pathname-file target-path) "." (pathname-extension target-path)) + (pathname-file target-path))) + (work-dir-file (conc (current-directory) "/" filename))) + (if (file-exists? work-dir-file) + (begin + (print filename " already exist in your work dir.") + (print "Nothing has been retrieved!! ")) + (begin + (change-directory parent-dir) + (process-execute "/bin/tar" (append (append (list "chfv" "-") (list filename)) (list "--ignore-failed-read"))) + ;(run (pipe + ; (tar "chfv" "-" ,filename) + ; (begin (system (conc "cd " start-dir ";tar xUf -"))))) + (change-directory start-dir))))))))))) + +(define (sretrieve:make_file path exclude base_path) + (find-files + path + action: (lambda (p res) + (cond + ((symbolic-link? p) + (if (directory?(read-symbolic-link p)) + (sretrieve:make_file p exclude base_path) + (print (string-substitute (conc base_path "/") "" p "-")))) + ((directory? p) + ;;do nothing for dirs) + ) + (else + + (if (not (string-match (regexp exclude) p )) + (print (string-substitute (conc base_path "/") "" p "-")))))))) + +(define (sretrieve:shell-help) +(conc "Usage: " *exe-name* " [action [params ...]] + + ls [target path] : list contents of target area. The output of the cmd can be piped into other system cmd. eg ls | grep txt + cd : To change the current directory within the sretrive shell. + pwd : Prints the full pathname of the current directory within the sretrive shell. + get : download directory/files into the directory where sretrieve shell cmd was invoked + less : Read input file to allows backward movement in the file as well as forward movement + cat : show the contents of a file. The output of the cmd can be piped into other system cmd. + + sgrep [options] : Similar to unix grep cmd But with diffrent parameter ordering. The output of the cmd can be piped into other system cmd. +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash) +) +;(define (toplevel-command . args) #f) +(define (sretrieve:shell area) + ; (print area) (use readline) (let* ((path '()) - (prompt "> ") - (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18")) + (prompt "sretrieve> ") + (args (argv)) + (usr (current-user-name) ) + (top-areas (sretrieve:get-accessable-projects area)) + (close-port #f) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) (iport (make-readline-port prompt))) - (install-history-file) ;; [homedir] [filename] [nlines]) - (with-input-from-port iport - (lambda () - (let loop ((inl (read-line))) - (if (not (or (eof-object? inl) - (equal? inl "exit"))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (let loop ((inl (read-line iport))) + ;(print 1) + (if (not (or (or (eof-object? inl) + (equal? inl "exit")) (port-closed? iport))) (let* ((parts (string-split inl)) (cmd (if (null? parts) #f (car parts)))) - (if (not cmd) + ; (print "2") + (if (and (not cmd) (not (port-closed? iport))) (loop (read-line)) (case (string->symbol cmd) ((cd) (if (> (length parts) 1) ;; have a parameter - (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths - (set! path '()))) + (begin + (let*((arg (cadr parts)) + (resolved-path (sauth-common:resolve-path arg path top-areas)) + (target-path (sauth-common:get-target-path path arg top-areas base-path))) + (if (not (equal? target-path #f)) + (if (or (equal? resolved-path #f) (not (file-exists? target-path))) + (print "Invalid argument " arg ".. ") + (begin + (set! path resolved-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cd")))) + ))))) + (set! path '()))) + ((pwd) + (if (null? path) + (print "/") + (print "/" (string-join path "/")))) ((ls) (let* ((thepath (if (> (length parts) 1) ;; have a parameter (cdr parts) - path)) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (sauth-common:shell-ls-cmd path "" top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))) ) + ((< plen 2) + + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))) + (else + (if (equal? (car thepath) "|") + (sauth-common:shell-ls-cmd path "" top-areas base-path thepath) + (sauth-common:shell-ls-cmd path (car thepath) top-areas base-path (cdr thepath))) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))))) + ((cat) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to cat")) + ((< plen 2) + (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat"))))) + + (else + (sretrieve:shell-cat-cmd path (car thepath) top-areas base-path (cdr thepath)) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "cat")))) +)))) + ((sgrep) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing arguments to grep!! Useage: grep [options] ")) + ((< plen 2) + (print "Error: Missing arguments to grep!! Useage: grep [options] ")) + (else + (sretrieve:shell-grep-cmd path (car thepath) top-areas base-path (cdr thepath)) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "grep")))))))) + + ((less) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) + (plen (length thepath))) + (cond + ((null? thepath) + (print "Error: Missing argument to less")) + ((< plen 2) + (sretrieve:shell-less-cmd path (car thepath) top-areas base-path) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "less"))))) + (else + (print "less cmd takes only one () argument!!"))))) + ((get) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + `())) (plen (length thepath))) (cond ((null? thepath) - (print (string-intersperse top-areas " "))) - ((and (< plen 2) - (member (car thepath) top-areas)) - (system (conc "ls /p/fdk/gwa/" (car thepath)))) - (else ;; have a long path - ;; check for access rights here - (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/"))))))) + (print "Error: Missing argument to get")) + ((< plen 2) + (let* ((target-path (sauth-common:get-target-path path (car thepath) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + (if (not (equal? target-path #f)) + (begin + (sretrieve:get-shell-cmd target-path base-path restrictions iport) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "\"" inl "\"") (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))))))) + (else + (print "Error: get cmd takes only one argument "))))) + ((exit) + (print "got exit")) + ((help) + (print (sretrieve:shell-help))) (else (print "Got command: " inl)))) - (loop (read-line))))))))) + (loop (read-line iport))))))) +;;)) ;;====================================================================== ;; MAIN ;;====================================================================== +;;(define *default-log-port* (current-error-port)) (define (sretrieve:load-config exe-dir exe-name) (let* ((fname (conc exe-dir "/." exe-name ".config"))) ;; (ini:property-separator-patt " * *") ;; (ini:property-separator #\space) (if (file-exists? fname) ;; (ini:read-ini fname) - (read-config fname #f #t) + (read-config fname #f #f) (make-hash-table)))) ;; package-type is "megatest", "builds", "kits" etc. ;; + (define (sretrieve:load-packages configdat exe-dir package-type) (push-directory exe-dir) (let* ((packages-metadir (configf:lookup configdat "settings" "packages-metadir")) (conversion-script (configf:lookup configdat "settings" "conversion-script")) (upstream-file (configf:lookup configdat "settings" "upstream-file")) (package-config (conc packages-metadir "/" package-type ".config"))) - ;; this section here does a timestamp based rebuild of the - ;; /.config file using - ;; as an input - (if (file-exists? upstream-file) + (if (file-exists? upstream-file) (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer (> (file-modification-time upstream-file)(file-modification-time package-config))) (handle-exceptions exn - (debug:print-error 0 *default-log-port* "failed to run script " conversion-script " with params " upstream-file " " package-config) + (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) (let ((pid (process-run conversion-script (list upstream-file package-config)))) (process-wait pid))) - (debug:print 0 *default-log-port* "Skipping update of " package-config " from " upstream-file)) - (debug:print 0 *default-log-port* "Skipping update of " package-config " as " upstream-file " not found")) - ;; (ini:property-separator-patt " * *") - ;; (ini:property-separator #\space) - (let ((res (if (file-exists? package-config) + (debug:print 0 "Skipping update of " package-config " from " upstream-file)) + (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found")) + (let ((res (if (file-exists? package-config) (begin - (debug:print 0 *default-log-port* "Reading package config " package-config) + (debug:print 0 "Reading package config " package-config) (read-config package-config #f #t)) (make-hash-table)))) (pop-directory) res))) +;(define (toplevel-command . args) #f) (define (sretrieve:process-action configdat action . args) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) - (user (current-user-name)) - (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) - (allowed-users (string-split - (or (configf:lookup configdat "settings" "allowed-users") - ""))) - (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package - - (if (not base-dir) - (begin - (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") - (exit))) - (if (null? allowed-users) - (begin - (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") - (exit))) - (if (not (member user allowed-users)) - (begin - (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting") - (exit 1))) + ; (use readline) (case (string->symbol action) ((get) - (if (< (length args) 1) - (begin - (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) - (version (car args)) - (msg (or (args:get-arg "-m") "")) - (package-type (or (args:get-arg "-package") - default-area)) - (exe-dir (configf:lookup configdat "exe-info" "exe-dir"))) -;; (relconfig (sretrieve:load-packages configdat exe-dir package-type))) - - (debug:print 0 *default-log-port* "retrieving " version " of " package-type " as tar data on stdout") - (sretrieve:get configdat user version msg))) - ((cp) - (if (< (length args) 1) - (begin - (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) - (file (car args)) - (msg (or (args:get-arg "-m") "")) ) - - (debug:print 0 *default-log-port* "copinging " file " to current directory " ) - (sretrieve:cp configdat user file msg))) - ((ls) - (if (< (length args) 1) - (begin - (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) - (dir (car args)) - (msg (or (args:get-arg "-m") "")) ) - - (debug:print 0 *default-log-port* "Listing files in " ) - (sretrieve:ls configdat user dir msg))) - - (else (debug:print 0 *default-log-port* "Unrecognised command " action))))) - -;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! -;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc"))) -;; (if (file-exists? debugcontrolf) -;; (load debugcontrolf))) + (if (< (length args) 2) + (begin + (print "ERROR: Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (iport (make-readline-port ">")) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((cp) + (if (< (length args) 2) + (begin + (print "ERROR: Missing arguments; " ) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (iport (make-readline-port ">")) + (area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + (sub-path (if (null? remargs) + "" + (car remargs)))) + ; (print args) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (let* ((target-path (sauth-common:get-target-path '() (conc area "/" sub-path) top-areas base-path)) + (restrictions (if (equal? target-path #f) + "" + (sretrieve:shell-lookup base-path)))) + ;(print target-path) + (if (not (equal? target-path #f)) + (begin + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "get " area " " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "get")))) + (sretrieve:get-shell-cmd-line target-path base-path restrictions iport)))))) + ((ls) + (cond + ((< (length args) 1) + (begin + (print "ERROR: Missing arguments; ") + (exit 1))) + ((equal? (length args) 1) + (let* ((area (car args)) + (usr (current-user-name)) + (area-obj (get-obj-by-code area)) + (user-obj (get-user usr)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj))))) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (sauth-common:shell-ls-cmd '() area top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" "ls" (number->string (car user-obj)) (number->string (caddr area-obj)) "ls")))))) + ((> (length args) 1) + (let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0)) + (usr (current-user-name)) + (user-obj (get-user usr)) + (area (car args))) + (let* ((area-obj (get-obj-by-code area)) + (top-areas (sretrieve:get-accessable-projects area)) + (base-path (if (null? area-obj) + "" + (caddr (cdr area-obj)))) + + (sub-path (if (null? remargs) + area + (conc area "/" (car remargs))))) + ;(print "sub path " sub-path) + (if (null? area-obj) + (begin + (print "Area " area " does not exist") + (exit 1))) + (sauth-common:shell-ls-cmd `() sub-path top-areas base-path '()) + (sauthorize:do-as-calling-user + (lambda () + (run-cmd (conc *sauth-path* "/sauthorize") (list "register-log" (conc "ls " sub-path) (number->string (car user-obj)) (number->string (caddr area-obj)) "ls"))))))))) + + ((shell) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments !!" ) + (exit 1)) + (sretrieve:shell (car args)))) + (else (debug:print 0 "Unrecognised command " action)))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) @@ -586,34 +1050,17 @@ ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print sretrieve:help)) - ((list-vars) ;; print out the ini file - (map print (sretrieve:get-areas configdat))) - ((ls) - (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))) - (if base-dir - (begin - (print "Files in " base-dir) - (sretrieve:do-as-calling-user - (lambda () - (process-execute "/bin/ls" (list "-lrt" base-dir))))) - (print "ERROR: No base dir specified!")))) - ((log) - (sretrieve:db-do configdat (lambda (db) - (print "Logs : ") - (query (for-each-row - (lambda (row) - (apply print (intersperse row " | ")))) - (sql db "SELECT * FROM actions"))))) - ((shell) - (sretrieve:shell)) (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2) (apply sretrieve:process-action configdat (car rema)(cdr rema))) - (else (debug:print-error 0 *default-log-port* "Unrecognised command. Try \"sretrieve help\""))))) + (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main) + + + Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -170,21 +170,21 @@ (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) (define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) (define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) (define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) -(define (tasks:server-lock-slot mdb run-id) +(define (tasks:server-lock-slot mdb run-id transport-type) (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot") (if (< (tasks:num-in-available-state mdb run-id) 4) (begin - (tasks:server-set-available mdb run-id) + (tasks:server-set-available mdb run-id transport-type) (thread-sleep! (/ (random 1500) 1000)) ;; (thread-sleep! 2) ;; Try removing this. It may not be needed. (tasks:server-am-i-the-server? mdb run-id)) #f)) ;; register that this server may come online (first to register goes though with the process) -(define (tasks:server-set-available mdb run-id) +(define (tasks:server-set-available mdb run-id transport-type) (sqlite3:execute mdb "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id) VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);" (current-process-id) ;; pid @@ -194,11 +194,11 @@ (random 1000) ;; priority (used a tiebreaker on get-available) "available" ;; state (common:version-signature) ;; mt_version -1 ;; interface ;; (conc (server:get-transport)) ;; transport - (conc *transport-type*) ;; transport + (symbol->string transport-type) ;; transport run-id )) (define (tasks:num-in-available-state mdb run-id) (let ((res 0)) @@ -323,12 +323,12 @@ (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) mdb - (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") - run-id) + (conc "SELECT " selstr " FROM servers WHERE state in ('available','running','dbprep') ORDER BY start_time DESC;") + ) (vector header res))) (define (tasks:get-server mdb run-id #!key (retries 10)) (let ((res #f) (best #f)) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -157,11 +157,12 @@ # force use of server always # required yes # Use http instead of direct filesystem access -transport http +transport rpc +# transport http # transport fs # transport nmsg synchronous 0 Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,8 +1,8 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET -check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat +check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUNNAME.dat [logpro] check_triggers ;; (expect:error in "LogFileBody" = 0 "No errors" #/error/i) ADDED thunk-utils.scm Index: thunk-utils.scm ================================================================== --- /dev/null +++ thunk-utils.scm @@ -0,0 +1,121 @@ +(use srfi-18) + + +;; wrap a proc with a mutex so that two threads may not call proc simultaneously. +;; will catch exceptions to ensure mutex is unlocked even if exception is thrown. +;; will generate a unique mutex for proc unless one is specified with canned-mutex: option +;; +;; example 1: (define thread-safe-+ (make-synchronized-proc +)) +;; example 2: (define thread-safe-plus +;; (make-synchronized-proc +;; (lambda (x y) +;; (+ x y)))) + +(define (make-synchronized-proc proc + #!key (canned-mutex #f)) + (let* ((guard-mutex (if canned-mutex canned-mutex (make-mutex))) + (guarded-proc ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. + (lambda args + (mutex-lock! guard-mutex) + (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision with a proc that returns a pair having the first element be our flag. gensym guarantees the symbol is unique. + (res + (condition-case + (apply proc args) ;; this is what we are guarding the execution of + [x () (cons EXCEPTION x)] + ))) + (mutex-unlock! guard-mutex) + (cond + ((and (pair? res) (eq? (car res) EXCEPTION)) + (raise (cdr res))) + (else + res)))))) + guarded-proc)) + + +;; retry an operation (depends on srfi-18) +;; ================== +;; idea here is to avoid spending time on coding retrying something. Trying to be generic here. +;; +;; Exception handling: +;; ------------------- +;; if evaluating the thunk results in exception, it will be retried. +;; on last try, if final-failure-returns-actual is true, the exception will be re-thrown to caller. +;; +;; look at options below #!key to see how to configure behavior +;; +;; + +(define (retry-thunk + the-thunk + #!key ;;;; options below + (accept-result? (lambda (x) x)) ;; retry if predicate applied to thunk's result is false + (retries 4) ;; how many tries + (failure-value #f) ;; return this on final failure, unless following option is enabled: + (final-failure-returns-actual #f) ;; on failure, on the last try, just return the result, not failure-value + + (retry-delay 0.1) ;; delay between tries + (back-off-factor 1) ;; multiply retry-delay by this factor on retry + (random-delay 0.1) ;; add a random portion of this value to wait + + (chatty #f) ;; print status as we go, for debugging. + ) + + (when chatty (print) (print "Entered retry-thunk") (print "-=-=-=-=-=-")) + (let* ((guarded-thunk ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. + (lambda () + (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision + (res + (condition-case + (the-thunk) ;; this is what we are guarding the execution of + [x () (cons EXCEPTION x)] + ))) + (cond + ((and (pair? res) (eq? (car res) EXCEPTION)) + (if chatty + (print " - the-thunk threw exception >"(cdr res)"<")) + (cons 'exception (cdr res))) + (else + (if chatty + (print " - the-thunk returned result >"res"<")) + (cons 'regular-result res))))))) + + (let loop ((guarded-res (guarded-thunk)) + (retries-left retries) + (fail-wait retry-delay)) + (if chatty (print " ==========")) + (let* ((wait-time (+ fail-wait (+ (* fail-wait back-off-factor) + (* random-delay + (/ (random 1024) 1024) )))) + (res-type (car guarded-res)) + (res-value (cdr guarded-res))) + (cond + ((and (eq? res-type 'regular-result) (accept-result? res-value)) + (if chatty (print " + return result that satisfied accept-result? >"res-value"<")) + res-value) + + ((> retries-left 0) + (if chatty (print " - sleep "wait-time)) + (thread-sleep! wait-time) + (if chatty (print " + retry ["retries-left" tries left]")) + (loop (guarded-thunk) + (sub1 retries-left) + wait-time)) + + ((eq? res-type 'regular-result) + (if final-failure-returns-actual + (begin + (if chatty (print " + last try failed- return the result >"res-value"<")) + res-value) + (begin + (if chatty (print " + last try failed- return canned failure value >"failure-value"<")) + failure-value))) + + (else ;; no retries left; result was not accepted and res-type can only be 'exception + (if final-failure-returns-actual + (begin + (if chatty (print " + last try failed with exception- re-throw it >"res-value"<")) + (abort res-value)); re-raise the exception. TODO: find a way for call-history to show as though from entry to this function + (begin + (if chatty (print " + last try failed with exception- return canned failure value >"failure-value"<")) + failure-value)))))))) + Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -10,14 +10,13 @@ # This program is distributed WITHOUT ANY WARRANTY; without even the # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. echo You may need to do the following first: -echo sudo apt-get install libreadline-dev -echo sudo apt-get install libwebkitgtk-dev +echo sudo apt-get install libreadline-dev libsqlite3-dev libwebkitgtk-dev echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake -echo sudo apt-get install libssl-dev +echo sudo apt-get install libssl-dev uuid-dev libglu1-mesa-dev echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 echo echo Set OPTION to std, currently OPTION=$OPTION echo echo Additionally, if you want mysql-client, you will need to make sure @@ -25,21 +24,37 @@ echo echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" + +if [[ "$OPTION"x == "x" ]];then + OPTION=std +fi SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION + +# default chicken version variables. Override in case statement as appropriate +CHICKEN_VERSION=4.10.0 +CHICKEN_BASEVER=4.10.0 # Set up variables # case $SYSTEM_TYPE in Ubuntu-16.04-x86_64-std) KTYPE=32 CDVER=5.10 IUPVER=3.17 IMVER=3.11 + ;; +Ubuntu-16.04-x86_64-new) + KTYPE=32 + CDVER=5.10 + IUPVER=3.17 + IMVER=3.11 + CHICKEN_VERSION=4.10.0 + CHICKEN_BASEVER=4.10.0 ;; Ubuntu-16.04-i686-std) KTYPE=32 CDVER=5.10 IUPVER=3.17 @@ -103,12 +118,10 @@ # Put all the downloaded tar files in tgz mkdir -p tgz # http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz -export CHICKEN_VERSION=4.11.0 -export CHICKEN_BASEVER=4.11.0 chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz if ! [[ -e tgz/$chicken_targz ]]; then wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz} mv $chicken_targz tgz fi @@ -177,11 +190,11 @@ cd $BUILDHOME # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do # $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing -for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \ +for egg in matchable readline apropos dbi base64 regex-literals format "regex-case" "test" \ coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \ tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client \ spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \ sxml-modifications logpro z3 call-with-environment-variables \ pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42 \ @@ -302,12 +315,12 @@ cd histstore $PREFIX/bin/csc histstore.scm -o hs cp -f hs $PREFIX/bin/hs cd ../mutils $PREFIX/bin/chicken-install - cd ../dbi - $PREFIX/bin/chicken-install + # cd ../dbi + # $PREFIX/bin/chicken-install cd ../margs $PREFIX/bin/chicken-install fi cd $BUILDHOME