Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -257,19 +257,15 @@ 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)" Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -46,23 +46,17 @@ (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 - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (5)") - (exit)))) + (else (rpc:client-connect iface port)))) (define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) (case (server:get-transport) - ((rpc) (let ((res (client:setup-rpc run-id remaining-tries: remaining-tries))) - (remote-conndat-set! *runremote* res) - res)) + ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects)) - (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (6)") - (exit)))) ;; (client:setup-rpc run-id)))) + (else (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (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)) @@ -158,30 +152,10 @@ ;; ;; 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 @@ -191,12 +165,22 @@ (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 (http-transport:client-connect iface port)) - (ping-res (rmt:login-no-auto-client-setup start-res))) + (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))) + + ))) (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)) @@ -213,23 +197,23 @@ (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (if (> remaining-tries 8) (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) + (server:try-running *toppath*) (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (if (< num-available 2) - (server:try-running run-id)) + (server:try-running *toppath*)) (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 ;; this is unused, not porting for rpc -BB +;; keep this as a function to ease future (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,12 +18,10 @@ (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) @@ -62,24 +60,13 @@ (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) - ;; 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))))) + (let ((res (proc cxt))) + (mutex-unlock! cxt-mutex) + res)))) (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data @@ -114,22 +101,11 @@ (define *db-access-mutex* (make-mutex)) (define *db-cache-path* #f) ;; SERVER (define *my-client-signature* #f) -(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 *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (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) @@ -603,11 +579,11 @@ (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (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)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + ;;(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write (sync-in-progress *db-sync-in-progress*) @@ -642,11 +618,11 @@ ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) - (BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) @@ -655,10 +631,11 @@ (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) (define (std-exit-procedure) (on-exit (lambda () 0)) + ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) @@ -690,19 +667,10 @@ (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) ) ) @@ -710,10 +678,11 @@ 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) + ;;(BB> "got signal "signum) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -121,10 +121,11 @@ (db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) +(define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) (location #f)) (for-each (lambda (frame) @@ -131,11 +132,11 @@ (let* ((this-loc (vector-ref frame 0)) (this-func (cadr (string-split this-loc " ")))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) - (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args))) + (let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) in-args))) (apply debug:print dp-args)))) (define *BBpp_custom_expanders_list* (make-hash-table)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -473,11 +473,11 @@ (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn - (tests:get-testconfig (db:test-get-testname testdat) test-registry #f) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dashboard-tests:run-html-viewer logfile) 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: 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-lastaccess* (current-seconds)) + (set! *db-last-access* (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))) @@ -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) 'http))) + (server-dat (vector iface port api-uri api-url api-req (current-seconds)))) 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. ;; @@ -383,30 +383,34 @@ (server-going #f)) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) - + ;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going) ;; Use this opportunity to sync the tmp db to megatest.db (if (not server-going) ;; *dbstruct-db* ;; Removed code is pasted below (keeping it around until we are clear it is not needed). ;; no *dbstruct-db* yet, set running after our first pass through and start the db (if (eq? server-state 'available) (let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers (if (equal? new-server-id server-id) (begin (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") + ;;(BB> "http-transport: ->dbprep") (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") + ;;(BB> "http-transport: ->running") (server:write-dotserver *toppath* (conc iface ":" port)) - (server:dotserver-starting-remove)) - (begin ;; gotta exit nicely + (thread-start! *watchdog*) + (server:complete-attempt *toppath*)) + (begin ;; gotta exit nicely + ;;(BB> "http-transport: ->collision") (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. (let* ((sync-time (- (current-milliseconds) start-time)) (rem-time (quotient (- 4000 sync-time) 1000))) (if (and (<= rem-time 4) @@ -486,10 +490,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))) + ;;(BB> "http-transport:server-shutdown called") (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") @@ -513,18 +518,19 @@ " ms") (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") ;; if the .server file contained :myport then we can remove it (server:remove-dotserver-file *toppath* port) + ;;(BB> "http-transport:server-shutdown -> exit") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) - (server:dotserver-starting) + (server:attempting-start *toppath*) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) @@ -536,25 +542,24 @@ (server:check-if-running run-id)) (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 'http)) + (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)) (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 'http) + (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) " http-transport:launch") - - (server:dotserver-starting-remove) + (server:complete-attempt *toppath*) )) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") @@ -636,11 +641,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 *last-db-access*) "" + "Last access" (seconds->time-string *db-last-access*) "" ""))) (mutex-unlock! *heartbeat-mutex*) res)) (define (http-transport:runs linkpath) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -280,11 +280,11 @@ ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. - (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) + (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) (hash-table-ref/default testconfig "ezsteps" '()) #f))) (if testconfig (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... @@ -828,11 +828,10 @@ (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)) @@ -1090,11 +1089,11 @@ (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) + (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) (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 Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6302) +(define megatest-version 1.6303) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -331,11 +331,10 @@ 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") @@ -350,12 +349,14 @@ ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread common:watchdog "Watchdog thread")) -(thread-start! *watchdog*) -(BB> "thread-start! watchdog") +(if (not (args:get-arg "-server")) + (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog +;;(BB> "thread-start! watchdog") + (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log")) (set! *default-log-port* oup))) @@ -704,11 +705,13 @@ ;; 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 *transport-type* )) + (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) + ;; (if run-id + ;; (begin (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 @@ -1989,12 +1992,19 @@ ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help)) -(BB> "thread-join! watchdog") -(thread-join! *watchdog*) +;;(BB> "thread-join! watchdog") + +;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) +;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) +(if (thread? *watchdog*) + (case (thread-state *watchdog*) + ((ready running blocked sleeping terminated dead) + (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 Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -6,18 +6,17 @@ ;; ;; 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!!! @@ -141,16 +140,11 @@ ((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) - (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)) + (remote-conndat-set! *runremote* (rmt:get-connection-info 0)) ;; calls client:setup which calls client:setup-http (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") @@ -162,25 +156,21 @@ (let* ((conninfo (remote-conndat *runremote*)) (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 (1)") + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported") (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 rpc) res) + ((http) 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) @@ -280,22 +270,14 @@ (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 - (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)) - - )))) + (http-transport:client-api-send-receive run-id connection-info cmd params)))) (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?) @@ -335,16 +317,11 @@ ;; 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 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)) - - + ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) ;;((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 Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2016, Matthew Welland. +;; Copyright 2006-2012, 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,621 +21,208 @@ (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) ;; 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))) - ) - +(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))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (rpc-transport:launch run-id) - (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")))))) - - + (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)))))) (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!) - ;;====================================================================== - ;; 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 - ;;====================================================================== - + (rpc:publish-procedure! 'server:login server:login) + (rpc:publish-procedure! 'testing (lambda () "Just testing")) (let* ((db #f) - (hostname (let ((res (get-host-name))) res)) - (server-start-time (current-seconds)) - (server-timeout (server:get-timeout)) - (ipaddrstr (let* ((ipstr (if (string=? "-" hostn) + (hostname (get-host-name)) + (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) - #f)) - (res (if ipstr ipstr hostn))) - res)) ;; hostname))) - (start-port (let ((res (portlogger:open-run-close portlogger:find-port))) ;; BB> TODO: remove portlogger! - res)) + #f))) + (if ipstr ipstr hostn))) ;; hostname))) + (start-port (open-run-close tasks:server-get-next-port tasks:open-db)) (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; 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)) + (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) (th1 (make-thread (lambda () - ;;(BB> "BEFORE rpc:make-server") - ((rpc:make-server rpc:listener) #t) - ;;(BB> "BEFORE rpc:make-server") - ) + ((rpc:make-server rpc:listener) #t)) "rpc:server")) - - - (hostname (if (string=? "-" hostn) + ;; (cute (rpc:make-server rpc:listener) "rpc:server") + ;; 'rpc:server)) + (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))) ".") - (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 - ;;============================================================= + #f)) + (portnum (rpc:default-server-port)) + (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum)) + (tdb (tasks:open-db))) (thread-start! th1) (set! db *dbstruct-db*) - - (debug:print 0 *default-log-port* "Server started on " host: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 ) + (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) (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 (add1 port))) + (rpc-transport:find-free-port-and-open (+ port 1))) (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-buffer-size 0) ;; gotta do this because http-transport undoes it. - (tcp-listen (rpc:default-server-port) 10000) - )) - + (tcp-listen (rpc:default-server-port) 10000))) + (define (rpc-transport:ping run-id host port) (handle-exceptions exn (begin - (print "SERVER_NOT_FOUND exn="exn) + (print "SERVER_NOT_FOUND") (exit 1)) (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) - (if login-res + (if (and (list? login-res) + (car login-res)) (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1)))))) -(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)))))) +(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 *toppath*) + (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 *toppath*) + (thread-sleep! 2) + (rpc-transport:client-setup run-id (- remtries 1))))) + (begin + (server:try-running *toppath*) + (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"))))) + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -46,24 +46,32 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; -(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))))) - +(define (server:launch run-id transport-type) + ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type) + + (let ((attempt-in-progress (server:start-attempted? *toppath*))) + (when attempt-in-progress + (debug:print-info 0 *default-log-port* "Server start attempt in progress in other process (=> "attempt-in-progress"<=). Aborting server launch attempt in this process ("(current-process-id)")") + (exit))) + + (let ((dotserver-url (server:check-if-running *toppath*))) + (when dotserver-url + (debug:print-info 0 *default-log-port* "Server already running (=> "dotserver-url"<=). Aborting server launch attempt in this process ("(current-process-id)")") + (exit) + )) + + (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))))) + ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Get the transport @@ -71,11 +79,11 @@ (if *transport-type* *transport-type* (let ((ttype (string->symbol (or (args:get-arg "-transport") (configf:lookup *configdat* "server" "transport") - *DEFAULT-TRANSPORT*)))) + "rpc")))) (set! *transport-type* ttype) ttype))) ;; Generate a unique signature for this server (define (server:mk-signature) @@ -107,54 +115,60 @@ ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; -(define (server:run areapath) ;; areapath is ignored for now. +(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area (let* ((curr-host (get-host-name)) + (attempt-in-progress (server:start-attempted? areapath)) + (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) - (logfile (conc *toppath* "/logs/server.log")) + (logfile (conc areapath "/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) - "") - " -transport " (server:get-transport) + " -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") + (conc " -daemonize -log " logfile) + "") " -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 ") ...") - (thread-start! log-rotate) - - ;; host.domain.tld match host? - (if (and target-host - ;; look at target host, is it host.domain.tld or ip address and does it - ;; match current ip or hostname - (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) - (not (equal? curr-ip target-host))) - (begin - (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) - (setenv "TARGETHOST" target-host))) - - (setenv "TARGETHOST_LOGF" logfile) - (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever - (system (conc "nbfake " cmdln)) - (unsetenv "TARGETHOST_LOGF") - (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) - (thread-join! log-rotate) - (pop-directory))) - + (push-directory areapath) + (cond + (attempt-in-progress + (debug:print 0 *default-log-port* "INFO: Not trying to start server because attempt is in progress: "attempt-in-progress)) + (dot-server-url + (debug:print 0 *default-log-port* "INFO: Not trying to start server because one is already running : "dot-server-url)) + (else + (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") + (thread-start! log-rotate) + + ;; host.domain.tld match host? + (if (and target-host + ;; look at target host, is it host.domain.tld or ip address and does it + ;; match current ip or hostname + (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) + (not (equal? curr-ip target-host))) + (begin + (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) + (setenv "TARGETHOST" target-host))) + + (setenv "TARGETHOST_LOGF" logfile) + (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever + (system (conc "nbfake " cmdln)) + (unsetenv "TARGETHOST_LOGF") + (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) + (thread-join! log-rotate) + (pop-directory))))) + (define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) - (set! *my-client-signature* sig) - *my-client-signature*))) + (set! *my-client-signature* sig) + *my-client-signature*))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run areapath) (let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f))) @@ -162,27 +176,36 @@ (> (- (current-seconds) last-run-time) 30)) (begin (server:run areapath) (hash-table-set! *server-kind-run* areapath (current-seconds)))))) -;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 -;; -;; (define (server:try-running run-id) -;; (if (eq? run-id 0) -;; (server:run run-id) -;; (rmt:start-server run-id))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. +(define (server:attempting-start areapath) + (with-output-to-file + (conc areapath "/.starting-server") + (lambda () + (print (current-process-id) " on " (get-host-name))))) + +(define (server:complete-attempt areapath) + (delete-file* (conc areapath "/.starting-server"))) + (define (server:start-attempted? areapath) (let ((flagfile (conc areapath "/.starting-server"))) (handle-exceptions exn #f ;; if things go wrong pretend we can't see the file - (and (file-exists? flagfile) - (< (- (current-seconds) - (file-modification-time flagfile)) - 15))))) ;; exists and less than 15 seconds old + (cond + ((and (file-exists? flagfile) + (< (- (current-seconds) + (file-modification-time flagfile)) + 15)) ;; exists and less than 15 seconds old + (with-input-from-file flagfile (lambda () (read-line)))) + ((file-exists? flagfile) ;; it is stale. + (server:complete-attempt areapath) + #f) + (else #f))))) (define (server:read-dotserver areapath) (let ((dotfile (conc areapath "/.server"))) (handle-exceptions exn @@ -193,22 +216,10 @@ 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")) @@ -224,15 +235,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 #!key (force #f)) +(define (server:remove-dotserver-file areapath hostport) (let ((dotserver (server:read-dotserver areapath)) (server-file (conc areapath "/.server")) (lock-file (conc areapath "/.server.lock"))) - (if (or force (and dotserver (string-match (conc ".*:" hostport "$") dotserver))) ;; port matches, good enough info to decide to remove the file + (if (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 @@ -244,16 +255,18 @@ ;; (define (server:check-if-running areapath) (let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db))) (if dotserver (let* ((res (case *transport-type* - ((http rpc)(server:ping-server dotserver)) + ((http)(server:ping-server dotserver)) ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) ))) (if res dotserver - #f)) + (begin + (server:remove-dotserver-file areapath ".*") ;; remove stale dotserver + #f))) #f))) ;; called in megatest.scm, host-port is string hostname:port ;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running @@ -283,17 +296,11 @@ (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 - (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)))) + (server-dat (http-transport:client-connect iface port)) (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,14 +7,10 @@ ;; 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) @@ -22,12 +18,10 @@ ;; (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:)) @@ -45,32 +39,29 @@ ;; (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 - +(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 : + 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)) ;; " @@ -80,13 +71,10 @@ ;;====================================================================== ;; DB ;;====================================================================== -(define *default-log-port* (current-error-port)) -(define *verbosity* 1) - (define (spublish:initialize-db db) (for-each (lambda (qry) (exec (sql db qry))) (list @@ -161,11 +149,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 () @@ -355,332 +343,10 @@ (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 ;;====================================================================== @@ -691,110 +357,148 @@ (if (file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) -(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))) +(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))) (case (string->symbol action) ((cp publish) - (if (< (length remargs) 2) + (if (< (length args) 2) (begin - (print "ERROR: Missing arguments; spublish " ) + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1))) - (let* ((filter-args (args:get-args args '("-m") '() args:arg-hash 0)) - (src-path-in (car filter-args)) - (dest-path (cadr filter-args)) + (let* ((remargs (args:get-args args '("-m") '() args:arg-hash 0)) + (dest-dir (cadr args)) + (src-path-in (car args)) (src-path (with-input-from-pipe (conc "readlink -f " src-path-in) (lambda () (read-line)))) (msg (or (args:get-arg "-m") "")) - (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 remargs) 1) - (begin - (print "ERROR: Missing arguments; ") - (exit 1))) - (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)) - (spublish:shell area))) + (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))) + + ((rm) + (if (< (length args) 1) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (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 ", ")) + (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))) (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) @@ -802,21 +506,37 @@ (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) - (exe-name (pathname-file (car (argv))))) + (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))) (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 (car rema)(cdr rema))) + (apply spublish:process-action configdat (car rema)(cdr rema))) (else (print "ERROR: Unrecognised command2. Try \"spublish help\""))))) (main) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -7,38 +7,43 @@ ;; 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 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 srfi-18) -(use srfi-19) -;;(use utils) -;;(use format) -(use refdb) +(use format) + ;; (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) @@ -46,14 +51,16 @@ (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 path to the data within - -m \"message\" : why retrieved? - shell : start a shell-like interface + 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 Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -87,11 +94,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 @@ -102,14 +109,15 @@ ;; (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 "[database]\nlocation /some/path\n\n Is missing from the config file!") + (debug:print 0 *default-log-port* "[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")) @@ -116,37 +124,37 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) - ;;(debug:print 0 "calling proc " proc "db path " dbpath ) + ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) - ;;(debug:print 0 "calling proc " proc " on db " db) + ;;(debug:print 0 *default-log-port* "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)))) + (debug:print-error 0 *default-log-port* "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 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) + (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." ) (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -165,11 +173,12 @@ (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) @@ -178,34 +187,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 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) (exit 1))) (if (directory? datadir) (begin - (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) + (debug:print-error 0 *default-log-port* "(" file ") is a dirctory!! cp cmd works only on files ." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) + (debug:print-error 0 *default-log-port* "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 "ph: "(pathname-directory datadir) "!! " ) + ;; (debug:print 0 *default-log-port* "ph: "(pathname-directory datadir) "!! " ) (change-directory (pathname-directory datadir)) - ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) + ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) ) (process-execute "/bin/tar" (list "chfv" "-" filename))) )) ;; ls in file to dest, validation is done BEFORE calling this ;; @@ -215,44 +224,148 @@ (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 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) + (debug:print-error 0 *default-log-port* "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 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) + (debug:print-error 0 *default-log-port* "Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") + (debug:print-error 0 *default-log-port* "You cannot update data outside " target-dir ".") (exit 1))) - (debug:print 0 "Path " targ-mk " is valid.") + (debug:print 0 *default-log-port* "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) @@ -279,11 +392,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 "running as " (current-effective-user-id)) + ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (sretrieve:find name paths) @@ -304,738 +417,161 @@ ;;====================================================================== ;; 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) +(define (toplevel-command . args) #f) +(define (sretrieve:shell) (use readline) (let* ((path '()) - (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)))) + (prompt "> ") + (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18")) (iport (make-readline-port prompt))) - (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))) + (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"))) (let* ((parts (string-split inl)) (cmd (if (null? parts) #f (car parts)))) - ; (print "2") - (if (and (not cmd) (not (port-closed? iport))) + (if (not cmd) (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")))))))) - ((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 "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 iport))))))) -;;)) + (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths + (set! path '()))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + path)) + (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 "/"))))))) + (else + (print "Got command: " inl)))) + (loop (read-line))))))))) ;;====================================================================== ;; 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 #f) + (read-config fname #f #t) (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"))) - (if (file-exists? upstream-file) + ;; this section here does a timestamp based rebuild of the + ;; /.config file using + ;; as an input + (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 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) + (debug:print-error 0 *default-log-port* "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 "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) + (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) (begin - (debug:print 0 "Reading package config " package-config) + (debug:print 0 *default-log-port* "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) - ; (use readline) + (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))) (case (string->symbol action) ((get) - (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)))) + (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))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) @@ -1050,17 +586,34 @@ ;; 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 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) + (else (debug:print-error 0 *default-log-port* "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 transport-type) +(define (tasks:server-lock-slot mdb run-id) (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 transport-type) + (tasks:server-set-available mdb run-id) (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 transport-type) +(define (tasks:server-set-available mdb run-id) (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 - (symbol->string transport-type) ;; transport + (conc *transport-type*) ;; transport run-id )) (define (tasks:num-in-available-state mdb run-id) (let ((res 0)) @@ -402,11 +402,11 @@ (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) (debug:print 0 *default-log-port* "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) - (server:kind-run run-id) + (server:kind-run *toppath*) (thread-sleep! (min delay-time 1)) (if (not (or (server:start-attempted? *toppath*) (server:read-dotserver *toppath*))) ;; no point in trying (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)) #f)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -141,11 +141,11 @@ ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry) - (let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs))) + (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) @@ -291,11 +291,11 @@ ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) - (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) + (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr (db:test-get-rundir testdat)) ;; ) (prev-rundir ;; (sdb:qry 'passstr (db:test-get-rundir prev-testdat)) ;; ) (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) @@ -979,11 +979,11 @@ ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; -(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)) (let* ((cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read (file-exists? cache-file))) @@ -991,14 +991,17 @@ cache-exists) (handle-exceptions exn #f ;; any issues, just give up with the cached version and re-read (configf:read-alist cache-file)) - #f))) + #f)) + (test-full-name (if (and item-path (not (string-null? item-path))) + (conc test-name "/" item-path) + test-name))) (if cached-dat cached-dat - (let ((dat (hash-table-ref/default *testconfigs* test-name #f))) + (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f))) (if (and dat ;; have a locally cached version (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? dat ;; no cached data available (let* ((treg (or test-registry @@ -1012,11 +1015,11 @@ environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data - (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) + (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) @@ -1240,11 +1243,12 @@ (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") - (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) + ;; don't know item-path at this time, let the testconfig get the top level testconfig + (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -157,12 +157,11 @@ # force use of server always # required yes # Use http instead of direct filesystem access -transport rpc -# transport http +transport http # transport fs # transport nmsg synchronous 0 Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -10,13 +10,14 @@ # 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 libsqlite3-dev libwebkitgtk-dev +echo sudo apt-get install libreadline-dev +echo sudo apt-get install libwebkitgtk-dev echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake -echo sudo apt-get install libssl-dev uuid-dev libglu1-mesa-dev +echo sudo apt-get install libssl-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,37 +26,21 @@ 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 IMVER=3.11 @@ -118,10 +103,12 @@ # 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 @@ -190,11 +177,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 dbi base64 regex-literals format "regex-case" "test" \ +for egg 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 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 \ @@ -315,12 +302,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