Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -56,11 +56,11 @@ (argv) (list "-rows" "-run" "-test" "-debug" - "-server" + "-host" ) (list "-h" "-guimonitor" "-main" "-v" @@ -79,33 +79,35 @@ (print "Failed to find megatest.config, exiting") (exit 1))) (define *db* #f) ;; (open-db)) -(if (args:get-arg "-server") +(if (args:get-arg "-host") (begin - (set! *runremote* (string-split (args:get-arg "-server" ":"))) - (server:client-launch))) + (set! *runremote* (string-split (args:get-arg "-host" ":"))) + (server:client-launch)) + (server:client-launch)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (open-run-close db:get-keys #f)) +;; (define *keys* (open-run-close db:get-keys #f)) +(define *keys* (cdb:remote-run db:get-keys #f)) ;; (define *keys* (db:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (open-run-close db:get-num-runs #f "%")) +(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) (define *last-update* (current-seconds)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) @@ -169,11 +171,11 @@ (begin (debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts) (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (open-run-close db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (let* ((allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -185,13 +187,13 @@ (begin (set! *last-update* (current-seconds)) (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt)))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (open-run-close db:get-tests-for-run #f run-id testnamepatt states statuses))) + (tests (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (open-run-close db:get-key-vals #f run-id))) + (key-vals (cdb:remote-run db:get-key-vals #f run-id))) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set (not (null? tests))) (set! result (cons (vector run tests key-vals) result))))) @@ -643,11 +645,11 @@ (if runid (begin (lambda (x) (on-exit (lambda () (if *db* (sqlite3:finalize! *db*)))) - (open-run-close examine-run *db* runid))) + (cdb:remote-run examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1125,13 +1125,13 @@ ((zmq) (handle-exceptions exn (begin (thread-sleep! 5) - (if (> numretries 0)(apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params))) - (let* ((push-socket (vector-ref zmq-sockets 0)) - (sub-socket (vector-ref zmq-sockets 1)) + (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) + (let* ((push-socket (vector-ref serverdat 0)) + (sub-socket (vector-ref serverdat 1)) (client-sig (server:get-client-signature)) (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params)))) (res #f) (send-receive (lambda () @@ -1157,11 +1157,11 @@ (debug:print 2 "WARNING: no reply to query " params ", trying resend") (debug:print-info 11 "re-sending message") (send-message push-socket zdat) (debug:print-info 11 "message re-sent") (loop (- n 1))) - ;; (apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params)) + ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) (begin (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") (exit 5)))))))) (debug:print-info 11 "Starting threads") (let ((th1 (make-thread send-receive "send receive")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -59,20 +59,23 @@ (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) - (runremote (assoc/default 'runremote cmdinfo)) + ;; (runremote (assoc/default 'runremote cmdinfo)) + (transport (assoc/default 'transport cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) + (keys #f) + (keyvals #f) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc testpath "/" runscript))) @@ -82,11 +85,14 @@ runscript))))) ;; assume it is on the path (rollup-status 0)) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; Setup the *runremote* global var (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time")) - (set! *runremote* runremote) + ;; (set! *runremote* runremote) + (set! *transport-type* (string->symbol transport)) + (set! keys (cdb:remote-run db:get-keys #f)) + (set! keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 "varpairs: " varpairs) @@ -111,17 +117,17 @@ (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) ;; Can setup as client for server mode now - (server:client-setup) + ;; (server:client-setup) (change-directory *toppath*) (set-megatest-env-vars run-id) ;; these may be needed by the launching process (change-directory work-area) - (open-run-close set-run-config-vars #f run-id) + (open-run-close set-run-config-vars #f run-id keys keyvals) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") @@ -574,11 +580,12 @@ (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) - (list 'runremote *runremote*) + ;; (list 'runremote *runremote*) + (list 'transport (conc *transport-type*)) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -103,10 +103,11 @@ -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -transport http|zmq : use http or zmq for transport (default is http) -list-servers : list the servers -repl : start a repl (useful for extending megatest) + -load file.scm : load and run file.scm Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -172,10 +173,11 @@ "-set-state-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all + "-load" ;; load and exectute a scheme file ) (list "-h" "-version" "-force" "-xterm" @@ -390,14 +392,14 @@ (let* ((db #f) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (open-run-close db:get-runs db runpatt #f #f '())) + (runsdat (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (open-run-close db:get-keys db)) + (keys (cdb:remote-run db:get-keys #f)) (keynames (map key:get-fieldname keys)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each @@ -410,12 +412,12 @@ (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) - (let* ((run-id (open-run-close db:get-value-by-header run header "id")) - (tests (open-run-close db:get-tests-for-run db run-id testpatt '() '()))) + (let* ((run-id (db:get-value-by-header run header "id")) + (tests (cdb:remote-run db:get-tests-for-run #f run-id testpatt '() '()))) (debug:print 1 "Run: " targetstr " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) (format #t @@ -437,11 +439,11 @@ "\n diskfree: " (db:test-get-diskfree test) "\n uname: " (db:test-get-uname test) "\n rundir: " (db:test-get-rundir test) ) ;; Each test - (let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test)))) + (let ((steps (cdb:remote-run db:get-steps-for-test #f (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (db:step-get-stepname step) @@ -554,11 +556,12 @@ (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - (runremote (assoc/default 'runremote cmdinfo)) + ;; (runremote (assoc/default 'runremote cmdinfo)) + (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) @@ -567,11 +570,12 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) - (set! *runremote* runremote) + ;; (set! *runremote* runremote) + (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (setup-for-run)) @@ -675,44 +679,49 @@ (set! *didsomething* #t))) ;;====================================================================== ;; Test commands (i.e. for use inside tests) ;;====================================================================== + +(define (megatest:step step state status logfile msg) + (if (not (getenv "MT_CMDINFO")) + (begin + (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (exit 5)) + (let* ((cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) + (runremote (assoc/default 'runremote cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (db #f)) + (change-directory testpath) + (set! *runremote* runremote) + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (if (and state status) + (open-run-close db:teststep-set-status! db test-id step state status msg logfile) + (begin + (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") + (exit 6)))))) (if (args:get-arg "-step") - (if (not (getenv "MT_CMDINFO")) - (begin - (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") - (exit 5)) - (let* ((step (args:get-arg "-step")) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - (runremote (assoc/default 'runremote cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (test-id (assoc/default 'test-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - (logfile (args:get-arg "-setlog"))) - (change-directory testpath) - (set! *runremote* runremote) - (if (not (setup-for-run)) - (begin - (debug:print 0 "Failed to setup, exiting") - (exit 1))) - (if (and state status) - (open-run-close db:teststep-set-status! db test-id step state status (args:get-arg "-m") logfile) - (begin - (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") - (exit 6))) - (if db (sqlite3:finalize! db)) - (set! *didsomething* #t)))) - + (begin + (megatest:step + (args:get-arg "-step") + (args:get-arg ":state") + (args:get-arg ":status") + (args:get-arg "-setlog") + (args:get-arg "-m")) + ;; (if db (sqlite3:finalize! db)) + (set! *didsomething* #t))) + (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") @@ -722,11 +731,12 @@ (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - (runremote (assoc/default 'runremote cmdinfo)) + ;; (runremote (assoc/default 'runremote cmdinfo)) + (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) @@ -734,18 +744,19 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) - (set! *runremote* runremote) + ;; (set! *runremote* runremote) + (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; can setup as client for server mode now - (server:client-setup) + ;; (server:client-setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: (open-run-close db:load-test-data db test-id)) (if (args:get-arg "-setlog") @@ -887,25 +898,29 @@ ;;====================================================================== ;; Start a repl ;;====================================================================== -(if (args:get-arg "-repl") +(if (or (args:get-arg "-repl") + (args:get-arg "-load")) (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (if db (begin (set! *db* db) (set! *client-non-blocking-mode* #t) - (server:client-setup) + ;; (server:client-setup) + ;; (server:client-launch) (import readline) (import apropos) (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) - (repl)) + (if (args:get-arg "-repl") + (repl) + (load (args:get-arg "-load")))) (exit)) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -10,13 +10,14 @@ (include "common_records.scm") -(define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t)) - (let* ((keys (db:get-keys db)) - (keyvals (if run-id (db:get-key-vals db run-id) #f)) +;; (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t)) +(define (setup-env-defaults fname run-id already-seen keys keyvals #!key (environ-patt #f)(change-env #t)) + (let* (;; (keys (db:get-keys db)) + ;; (keyvals (if run-id (db:get-key-vals db run-id) #f)) (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/") (if (args:get-arg "-reqtarg") (args:get-arg "-reqtarg") (if (args:get-arg "-target") (args:get-arg "-target") @@ -58,17 +59,18 @@ sections) (debug:print 2 "---") (set! *already-seen-runconfig-info* #t))) finaldat)) -(define (set-run-config-vars db run-id) +(define (set-run-config-vars db run-id keys keyvals) (let ((runconfigf (conc *toppath* "/runconfigs.config")) (targ (or (args:get-arg "-target") (args:get-arg "-reqtarg") (db:get-target db run-id)))) (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id #t environ-patt: (conc "(default" - (if targ - (conc "|" targ ")") - ")"))) + (setup-env-defaults runconfigf run-id #t keys keyvals + environ-patt: (conc "(default" + (if targ + (conc "|" targ ")") + ")"))) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -215,10 +215,11 @@ (common:clear-caches) ;; clear all caches (let* ((db #f) (keys (cdb:remote-run db:get-keys #f)) (keyvallst (keys:target->keyval keys target)) (run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) + (keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) @@ -225,11 +226,11 @@ (test-records (make-hash-table))) (set-megatest-env-vars run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") + (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) @@ -884,15 +885,15 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-server") - (open-run-close server:start db (args:get-arg "-server")) - (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers - (args:get-arg "-runtests"))) - (server:client-setup) ;; This is a duplicate startup!!!??? BUG? - )) + (open-run-close server:start db (args:get-arg "-server"))) + ;; (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers + ;; (args:get-arg "-runtests"))) + ;; (server:client-setup) ;; This is a duplicate startup!!!??? BUG? + ;; )) (set! keys (open-run-close db:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest zmq) (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -129,12 +129,13 @@ ;; (send-message pubsock (case *transport-type* ((fs) result) ((http)(db:obj->string (vector success/fail query-sig result))) ((zmq) - (send-message pubsock target send-more: #t) - (send-message pubsock (db:obj->string (vector success/fail query-sig result)))) + (let ((pub-socket (vector-ref *runremote* 1))) + (send-message pub-socket return-addr send-more: #t) + (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) (else (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) result))) ;;====================================================================== @@ -154,58 +155,51 @@ (define (server:client-logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (server:get-client-signature))))) ok)) -(define (server:client-connect iface port) - (let* ((login-res #f) - (serverdat (list iface port))) - (set! login-res (server:client-login serverdat)) - (if (and (not (null? login-res)) - (car login-res)) - (begin - (debug:print-info 2 "Logged in and connected to " iface ":" port) - (set! *runremote* serverdat) - serverdat) - (begin - (debug:print-info 2 "Failed to login or connect to " iface ":" port) - (set! *runremote* #f) - #f)))) - ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; +;; There are two scenarios. +;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline +;; 2. We are a run tests, list runs or other interactive process and we mush figure out +;; *transport-type* and *runremote* from the monitor.db +;; (define (server:client-setup #!key (numtries 50)) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: failed to find megatest.config, exiting") (exit)))) - (debug:print-info 11 "*transport-type* is " *transport-type*) - (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out - (open-run-close tasks:get-best-server tasks:open-db) - #f))) + (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) + (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out + (open-run-close tasks:get-best-server tasks:open-db) + #f))) ;; if have hostinfo then extract the transport type ;; else fall back to fs (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) (set! *transport-type* (if hostinfo - (string->symbol (tasks:hostinfo-get-transport hostinfo)) + (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) + ;; DEBUG STUFF + (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99))) + (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) - ((http) - (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo))) - ((zmq) - (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo) - (tasks:hostinfo-get-pubport hostinfo))) - (else ;; default to fs - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))) - + ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ((http) + (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) + (tasks:hostinfo-get-port hostinfo))) + ((zmq) + (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) + (tasks:hostinfo-get-port hostinfo) + (tasks:hostinfo-get-pubport hostinfo))) + (else ;; default to fs + (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") + (set! *transport-type* 'fs) + (set! *megatest-db* (open-db)))))) ;; all routes though here end in exit ... (define (server:launch transport) (if (not *toppath*) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -194,13 +194,13 @@ (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (cons (vector id interface port pubport transport pid hostname) res)) (debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) mdb + ;; strftime('%s','now')-heartbeat < 10 AND "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers - WHERE strftime('%s','now')-heartbeat < 10 - AND mt_version=? ORDER BY start_time ASC LIMIT 1;" megatest-version) + WHERE mt_version=? ORDER BY start_time DESC LIMIT 1;" megatest-version) ;; for now we are keeping only one server registered in the db, return #f or first server found (if (null? res) #f (car res)))) ;; BUG: This logic is probably needed unless methodology changes completely... ;; Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -73,11 +73,12 @@ (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") (exit)))) - (let* ((zmq-sdat1 #f) + (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db + (zmq-sdat1 #f) (zmq-sdat2 #f) (pull-socket #f) (pub-socket #f) (p1 #f) (p2 #f) @@ -102,10 +103,12 @@ (set! zmq-sdat2 (cadr zmq-sockets-dat)) (set! pub-socket (cadr zmq-sdat2)) (set! p2 (caddr zmq-sdat2)) (set! *cache-on* #t) + + (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? ;; what to do when we quit ;; ;; (on-exit (lambda () ;; (if (and *toppath* *server-info*) @@ -136,11 +139,13 @@ (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*))) (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue (begin - (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) + (db:process-queue-item db packet) + ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) + (loop '())) (loop (cons packet queue-lst))))))) ;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. @@ -280,15 +285,15 @@ (define (zmq-transport:client-connect iface pullport pubport) (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push)) (sub-socket (zmq-transport:client-socket-connect iface pubport type: 'sub - subscriptions: (list (zmq-transport:get-client-signature) "all"))) + subscriptions: (list (server:get-client-signature) "all"))) (zmq-sockets (vector push-socket sub-socket)) (login-res #f)) (debug:print-info 11 "zmq-transport:client-connect started. Next is login") - (set! login-res (zmq-transport:client-login zmq-sockets)) + (set! login-res (server:client-login zmq-sockets)) (if (and (not (null? login-res)) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".") (set! *runremote* zmq-sockets) @@ -381,16 +386,16 @@ (th2 (make-thread (lambda () (zmq-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) - (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) + ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) ) (set! *client-non-blocking-mode* #t) ;; (thread-start! th1) (thread-start! th2) - (thread-start! th3) + ;; (thread-start! th3) (set! *didsomething* #t) ;; (thread-join! th3) (thread-join! th2) ) (debug:print 0 "ERROR: Failed to setup for megatest")))