Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -200,10 +200,11 @@ ;; SERVERS ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ((get-server) (api:start-server dbstruct params)) ((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) + ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -228,17 +228,15 @@ (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) (define *server-overloaded* #f) (define *writes-total-delay* 0) +(define *unclean-shutdown* #t) ;; flag to clear on clean shutdown ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex -;; RPC transport -(define *rpc:listener* #f) - ;; KEY info ;; (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here @@ -3649,11 +3647,11 @@ (define (server:expiration-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) - 600))) ;; default is ten minutes + 60))) ;; default is one minute (define (runs:get-mt-env-alist run-id runname target testname itempath) ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") `(("MT_TEST_NAME" . ,testname) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -421,18 +421,19 @@ (db (dbr:dbdat-db dbdat)) (inmem (dbr:dbdat-inmem dbdat)) (start-t (current-seconds)) (last-update (dbr:dbdat-last-write dbdat)) (last-sync (dbr:dbdat-last-sync dbdat))) - (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile) + (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync) (mutex-lock! *db-multi-sync-mutex*) - (let* ((update_info (cons (if force-sync 0 last-update) "last_update")) + (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;; "last_update")) (need-sync (or force-sync (>= last-update last-sync)))) (if need-sync - (db:sync-tables (db:sync-all-tables-list) update_info inmem db) + (begin + (db:sync-tables (db:sync-all-tables-list) update_info inmem db) + (dbr:dbdat-last-sync-set! dbdat start-t)) (debug:print 0 *default-log-port* "Skipping sync as nothing touched."))) - (dbr:dbdat-last-sync-set! dbdat start-t) (mutex-unlock! *db-multi-sync-mutex*))) ;; TODO: Add final sync to this ;; (define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) @@ -649,17 +650,20 @@ (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (has-last-update (member "last_update" fields)) (use-last-update (cond ((and has-last-update - (member "last_update" fields)) + (number? last-update)) #t) ;; if given a number, just use it for all fields - ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table ((and (pair? last-update) (member (car last-update) ;; last-update field name (map car fields))) #t) + ((pair? last-update) + (debug:print 0 *default-log-port* "ERROR: parameter last-update malformed. last-update="last-update) + #f) + ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table (last-update (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields #f) (else #f))) @@ -798,11 +802,11 @@ (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) (if (> count 0) - (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) + (if should-print (debug:print 0 *default-log-port* " "tblname" "count))))) ;; (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count)) (define (db:patch-schema-rundb frundb) ;; @@ -5536,10 +5540,30 @@ #f) ;; server already registered (begin (sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" host port servkey pid ipaddr apath dbname) (db:get-server-info dbstruct apath dbname))))))))) + +;; run this one in a transaction where first check if host:port is taken +(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname) + (db:with-db + dbstruct + #f #f + (lambda (db) + (sqlite3:with-transaction + db + (lambda () + (let* ((sinfo (db:get-server-info dbstruct apath dbname))) + (if (not sinfo) + (begin + (debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port) + #f) ;; server already deregistered + (begin + (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" + ;; host port servkey pid ipaddr + apath dbname) + #;(db:get-server-info dbstruct apath dbname))))))))) (define (db:get-server-info dbstruct apath dbname) (db:with-db dbstruct #f #f Index: docs/manual/server.dot ================================================================== --- docs/manual/server.dot +++ docs/manual/server.dot @@ -17,61 +17,65 @@ digraph G { subgraph cluster_1 { node [style=filled,shape=box]; - check_available_queue -> remove_entries_over_10s_old; - remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; - remove_entries_over_10s_old -> exit [label="num_avail > 2"]; - - set_available -> delay_2s; - delay_2s -> check_place_in_queue; - - check_place_in_queue -> "http:transport-launch" [label="at head"]; - check_place_in_queue -> exit [label="not at head"]; - - "client:login" -> "server:shutdown" [label="login failed"]; - "server:shutdown" -> exit; - - subgraph cluster_2 { - "http:transport-launch" -> "http:transport-run"; - "http:transport-launch" -> "http:transport-keep-running"; - - "http:transport-keep-running" -> "tests running?"; - "tests running?" -> "client:login" [label=yes]; - "tests running?" -> "server:shutdown" [label=no]; - "client:login" -> delay_5s [label="login ok"]; - delay_5s -> "http:transport-keep-running"; - } - - // start_server -> "server_running?"; - // "server_running?" -> set_available [label="no"]; - // "server_running?" -> delay_2s [label="yes"]; - // delay_2s -> "still_running?"; - // "still_running?" -> ping_server [label=yes]; - // "still_running?" -> set_available [label=no]; - // ping_server -> exit [label=alive]; - // ping_server -> remove_server_record [label=dead]; - // remove_server_record -> set_available; - // set_available -> avail_delay [label="delay 3s"]; - // avail_delay -> "first_in_queue?"; - // - // "first_in_queue?" -> set_running [label=yes]; - // set_running -> get_next_port -> handle_requests; - // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; - // "dead_entry_in_queue?" -> "server_running?" [label=no]; - // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; - // remove_dead_entries -> "server_running?"; - // - // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; - // handle_requests -> shutdown_request; - // start_shutdown -> shutdown_delay; - // shutdown_request -> shutdown_delay; - // shutdown_delay -> exit; - - label = "server:launch"; - color=brown; + rmt:send-receive -> "init-*remote* if needed" -> rmt:general-open-connection -> + rmt:send-receive-real; + + +// check_available_queue -> remove_entries_over_10s_old; +// remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; +// remove_entries_over_10s_old -> exit [label="num_avail > 2"]; +// +// set_available -> delay_2s; +// delay_2s -> check_place_in_queue; +// +// check_place_in_queue -> "http:transport-launch" [label="at head"]; +// check_place_in_queue -> exit [label="not at head"]; +// +// "client:login" -> "server:shutdown" [label="login failed"]; +// "server:shutdown" -> exit; +// +// subgraph cluster_2 { +// "http:transport-launch" -> "http:transport-run"; +// "http:transport-launch" -> "http:transport-keep-running"; +// +// "http:transport-keep-running" -> "tests running?"; +// "tests running?" -> "client:login" [label=yes]; +// "tests running?" -> "server:shutdown" [label=no]; +// "client:login" -> delay_5s [label="login ok"]; +// delay_5s -> "http:transport-keep-running"; +// } +// +// // start_server -> "server_running?"; +// // "server_running?" -> set_available [label="no"]; +// // "server_running?" -> delay_2s [label="yes"]; +// // delay_2s -> "still_running?"; +// // "still_running?" -> ping_server [label=yes]; +// // "still_running?" -> set_available [label=no]; +// // ping_server -> exit [label=alive]; +// // ping_server -> remove_server_record [label=dead]; +// // remove_server_record -> set_available; +// // set_available -> avail_delay [label="delay 3s"]; +// // avail_delay -> "first_in_queue?"; +// // +// // "first_in_queue?" -> set_running [label=yes]; +// // set_running -> get_next_port -> handle_requests; +// // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; +// // "dead_entry_in_queue?" -> "server_running?" [label=no]; +// // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; +// // remove_dead_entries -> "server_running?"; +// // +// // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; +// // handle_requests -> shutdown_request; +// // start_shutdown -> shutdown_delay; +// // shutdown_request -> shutdown_delay; +// // shutdown_delay -> exit; +// +// label = "server:launch"; +// color=brown; } // client_start_server -> start_server; // handle_requests -> read_write; // read_write -> handle_requests; Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -2289,13 +2289,16 @@ (dbfile (args:get-arg "-db")) (apath *toppath*)) (let loop () (thread-sleep! 5) ;; add control / setting for this (if am-server - (if (not *dbstruct-db*) + (if (not *dbstruct-db*) ;; skip syncing until db is setup (loop) - (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile)))))) + (begin + ;; (debug:print-info 0 *default-log-port* "syncing "apath" "dbfile" at "(current-seconds)) + ;; (db:sync-inmem->disk *dbstruct-db* apath dbfile) + (loop))))))) ;; ;; (let ((dbstruct ;; (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) ;; (cond Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -62,10 +62,11 @@ ;; http-client ;; intarweb matchable md5 message-digest + nanomsg (prefix base64 base64:) (prefix sqlite3 sqlite3:) regex s11n ;; spiffy @@ -75,11 +76,11 @@ srfi-13 srfi-18 srfi-69 stack system-information - tcp6 + ;; tcp6 typed-records uri-common z3 apimod @@ -119,10 +120,11 @@ ;; (defstruct servdat (host #f) (port #f) (uuid #f) + (rep #f) (dbfile #f) (api-url #f) (api-uri #f) (api-req #f) (status 'starting) @@ -243,15 +245,16 @@ (start-main-srv)))) ;; NB// remote is a rmt:remote struct ;; (define (rmt:general-open-connection remote apath dbname #!key (num-tries 5)) - (let ((mdbname (db:run-id->dbname #f))) + (let* ((mdbname (db:run-id->dbname #f)) + (mconn (rmt:get-conn remote apath mdbname))) (cond - ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main? + ((or (not mconn) ;; no channel open to main? + (< (rmt:conn-expires mconn)(+ (current-seconds) 2))) ;; restablish connection if less than 2 seconds on the lease (rmt:open-main-connection remote apath) - (thread-sleep! 2) (rmt:general-open-connection remote apath mdbname)) ((not (rmt:get-conn remote apath dbname)) ;; no channel open to dbname? (let* ((res (rmt:send-receive-real remote apath mdbname 'get-server `(,apath ,dbname)))) (case res ((server-started) @@ -262,14 +265,39 @@ (begin (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname) (exit 1)))) (else (if (list? res) ;; server has been registered and the info was returned. pass it on. - res + (begin ;; ("192.168.0.9" 53817 + ;; "5e34239f48e8973b3813221e54701a01" "24310" + ;; "192.168.0.9" + ;; "/home/matt/data/megatest/tests/simplerun" + ;; ".db/1.db") + (match + res + ((host port servkey pid ipaddr apath dbname) + (debug:print-info 0 *default-log-port* "got "res) + (hash-table-set! (rmt:remote-conns remote) + dbname + (make-rmt:conn + apath: apath + dbname: dbname + hostport: (conc host":"port) + ipaddr: ipaddr + port: port + srvkey: servkey + lastmsg: (current-seconds) + expires: (+ (current-seconds) 60)))) + (else + (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res))) + res) (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) - res))))))))) + res)))))) + + + ))) ;;====================================================================== ;; Defaults to current area @@ -293,31 +321,19 @@ ;; sometime in the future ;; (define (rmt:send-receive-real remote apath dbname cmd params) (let* ((conn (rmt:get-conn remote apath dbname))) (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened") - (pp (rmt:conn->alist conn)) - ;; (rmt:send-receive-setup conn) - (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) - (rmt:conn-port conn)))) - (let* ((key #f) - (payload `((cmd . ,cmd) - (key . ,(rmt:conn-srvkey conn)) - (params . ,params))) - (res (begin - (write payload o) ;; (rmt:conn-outport conn)) - (with-input-from-port - i ;; (rmt:conn-inport conn) - read)))) - (close-input-port i) - (close-output-port o) - res)))) -;; (if (string? res) -;; (string->sexpr res) -;; res)))) - - + (let* ((key #f) + (host (rmt:conn-ipaddr conn)) + (port (rmt:conn-port conn)) + (payload `((cmd . ,cmd) + (key . ,(rmt:conn-srvkey conn)) + (params . ,params))) + (res (open-send-receive-nn (conc host":"port) + (sexpr->string payload)))) + (string->sexpr res)))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future. ;; ;; Purpose - call the main.db server and request a server be started @@ -332,11 +348,11 @@ ;; read-string))) ;; (string->sexpr res)))) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" - (debug:print 18 *default-log-port* "DB Stats\n========") + (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================") (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) @@ -1443,10 +1459,48 @@ (common:version-signature)))) (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) + +(define (rmt:server-shutdown) + (let ((dbfile (servdat-dbfile *server-info*))) + (debug:print-info 0 *default-log-port* "dbfile is "dbfile) + (if dbfile + (let* ((am-server (args:get-arg "-server")) + (dbfile (args:get-arg "-db")) + (apath *toppath*)) + ;; do a final sync here + (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) + (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) + (if am-server + (if (string-match ".*/main.db$" dbfile) + (let ((pkt-file (conc (get-pkts-dir *toppath*) + "/" (servdat-uuid *server-info*) + ".pkt"))) + (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) + (delete-file* pkt-file) + (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) + (db:with-lock-db (servdat-dbfile *server-info*) + (lambda (dbh dbfile) + (db:release-lock dbh dbfile)))) + (let* ((sdat *server-info*) ;; we have a run-id server + (host (servdat-host sdat)) + (port (servdat-port sdat)) + (uuid (servdat-uuid sdat))) + (if (not (string-match ".db/main.db" (args:get-arg "-db"))) + (let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*? + *toppath* + (servdat-host *server-info*) ;; iface + (servdat-port *server-info*) + (servdat-uuid *server-info*) + (current-process-id) + ))) + (debug:print-info 0 *default-log-port* "deregistered-server, res="res))) + + (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid) + ))))))) (define (std-exit-procedure) ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) @@ -1456,56 +1510,38 @@ (bdat-time-to-exit-set! *bdat* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) - (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (if *server-info* - (let ((pkt-file (conc (get-pkts-dir *toppath*) - "/" (servdat-uuid *server-info*) - ".pkt")) - (dbfile (servdat-dbfile *server-info*))) - (if dbfile - (begin - - ;; do a final sync here - - (if (string-match ".*/main.db$" dbfile) - (begin - (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) - (delete-file* pkt-file) - (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) - (db:with-lock-db (servdat-dbfile *server-info*) - (lambda (dbh dbfile) - (db:release-lock dbh dbfile)))) - (let* ((sdat *server-info*)) ;; we have a run-id server - (rmt:send-receive-real *rmt:remote* *toppath* - (db:run-id->dbname #f) - 'deregister-server - `(,(servdat-uuid sdat) - ,(current-process-id) - ,(servdat-host sdat) ;; iface - ,(servdat-port sdat))))))))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated - (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db - (let ((db (cdr (bdat-task-db *bdat*)))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t) - (bdat-task-db-set! *bdat* #f))))) - #;(http-client#close-idle-connections!) - (if (not (eq? *default-log-port* (current-error-port))) - (close-output-port *default-log-port*)) - (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) + (let ((th1 (make-thread + (lambda () ;; thread for cleaning up, give it five seconds + (let* ((start-time (current-seconds))) + (if (and *server-info* + *unclean-shutdown*) + (rmt:server-shutdown)) + (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds")) + ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated + #;(if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db + (let ((db (cdr (bdat-task-db *bdat*)))) + (if (sqlite3:database? db) + (begin + (debug:print-info 0 *default-log-port* "Closing down task db "db) + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (bdat-task-db-set! *bdat* #f))))) + #;(http-client#close-idle-connections!) + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) + (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () - (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") + (debug:print 4 *default-log-port* "Attempting clean exit. Mode="(if no-hurry "no-hurry" "normal") + " Please be patient and wait a few seconds...") (if no-hurry (begin (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff (begin - (thread-sleep! 2))) + (thread-sleep! 2))) (debug:print 4 *default-log-port* " ... done") ) "clean exit"))) (thread-start! th1) (thread-start! th2) @@ -1539,38 +1575,13 @@ ;;====================================================================== ;; S E R V E R ;; ====================================================================== -;; NOTE: http-transport:launch is the entry point -;; -> http-transport:run -;; -> http-transport:try-start-server -> http-transport:try-start-server (until success) - (define (http-get-function fnkey) (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet"))) -#;(define (rmt:launch-server hostn port) - (if *server-info* - (begin - (servdat-host-set! *server-info* hostn) - (servdat-port-set! *server-info* port) - (servdat-status-set! *server-info* 'trying-port) - (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) - (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) - (let* ((l (tcp-listen port)) - (dbstruct #f)) - (let-values (((i o) (tcp-accept l))) - ;; (write-line "Hello!" o) - (let loop ((indat (read i))) - (let* ((res (api:process-request dbstruct indat))) - (case res - ((quit) - (close-input-port i) - (close-output-port o)) - (else - (write res o)))))))) - (define (rmt:run hostn) ;; ;; Configurations for server ;; (tcp-buffer-size 2048) ;; (max-connections 2048) (debug:print 2 *default-log-port* "Attempting to start the server ...") @@ -1591,63 +1602,77 @@ (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* port) (servdat-status-set! *server-info* 'trying-port) (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: port))) - (let* ((l (rmt:try-start-server ipaddrstr port))) - (let oloop () - (let-values (((i o) (tcp-accept l))) - ;; (write-line "Hello!" o) - (let loop ((indat (read i))) - (if (eof-object? indat) - (begin - (close-input-port i) - (close-output-port o) - (oloop)) - (let* ((res (api:process-request *dbstruct-db* indat))) - (set! *db-last-access* (current-seconds)) - (write res o) - (loop (read i)))))))) + (let* ((rep (rmt:try-start-server ipaddrstr port))) + (let loop ((instr (nn-recv rep))) + (let* ((data (string->sexpr instr)) + (res (case data + ((quit) 'quit) + (else (api:process-request *dbstruct-db* data)))) + (resdat (sexpr->string res))) + (if (not (eq? res 'quit)) + (begin + (set! *db-last-access* (current-seconds)) + (nn-send rep resdat) + (loop (nn-recv rep))))))) + ;; server exit stuff here (let* ((portnum (servdat-port *server-info*))) (portlogger:open-run-close portlogger:set-port portnum "released") (debug:print 1 *default-log-port* "INFO: server has been stopped")))) (define (rmt:try-start-server ipaddrstr portnum) - (if *server-info* + (if *server-info* ;; update the server info as we might be trying next port (begin (servdat-host-set! *server-info* ipaddrstr) (servdat-port-set! *server-info* portnum) (servdat-status-set! *server-info* 'trying-port) - (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) + (servdat-trynum-set! *server-info* + (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) (debug:print-info 0 *default-log-port* "rmt:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum) - (handle-exceptions - exn - (begin - (print-error-message exn) - (if (< portnum 64000) - (begin - (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (portlogger:open-run-close portlogger:set-failed portnum) - (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") - ;; (thread-sleep! 0.1) - (rmt:try-start-server ipaddrstr - (portlogger:open-run-close portlogger:find-port))) - (begin - (print "ERROR: Tried and tried but could not start the server")))) - ;; any error in following steps will result in a retry - (if *server-info* - (servdat-status-set! *server-info* 'starting) - (set! *server-info* (make-servdat host: ipaddrstr port: portnum))) - - (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) - (tcp-listen portnum))) + (if (is-port-in-use portnum) + (begin + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") + ;; (thread-sleep! 0.1) + (rmt:try-start-server ipaddrstr + (portlogger:open-run-close + portlogger:find-port))) + (begin + (if (not *server-info*) + (set! *server-info* (make-servdat + host: ipaddrstr + port: portnum))) + (servdat-status-set! *server-info* 'starting) + (servdat-port-set! *server-info* portnum) + (if (not (servdat-rep *server-info*)) + (servdat-rep-set! *server-info* (nn-socket 'rep))) + (let* ((rep (servdat-rep *server-info*))) + (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) + (handle-exceptions + exn + (begin + (print-error-message exn) + (if (< portnum 64000) + (begin + (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") + ;; (thread-sleep! 0.1) + (rmt:try-start-server ipaddrstr + (portlogger:open-run-close portlogger:find-port))) + (begin + (print "ERROR: Tried and tried but could not start the server, stopping at port "portnum)))) + (nn-bind rep (conc "tcp://*:" portnum)) + rep))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -1796,31 +1821,33 @@ (define (server-address srv-pkt) (conc (alist-ref 'host srv-pkt) ":" (alist-ref 'port srv-pkt))) (define (server-ready? host port key) ;; server-address is host:port - (let-values (((i o)(handle-exceptions - exn - (values #f #f) - (tcp-connect host port)))) - (if (and i o) - (begin - (write `((cmd . ping) - (key . ,key) - (params . ())) o) - (let ((res (with-input-from-port i - read))) - (close-output-port o) - (close-input-port i) - res)) +;; (let-values (((i o)(handle-exceptions +;; exn +;; (values #f #f) +;; (tcp-connect host port)))) +;; (if (and i o) + (let* ((data (sexpr->string `((cmd . ping) + (key . ,key) + (params . ())))) + (res (open-send-receive-nn (conc host ":" port) data))) + (string->sexpr res))) + +;; (let ((res (with-input-from-port i +;; read))) +;; (close-output-port o) +;; (close-input-port i) +;; res)) ;; (if (string? res) ;; (string->sexpr res) ;; res))) - (begin ;; connection failed - (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.") - #f)))) - +;; (begin ;; connection failed +;; (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.") +;; #f)))) + ;; (define (loop-test host port data) ;; server-address is host:port ;; ;; ping the server and ask it ;; ;; if it ready ;; ;; (let* ((sdat (servdat-init #f host port #f))) ;; ;; (http-transport:send-receive sdat "abc" 'ping '()))) @@ -1970,18 +1997,31 @@ (equal? sdat last-sdat) sdat)))))))) (define (rmt:register-server remote apath iface port server-key dbname) (rmt:open-main-connection remote apath) ;; we need a channel to main.db - (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath - (db:run-id->dbname #f) 'register-server `(,iface - ,port - ,server-key - ,(current-process-id) - ,iface - ,apath - ,dbname))) + (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath + (db:run-id->dbname #f) + 'register-server `(,iface + ,port + ,server-key + ,(current-process-id) + ,iface + ,apath + ,dbname))) + +(define (rmt:deregister-server remote apath iface port server-key dbname) + (rmt:open-main-connection remote apath) ;; we need a channel to main.db + (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath + (db:run-id->dbname #f) + 'deregister-server `(,iface + ,port + ,server-key + ,(current-process-id) + ,iface + ,apath + ,dbname))) (define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100)) ;; wait until *server-info* stops changing (let* ((stime (current-seconds))) (let loop ((last-host #f) @@ -2040,15 +2080,16 @@ (http-transport:wait-for-server pkts-dir dbname server-key) (http-transport:wait-for-stable-interface)) ;; this is our forever loop (let* ((iface (servdat-host *server-info*)) (port (servdat-port *server-info*))) - (let loop ((count 0) + (let loop ((count 0) (bad-sync-count 0) (start-time (current-milliseconds))) - (if (not is-main) + (if (and (not is-main) + (common:low-noise-print 60 "servdat-status")) (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*))) ;; set up the database handle (mutex-lock! *heartbeat-mutex*) (if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate @@ -2068,20 +2109,28 @@ (exit))))) (debug:print 0 *default-log-port* "SERVER: running, db "dbname" opened, megatest version: " (common:get-full-version)) ;; start the watchdog - (if watchdog + + ;; is this really needed? + + #;(if watchdog (if (not (member (thread-state watchdog) '(ready running blocked sleeping dead))) (begin (debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")") (thread-start! watchdog)) (debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")")) (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it.")) - #;(loop (+ count 1) bad-sync-count start-time))) + #;(loop (+ count 1) bad-sync-count start-time) + )) + + (debug:print-info 0 *default-log-port* "syncing "*toppath*" "dbname" at "(current-seconds)) + (db:sync-inmem->disk *dbstruct-db* *toppath* dbname) + (mutex-unlock! *heartbeat-mutex*) ;; 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. @@ -2109,10 +2158,19 @@ (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))) (loop 0 bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) + + + + + ;; send self 'quit here + + + + (http-transport:server-shutdown port)))))))) (define (http-transport:server-shutdown port) (begin ;;(BB> "http-transport:server-shutdown called") @@ -2120,14 +2178,15 @@ ;; ;; start_shutdown ;; ;; deregister the server - + (rmt:server-shutdown) + (set! *unclean-shutdown* #f) (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up - (portlogger:open-run-close portlogger:set-port port "released") + ;; (portlogger:open-run-close portlogger:set-port port "released") ;; done in rmt:run (thread-sleep! 1) ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*) ;; (debug:print-info 0 *default-log-port* "Average cached write time " @@ -2143,11 +2202,11 @@ ;; (/ *total-non-write-delay* ;; *number-non-write-queries*)) ;; " ms") (db:print-current-query-stats) - (common:save-pkt `((action . exit) + #;(common:save-pkt `((action . exit) (T . server) (pid . ,(current-process-id))) *configdat* #t) (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (exit))) @@ -2192,10 +2251,110 @@ (define (rmt:get-signature) (if *my-signature* *my-signature* (let ((sig (rmt:mk-signature))) (set! *my-signature* sig) *my-signature*))) + +;;====================================================================== +;; Nanomsg transport +;;====================================================================== + +(define (is-port-in-use port-num) + (let* ((ret #f)) + (let-values (((inp oup pid) + (process "netstat" (list "-tulpn" )))) + (let loop ((inl (read-line inp))) + (if (not (eof-object? inl)) + (begin + (if (string-search (regexp (conc ":" port-num)) inl) + (begin + ;(print "Output: " inl) + (set! ret #t)) + (loop (read-line inp))))))) + ret)) + +;;start a server, returns the connection +;; +(define (start-nn-server portnum ) + (let ((rep (nn-socket 'rep))) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + (print "ERROR: Failed to start server \"" emsg "\"") + (exit 1)) + + (nn-bind rep (conc "tcp://*:" portnum))) + rep)) + +;; open connection to server, send message, close connection +;; +(define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f) + ;; (contacts (alist-ref 'contact attrib)) + ;; (mode (alist-ref 'mode attrib)) + ) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) + #f) + (nn-connect req uri) + ;; (print "Connected to the server " ) + (nn-send req msg) + ;; (print "Request Sent") + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (set! res (if (equal? resp "ok") + #t + #f)))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) + +(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f) + ;; (contacts (alist-ref 'contact attrib)) + ;; (mode (alist-ref 'mode attrib)) + ) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) + #f) + (nn-connect req uri) + ;; (print "Connected to the server " ) + (nn-send req msg) + ;; (print "Request Sent") + ;; receive code here + ;;(print (nn-recv req)) + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (print resp) + (set! res resp))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -34,11 +34,11 @@ ;; sexpr->string ;; server-ready? ;; rmt:register-server ;; rmt:open-main-connection ;; rmt:general-open-connection - ;; rmt:get-conny + ;; rmt:get-conn ;; common:watchdog ;; rmt:find-main-server ;; get-all-server-pkts ;; get-viable-servers ;; get-best-candidate @@ -54,22 +54,28 @@ (define dbname ".db/2.db") (define remote *rmt:remote*) (define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) (test #f #t (rmt:open-main-connection remote apath)) +(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))) (test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))) (test #f 'server-started (rmt:send-receive-real *rmt:remote* *toppath* ".db/main.db" 'get-server `(,apath ,dbname))) (thread-sleep! 2) (test #f #t (list? (rmt:general-open-connection *rmt:remote* *toppath* ".db/2.db"))) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) (test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f))) (print "Got here.") -(test #t 1 (rmt:send-receive 'register-run 1 (list keyvals "run2" "new" "n/a" "justme" #f))) + +(test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f))) + +;; (test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) -(test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) +(thread-sleep! 5) +(exit) + ;; (delete-file* "logs/1.log") ;; (define run-id 1) ;; (test "setup for run" #t (begin (launch:setup) @@ -327,195 +333,196 @@ ;; ;; (exit) -;; all old stuff below - - - - -(delete-file* "logs/1.log") -(define run-id 1) - -(test "setup for run" #t (begin (launch:setup-for-run) - (string? (getenv "MT_RUN_AREA_HOME")))) - -;; Insert data into db -;; -(define user (current-user-name)) -(define runname "mytestrun") -(define keys (rmt:get-keys)) -(define runinfo #f) -(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) -(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) - -(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) -;; (test #f #f (rmt:get-runs-by-patt keys runname)) -(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) -(define test-one-id #f) -(test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) - (set! test-one-id test-id) - test-id)) -(define test-one-rec #f) -(test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) - (set! test-one-rec test-rec) - (vector-ref test-rec 2))) - -(use trace) -(import trace) -;; (trace -;; rmt:send-receive -;; rmt:open-qry-close-locally -;; ) - -;; Tests to assess reading/writing while servers are starting/stopping -(define start-time (current-seconds)) -(let loop ((test-state 'start)) - (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id)) - (first-dat (if (not (null? server-dats)) - (car server-dats) - #f)) - (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat))) - (if first-dat - (map (lambda (dat) - (apply print (intersperse (vector->list dat) ", "))) - server-dats) - (print "No server")) - (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id)) - (thread-sleep! 1) - (case test-state - ((start) - (print "Trying to start server") - (server:kind-run run-id) - (loop 'server-started)) - ((server-started) - (case server-state - ((running) - (print "Server appears to be running. Now ask it to shutdown") - (rmt:kill-server run-id) - ;; (trace rmt:open-qry-close-locally rmt:send-receive) - (loop 'shutdown-started)) - ((available) - (loop test-state)) - ((shutting-down) - (loop test-state)) - ((no-dat) - (loop test-state)) - (else (print "Don't know what to do if get here")))) - ((shutdown-started) - (case server-state - ((no-dat) - (print "Server appears to have shutdown, ending this test")) - (else - (loop test-state))))))) - -(exit) - -;; (set! *transport-type* 'http) -;; -;; (test "setup for run" #t (begin (setup-for-run) -;; (string? (getenv "MT_RUN_AREA_HOME")))) -;; -;; (test "server-register, get-best-server" #t (let ((res #f)) -;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) -;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) -;; (number? (vector-ref res 3)))) -;; -;; (test "de-register server" #f (let ((res #f)) -;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) -;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) -;; -;; (define server-pid #f) -;; -;; ;; Not sure how the following should work, replacing it with system of megatest -server -;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () -;; ;; ;; (daemon:ize) -;; ;; (server:launch 'http))))) -;; ;; (set! server-pid pid) -;; ;; (number? pid))) -;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") -;; -;; (let loop ((n 10)) -;; (thread-sleep! 1) ;; need to wait for server to start. -;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) -;; (print "tasks:get-best-server returned " res) -;; (if (and (not res) -;; (> n 0)) -;; (loop (- n 1))))) -;; -;; (test "get-best-server" #t (begin -;; (client:launch) -;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) -;; (vector? dat)))) -;; -;; (define *keys* (keys:config-get-fields *configdat*)) -;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) -;; -;; (test #f #t (string? (car *runremote*))) -;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -;; -;; (test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test -;; -;; ;; RUNS -;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) -;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) -;; (vector-ref (vector-ref rinfo 1) 3))) -;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) -;; -;; ;; TESTS -;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -;; (test "register test" #t (rmt:general-call 'register-test 1 1 "test1" "")) -;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) -;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) -;; -;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) -;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) -;; -;; (test "get keys" #t (list? (rmt:get-keys))) -;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t)) -;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1))) -;; (db:test-get-comment trec))) -;; -;; ;; MORE RUNS -;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) -;; (header (vector-ref runs 0)) -;; (data (vector-ref runs 1))) -;; (and (list? header) -;; (list? data) -;; (vector? (car data))))) -;; -;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2)) -;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) -;; -;; ;;====================================================================== -;; ;; D B -;; ;;====================================================================== -;; -;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) -;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) -;; (+ (db:test-get-pass_count dat) -;; (db:test-get-fail_count dat)))) -;; -;; (define testregistry (make-hash-table)) -;; (for-each -;; (lambda (tname) -;; (for-each -;; (lambda (itempath) -;; (let ((tkey (conc tname "/" itempath)) -;; (rpass (random 10)) -;; (rfail (random 10))) -;; (hash-table-set! testregistry tkey (list tname itempath)) -;; (rmt:general-call 'register-test 1 tname itempath) -;; (let* ((tid (rmt:get-test-id 1 tname itempath)) -;; (tdat (rmt:get-test-info-by-id tid))) -;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) -;; (let* ((resdat (rmt:get-test-info-by-id tid))) -;; (test "set/get pass fail counts" (list rpass rfail) -;; (list (db:test-get-pass_count resdat) -;; (db:test-get-fail_count resdat))))))) -;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) -;; (list "test1" "test2" "test3" "test4" "test5")) -;; -;; -;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) -;; +;; ;; ;; ;; all old stuff below +;; ;; ;; +;; ;; ;; +;; ;; ;; +;; ;; ;; +;; ;; ;; (delete-file* "logs/1.log") +;; ;; ;; (define run-id 1) +;; ;; ;; +;; ;; ;; (test "setup for run" #t (begin (launch:setup-for-run) +;; ;; ;; (string? (getenv "MT_RUN_AREA_HOME")))) +;; ;; ;; +;; ;; ;; ;; Insert data into db +;; ;; ;; ;; +;; ;; ;; (define user (current-user-name)) +;; ;; ;; (define runname "mytestrun") +;; ;; ;; (define keys (rmt:get-keys)) +;; ;; ;; (define runinfo #f) +;; ;; ;; (define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +;; ;; ;; (define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) +;; ;; ;; +;; ;; ;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +;; ;; ;; ;; (test #f #f (rmt:get-runs-by-patt keys runname)) +;; ;; ;; (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) +;; ;; ;; (define test-one-id #f) +;; ;; ;; (test #f 30001 (let ((test-id (rmt:get-test-id run-id "test-one" ""))) +;; ;; ;; (set! test-one-id test-id) +;; ;; ;; test-id)) +;; ;; ;; (define test-one-rec #f) +;; ;; ;; (test #f "test-one" (let ((test-rec (rmt:get-test-info-by-id run-id test-one-id))) +;; ;; ;; (set! test-one-rec test-rec) +;; ;; ;; (vector-ref test-rec 2))) +;; ;; ;; +;; ;; ;; (use trace) +;; ;; ;; (import trace) +;; ;; ;; ;; (trace +;; ;; ;; ;; rmt:send-receive +;; ;; ;; ;; rmt:open-qry-close-locally +;; ;; ;; ;; ) +;; ;; ;; +;; ;; ;; ;; Tests to assess reading/writing while servers are starting/stopping +;; ;; ;; (define start-time (current-seconds)) +;; ;; ;; (let loop ((test-state 'start)) +;; ;; ;; (let* ((server-dats (tasks:get-server-records (db:delay-if-busy (tasks:open-db)) run-id)) +;; ;; ;; (first-dat (if (not (null? server-dats)) +;; ;; ;; (car server-dats) +;; ;; ;; #f)) +;; ;; ;; (server-state (or (and first-dat (string->symbol (vector-ref first-dat 8))) 'no-dat))) +;; ;; ;; (if first-dat +;; ;; ;; (map (lambda (dat) +;; ;; ;; (apply print (intersperse (vector->list dat) ", "))) +;; ;; ;; server-dats) +;; ;; ;; (print "No server")) +;; ;; ;; (test #f test-one-rec (rmt:get-test-info-by-id run-id test-one-id)) +;; ;; ;; (thread-sleep! 1) +;; ;; ;; (case test-state +;; ;; ;; ((start) +;; ;; ;; (print "Trying to start server") +;; ;; ;; (server:kind-run run-id) +;; ;; ;; (loop 'server-started)) +;; ;; ;; ((server-started) +;; ;; ;; (case server-state +;; ;; ;; ((running) +;; ;; ;; (print "Server appears to be running. Now ask it to shutdown") +;; ;; ;; (rmt:kill-server run-id) +;; ;; ;; ;; (trace rmt:open-qry-close-locally rmt:send-receive) +;; ;; ;; (loop 'shutdown-started)) +;; ;; ;; ((available) +;; ;; ;; (loop test-state)) +;; ;; ;; ((shutting-down) +;; ;; ;; (loop test-state)) +;; ;; ;; ((no-dat) +;; ;; ;; (loop test-state)) +;; ;; ;; (else (print "Don't know what to do if get here")))) +;; ;; ;; ((shutdown-started) +;; ;; ;; (case server-state +;; ;; ;; ((no-dat) +;; ;; ;; (print "Server appears to have shutdown, ending this test")) +;; ;; ;; (else +;; ;; ;; (loop test-state))))))) +;; ;; ;; +;; ;; ;; (exit) +;; ;; ;; +;; ;; ;; ;; (set! *transport-type* 'http) +;; ;; ;; ;; +;; ;; ;; ;; (test "setup for run" #t (begin (setup-for-run) +;; ;; ;; ;; (string? (getenv "MT_RUN_AREA_HOME")))) +;; ;; ;; ;; +;; ;; ;; ;; (test "server-register, get-best-server" #t (let ((res #f)) +;; ;; ;; ;; (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) +;; ;; ;; ;; (set! res (open-run-close tasks:get-best-server tasks:open-db)) +;; ;; ;; ;; (number? (vector-ref res 3)))) +;; ;; ;; ;; +;; ;; ;; ;; (test "de-register server" #f (let ((res #f)) +;; ;; ;; ;; (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) +;; ;; ;; ;; (vector? (open-run-close tasks:get-best-server tasks:open-db)))) +;; ;; ;; ;; +;; ;; ;; ;; (define server-pid #f) +;; ;; ;; ;; +;; ;; ;; ;; ;; Not sure how the following should work, replacing it with system of megatest -server +;; ;; ;; ;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; ;; ;; ;; ;; (daemon:ize) +;; ;; ;; ;; ;; (server:launch 'http))))) +;; ;; ;; ;; ;; (set! server-pid pid) +;; ;; ;; ;; ;; (number? pid))) +;; ;; ;; ;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; ;; ;; ;; +;; ;; ;; ;; (let loop ((n 10)) +;; ;; ;; ;; (thread-sleep! 1) ;; need to wait for server to start. +;; ;; ;; ;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) +;; ;; ;; ;; (print "tasks:get-best-server returned " res) +;; ;; ;; ;; (if (and (not res) +;; ;; ;; ;; (> n 0)) +;; ;; ;; ;; (loop (- n 1))))) +;; ;; ;; ;; +;; ;; ;; ;; (test "get-best-server" #t (begin +;; ;; ;; ;; (client:launch) +;; ;; ;; ;; (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) +;; ;; ;; ;; (vector? dat)))) +;; ;; ;; ;; +;; ;; ;; ;; (define *keys* (keys:config-get-fields *configdat*)) +;; ;; ;; ;; (define *keyvals* (keys:target->keyval *keys* "a/b/c")) +;; ;; ;; ;; +;; ;; ;; ;; (test #f #t (string? (car *runremote*))) +;; ;; ;; ;; (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) +;; ;; ;; ;; +;; ;; ;; ;; (test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test +;; ;; ;; ;; +;; ;; ;; ;; ;; RUNS +;; ;; ;; ;; (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +;; ;; ;; ;; (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) +;; ;; ;; ;; (vector-ref (vector-ref rinfo 1) 3))) +;; ;; ;; ;; (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) +;; ;; ;; ;; +;; ;; ;; ;; ;; TESTS +;; ;; ;; ;; (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +;; ;; ;; ;; (test "register test" #t (rmt:general-call 'register-test 1 1 "test1" "")) +;; ;; ;; ;; (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +;; ;; ;; ;; (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +;; ;; ;; ;; +;; ;; ;; ;; (test "sync back" #t (> (rmt:sync-inmem->db) 0)) +;; ;; ;; ;; (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +;; ;; ;; ;; +;; ;; ;; ;; (test "get keys" #t (list? (rmt:get-keys))) +;; ;; ;; ;; (test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t)) +;; ;; ;; ;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1))) +;; ;; ;; ;; (db:test-get-comment trec))) +;; ;; ;; ;; +;; ;; ;; ;; ;; MORE RUNS +;; ;; ;; ;; (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) +;; ;; ;; ;; (header (vector-ref runs 0)) +;; ;; ;; ;; (data (vector-ref runs 1))) +;; ;; ;; ;; (and (list? header) +;; ;; ;; ;; (list? data) +;; ;; ;; ;; (vector? (car data))))) +;; ;; ;; ;; +;; ;; ;; ;; (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2)) +;; ;; ;; ;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) +;; ;; ;; ;; +;; ;; ;; ;; ;;====================================================================== +;; ;; ;; ;; ;; D B +;; ;; ;; ;; ;;====================================================================== +;; ;; ;; ;; +;; ;; ;; ;; (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +;; ;; ;; ;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) +;; ;; ;; ;; (+ (db:test-get-pass_count dat) +;; ;; ;; ;; (db:test-get-fail_count dat)))) +;; ;; ;; ;; +;; ;; ;; ;; (define testregistry (make-hash-table)) +;; ;; ;; ;; (for-each +;; ;; ;; ;; (lambda (tname) +;; ;; ;; ;; (for-each +;; ;; ;; ;; (lambda (itempath) +;; ;; ;; ;; (let ((tkey (conc tname "/" itempath)) +;; ;; ;; ;; (rpass (random 10)) +;; ;; ;; ;; (rfail (random 10))) +;; ;; ;; ;; (hash-table-set! testregistry tkey (list tname itempath)) +;; ;; ;; ;; (rmt:general-call 'register-test 1 tname itempath) +;; ;; ;; ;; (let* ((tid (rmt:get-test-id 1 tname itempath)) +;; ;; ;; ;; (tdat (rmt:get-test-info-by-id tid))) +;; ;; ;; ;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) +;; ;; ;; ;; (let* ((resdat (rmt:get-test-info-by-id tid))) +;; ;; ;; ;; (test "set/get pass fail counts" (list rpass rfail) +;; ;; ;; ;; (list (db:test-get-pass_count resdat) +;; ;; ;; ;; (db:test-get-fail_count resdat))))))) +;; ;; ;; ;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) +;; ;; ;; ;; (list "test1" "test2" "test3" "test4" "test5")) +;; ;; ;; ;; +;; ;; ;; ;; +;; ;; ;; ;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) +;; ;; ;; ;; +;; ;; ;;