Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -33,12 +33,12 @@ configfmod.scm commonmod.scm dbmod.scm rmtmod.scm \ debugprint.scm mtver.scm csv-xml.scm servermod.scm \ hostinfo.scm adjutant.scm processmod.scm testsmod.scm \ itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \ tasksmod.scm pgdb.scm launchmod.scm runsmod.scm \ - portloggermod.scm clientmod.scm archivemod.scm \ - ezstepsmod.scm subrunmod.scm bigmod.scm testsmod.scm + portloggermod.scm archivemod.scm ezstepsmod.scm \ + subrunmod.scm bigmod.scm testsmod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ vg.scm @@ -63,11 +63,11 @@ mofiles/archivemod.o : mofiles/launchmod.o mofiles/archivemod.o : mofiles/servermod.o mofiles/bigmod.o : mofiles/configfmod.o mofiles/bigmod.o : mofiles/dbmod.o mofiles/bigmod.o : mofiles/rmtmod.o -mofiles/clientmod.o : mofiles/servermod.o +# mofiles/clientmod.o : mofiles/servermod.o mofiles/commonmod.o : mofiles/configfmod.o mofiles/commonmod.o : mofiles/debugprint.o mofiles/commonmod.o : mofiles/hostinfo.o mofiles/commonmod.o : mofiles/itemsmod.o mofiles/commonmod.o : mofiles/keysmod.o @@ -88,11 +88,11 @@ mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o mofiles/mtmod.o : mofiles/debugprint.o mofiles/portloggermod.o : mofiles/tasksmod.o mofiles/rmtmod.o : mofiles/apimod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/portloggermod.o -mofiles/rmtmod.o : mofiles/itemsmod.o mofiles/clientmod.o +mofiles/rmtmod.o : mofiles/itemsmod.o # mofiles/clientmod.o mofiles/runsmod.o : mofiles/rmtmod.o mofiles/archivemod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/stml2.o : mofiles/cookie.o mofiles/dbi.o mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o mofiles/testsmod.o : mofiles/commonmod.o @@ -135,11 +135,10 @@ TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ - client.o \ common.o \ configf.o \ db.o \ env.o \ http-transport.o \ @@ -410,12 +409,12 @@ fi if csi -ne '(import postgresql)';then \ echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o +portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o buildmanual: cd docs/manual && make targets: Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -49,10 +49,11 @@ tasksmod servermod matchable ) + ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-var @@ -403,29 +404,33 @@ ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; -(define (api:process-request dbstruct $) ;; the $ is the request vars proc - (debug:print 0 *default-log-port* "server-id:" *server-id*) - (let* ((cmd-in ($ 'cmd)) - (cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in)) - (params (string->sexpr ($ 'params))) - (key ($ 'key)) ;; TODO - add this back - ) - (debug:print 0 *default-log-port* "cmd:" cmd " with params " params "key " key) - (if (equal? key "nokey") ;; *server-id*) ;; TODO - get real key involved - (begin - (set! *api-process-request-count* (+ *api-process-request-count* 1)) - (let* ((res (api:execute-requests dbstruct cmd params))) - (debug:print 0 *default-log-port* "res:" res) - #;(if (not success) - (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) - (if (> *api-process-request-count* *max-api-process-requests*) - (set! *max-api-process-requests* *api-process-request-count*)) - (set! *api-process-request-count* (- *api-process-request-count* 1)) - (sexpr->string res))) - (begin - (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) - (sexpr->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*)))))) +(define (api:process-request dbstruct indat) ;; the $ is the request vars proc + (let* ((cmd-in (alist-ref 'cmd indat)) ;; ($ 'cmd)) + (cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in)) + (params (alist-ref 'params indat)) + (key (alist-ref 'key indat)) ;; TODO - add this back + ) + (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key) + (case cmd-in + ((ping) #t) + ;; ((quit) (exit)) + (else + (if (equal? key *my-signature*) ;; TODO - get real key involved + (begin + (set! *api-process-request-count* (+ *api-process-request-count* 1)) + (let* ((res (api:execute-requests dbstruct cmd params))) + (debug:print 0 *default-log-port* "res:" res) + #;(if (not success) + (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) + (if (> *api-process-request-count* *max-api-process-requests*) + (set! *max-api-process-requests* *api-process-request-count*)) + (set! *api-process-request-count* (- *api-process-request-count* 1)) + #;(sexpr->string res) + res)) + (begin + (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *my-signature* ".\nOther arguments recived: cmd=" cmd " params = " params) + (conc "Server refused to process request server signature mismatch: " key ", " *my-signature*))))))) ) Index: clientmod.scm ================================================================== --- clientmod.scm +++ clientmod.scm @@ -73,11 +73,11 @@ ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; client:get-signature -(define (client:get-signature) +#;(define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -209,17 +209,17 @@ (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; no sync db (define *no-sync-db* #f) ;; SERVER -(define *my-client-signature* #f) +(define *my-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg ;; replaced by *rmt:remote* ;; (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-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global ;; (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) @@ -3780,9 +3780,13 @@ (handle-exceptions exn (begin (debug:print 0 *default-log-port* "ERROR: string->sexpr bad input \""instr"\"") #f) - (with-input-from-string instr - (lambda ()(read))))) + (if (string? instr) + (with-input-from-string instr + read) + (begin + (debug:print-info 0 *default-log-port* "Odd, instr is not a string: "instr) + instr)))) ) Index: fullrununit.sh ================================================================== --- fullrununit.sh +++ fullrununit.sh @@ -1,6 +1,9 @@ #!/bin/bash -(killall mtest -v;sleep 1;killall mtest -v -9;rm -f tests/simplerun/.db/* tests/simplerun/logs/* tests/basicserver.log) & -ck5 make -j install && -wait && -ck5 make unit +for x in basicserver server;do + (killall mtest -v;sleep 1;killall mtest -v -9;rm -f tests/simplerun/.db/* tests/simplerun/logs/* tests/$x.log) & + ck5 make -j install && + wait && + script -c "cd tests;ck5 make $x.log" full-$x.log +done + Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -19,11 +19,10 @@ ;;====================================================================== (declare (unit rmtmod)) (declare (uses apimod)) -(declare (uses clientmod)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses dbmod)) (declare (uses debugprint)) (declare (uses itemsmod)) @@ -51,40 +50,41 @@ chicken.process chicken.process-context chicken.process-context.posix chicken.sort chicken.string - chicken.tcp chicken.random + ;; chicken.tcp + chicken.random chicken.time chicken.time.posix (prefix sqlite3 sqlite3:) directory-utils - http-client - intarweb + ;; http-client + ;; intarweb matchable md5 message-digest (prefix base64 base64:) (prefix sqlite3 sqlite3:) regex s11n - spiffy - spiffy-directory-listing - spiffy-request-vars + ;; spiffy + ;; spiffy-directory-listing + ;; spiffy-request-vars srfi-1 srfi-13 srfi-18 srfi-69 stack system-information + tcp6 typed-records uri-common z3 apimod - clientmod commonmod configfmod dbmod debugprint itemsmod @@ -110,12 +110,12 @@ ;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; ;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; ;; Configurations for server -(tcp-buffer-size 2048) -(max-connections 2048) +;; (tcp-buffer-size 2048) +;; (max-connections 2048) ;; info about me as a server ;; (defstruct servdat (host #f) @@ -147,12 +147,23 @@ (fullname #f) (hostport #f) (ipaddr #f) (port #f) (srvpkt #f) + (srvkey #f) (lastmsg 0) - (expires 0)) + (expires 0) + (inport #f) + (outport #f)) + +(define *srvpktspec* + `((server (host . h) + (port . p) + (servkey . k) + (pid . i) + (ipaddr . a) + (dbpath . d)))) ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== @@ -204,14 +215,15 @@ (thread-sleep! 4) (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries ))) (if the-srv ;; yes, we have a server, now try connecting to it (let* ((srv-addr (server-address the-srv)) - (ipaddr (alist-ref 'ipaddr the-srv)) - (port (alist-ref 'port the-srv)) + (ipaddr (alist-ref 'ipaddr the-srv)) + (port (alist-ref 'port the-srv)) + (srvkey (alist-ref 'servkey the-srv)) (fullpath (db:dbname->path apath dbname)) - (srvready (server-ready? ipaddr port fullpath))) + (srvready (server-ready? ipaddr port srvkey))) (if srvready (begin (hash-table-set! (rmt:remote-conns remote) dbname ;; fullpath ;; yes, I'd prefer it to be fullpath - FIXME later (make-rmt:conn @@ -220,10 +232,11 @@ fullname: fullpath hostport: srv-addr ipaddr: ipaddr port: port srvpkt: the-srv + srvkey: srvkey ;; generated by rmt:get-signature on the server side lastmsg: (current-seconds) expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping )) #t) (start-main-srv))) @@ -255,10 +268,11 @@ (begin (debug:print-info 0 *default-log-port* "Unexpected result: " res) res))))))))) ;;====================================================================== + ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) @@ -266,41 +280,59 @@ (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))) +#;(define (rmt:send-receive-setup conn) + (if (not (rmt:conn-inport conn)) + (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) + (rmt:conn-port conn)))) + (rmt:conn-inport-set! conn i) + (rmt:conn-outport-set! conn o)))) + ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; 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") - (let* ((payload (sexpr->string params)) - (res (with-input-from-request - (rmt:conn->uri conn "api") - `((params . ,payload) - (cmd . ,cmd) - (key . "nokey")) - read-string))) - (if (string? res) - (string->sexpr res) - res)))) + (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)))) + + ;; 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 ;; for the given area path and dbname ;; -(define (rmt:send-receive-server-start remote apath dbname) - (let* ((conn (rmt:get-conn remote apath dbname))) - (assert conn "FATAL: Unable to connect to db "apath"/"dbname) - (let* ((res (with-input-from-request - (rmt:conn->uri conn "api") - `((params . (,apath ,dbname))) - read-string))) - (string->sexpr res)))) +;; (define (rmt:send-receive-server-start remote apath dbname) +;; (let* ((conn (rmt:get-conn remote apath dbname))) +;; (assert conn "FATAL: Unable to connect to db "apath"/"dbname) +;; #;(let* ((res (with-input-from-request +;; (rmt:conn->uri conn "api") +;; `((params . (,apath ,dbname))) +;; 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* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) @@ -357,11 +389,11 @@ ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) - (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*))) + (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*))) ;; rmt:login-no-auto-client-setup ;; rmt:send-receive-no-auto-client-setup ;; hand off a call to one of the db:queries statements @@ -1459,11 +1491,11 @@ (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (bdat-task-db-set! *bdat* #f))))) - (http-client#close-idle-connections!) + #;(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...") @@ -1489,14 +1521,14 @@ (args:get-arg "-server")) ;; 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 -;; in the same process as the server. +;; in the same process as the server. ;; (define (server:ping host port server-id #!key (do-exit #f)) - (server-ready? host port "nokey yet")) + (server-ready? host port server-id)) ;;====================================================================== ;; http-transportmod.scm contents moved here ;;====================================================================== @@ -1514,162 +1546,116 @@ ;; -> 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 (http-handle-api dbstruct $) - (if (api-proc) - ((api-proc) dbstruct $) ;; ($) => alist - 'no-api-proc-set)) - -(define (http-transport:run hostn) - ;; Configurations for server - (tcp-buffer-size 2048) - (max-connections 2048) +#;(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 ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (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))) (if ipstr ipstr hostn))) ;; hostname))) - (start-port (portlogger:open-run-close portlogger:find-port)) + (port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (common:get-linktree)) (tmp-area (common:get-db-tmp-area)) #;(start-file (conc tmp-area "/.server-start"))) - (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port) - ;; set some parameters for the server - (root-path (if link-tree-path - link-tree-path - (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! - (handle-directory spiffy-directory-listing) - #;(handle-exception (lambda (exn chain) - (signal (make-composite-condition - (make-property-condition - 'server - 'message "server error"))))) - - ;; Setup the web server and a /ctrl interface - ;; - (vhost-map `(((* any) . ,(lambda (continue) - ;; open the db on the first call - ;; This is were we set up the database connections - (let* (($ (request-vars source: 'both)) - ;; (dat ($ 'dat)) - (res #f)) - (cond - ((equal? (uri-path (request-uri (current-request))) - '(/ "api")) - (debug:print 0 *default-log-port* "In api request $=" $) - (send-response ;; the $ is the request vars proc - body: (http-handle-api *dbstruct-db* $) - headers: '((content-type text/plain))) - (set! *db-last-access* (current-seconds))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "ping")) - (send-response body: (conc *toppath*"/"(args:get-arg "-db")) - headers: '((content-type text/plain)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "loop-test")) - (send-response body: (alist-ref 'data ($)) - headers: '((content-type text/plain)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "")) - (send-response body: ((http-get-function 'http-transport:main-page)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "json_api")) - (send-response body: ((http-get-function 'http-transport:main-page)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "runs")) - (send-response body: ((http-get-function 'http-transport:main-page)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ any)) - (send-response body: "hey there!\n" - headers: '((content-type text/plain)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "hey")) - (send-response body: "hey there!\n" - headers: '((content-type text/plain)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "jquery3.1.0.js")) - (send-response body: ((http-get-function 'http-transport:show-jquery)) - headers: '((content-type application/javascript)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "test_log")) - (send-response body: ((http-get-function 'http-transport:html-test-log) $) - headers: '((content-type text/HTML)))) - ((equal? (uri-path (request-uri (current-request))) - '(/ "dashboard")) - (send-response body: ((http-get-function 'http-transport:html-dboard) $) - headers: '((content-type text/HTML)))) - (else (continue)))))))) - (http-transport:try-start-server ipaddrstr start-port))) - -;; This is recursively run by http-transport:run until sucessful, it then runs until server is stopped -;; -(define (http-transport:try-start-server ipaddrstr portnum) - (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) - (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes"))) - (if (not config-use-proxy) - (determine-proxy (constantly #f))) - ;; any error in following steps will result in a retry + (debug:print-info 0 *default-log-port* "portlogger recommended port: " port) (if *server-info* (begin (servdat-host-set! *server-info* ipaddrstr) - (servdat-port-set! *server-info* portnum) + (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))) - (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" - (seconds->time-string (current-seconds)) - " ipaddrsstr=" ipaddrstr - " portnum=" portnum - " config-hostname=" config-hostname) - (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) - - ;; get_next_port goes here - (http-transport: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) - ;; This starts the spiffy server - ;; NEED WAY TO SET IP TO #f TO BIND ALL - ;; (start-server bind-address: ipaddrstr port: portnum) - (if config-hostname ;; this is a hint to bind directly - (start-server port: portnum bind-address: (if (equal? config-hostname "-") - ipaddrstr - config-hostname)) - (start-server port: portnum)) - (portlogger:open-run-close portlogger:set-port portnum "released") - (debug:print 1 *default-log-port* "INFO: server has been stopped")))) + (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* ((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* + (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))) + (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))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== - (define (http-transport:get-time-to-cleanup) (let ((res #f)) (mutex-lock! *http-mutex*) (set! res (> (current-seconds) *http-connections-next-cleanup*)) @@ -1698,12 +1684,13 @@ (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.052) (loop etime)) - (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) - (close-idle-connections!))) + (debug:print-error 0 *default-log-port* + "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + #;(close-idle-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) @@ -1728,35 +1715,10 @@ ;; ;;(close-idle-connections!) ;; #t)) ;; #f))) -(define (make-http-transport:server-dat)(make-vector 6)) -(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0)) -(define (http-transport:server-dat-get-port vec) (vector-ref vec 1)) -(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2)) -(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3)) -(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4)) -(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5)) -;(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6)) -(define (http-transport:server-dat-get-server-id vec) (vector-ref vec 6)) - -(define (http-transport:server-dat-make-url vec) - (if (and (http-transport:server-dat-get-iface vec) - (http-transport:server-dat-get-port vec)) - (conc "http://" - (http-transport:server-dat-get-iface vec) - ":" - (http-transport:server-dat-get-port vec)) - #f)) - -(define (http-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 http-transport:server-dat-update-last-access with non-vector!!")))) ;; initialize servdat for client side, setup needed parameters ;; pass in #f as sdat-in to create sdat ;; #;(define (servdat-init sdat-in iface port uuid) @@ -1790,18 +1752,10 @@ (res (db:get-iam-server-lock dbh dbfile))) (sqlite3:finalize! dbh) res)) -(define *srvpktspec* - `((server (host . h) - (port . p) - (servkey . k) - (pid . i) - (ipaddr . a) - (dbpath . d)))) - (define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath) (let* ((pkt-dat `((host . ,host) (port . ,port) (servkey . ,servkey) (pid . ,(current-process-id)) @@ -1842,35 +1796,44 @@ (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 - ;; ping the server and ask it - ;; if it ready - ;; (let* ((sdat (servdat-init #f host port #f))) - ;; (http-transport:send-receive sdat "abc" 'ping '()))) - (let* ((res (with-input-from-request - (conc "http://"host":"port"/ping") ;; returns *toppath*/dbname - #f - read-string))) - (if (equal? res key) - #t + (let-values (((i o)(handle-exceptions + exn + (values #f #f) + (tcp-connect host port)))) + (if (and i o) (begin - (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res) + (write `((cmd . ping) + (key . ,key) + (params . ())) o) + (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)))) - -(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 '()))) - (let* ((payload (sexpr->string data)) - (res (with-input-from-request - (conc "http://"host":"port"/loop-test") - `((data . ,payload)) - read-string))) - (string->sexpr res))) + +;; (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 '()))) +;; (let* ((payload (sexpr->string data)) +;; (res (with-input-from-request +;; (conc "http://"host":"port"/loop-test") +;; `((data . ,payload)) +;; read-string))) +;; (string->sexpr res)) +;; #f +;; ) ; from the pkts return servers associated with dbpath ;; NOTE: Only one can be alive - have to check on each ;; in the list of pkts returned ;; @@ -1893,12 +1856,13 @@ #f (let* ((spkt (car tail)) (host (alist-ref 'ipaddr spkt)) (port (alist-ref 'port spkt)) (dbpth (alist-ref 'dbpath spkt)) + (srvkey (alist-ref 'Z spkt)) ;; (alist-ref 'srvkey spkt)) (addr (server-address spkt))) - (if (server-ready? host port (conc apath"/"dbpth)) + (if (server-ready? host port srvkey) spkt (loop (cdr tail))))))) ;; am I the "first" in line server? I.e. my D card is smallest ;; use Z card as tie breaker @@ -1964,11 +1928,11 @@ (register-server pkts-dir *srvpktspec* (get-host-name) (servdat-port sdat) server-key (servdat-host sdat) db-file)) - + ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) (viables (get-viable-servers all-pkts db-file)) (best-srv (get-best-candidate viables db-file)) (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f))) @@ -1987,10 +1951,13 @@ (exit))) (begin (debug:print 0 *default-log-port* "Keys do not match "best-srv-key", "server-key", exiting.") (bdat-time-to-exit-set! *bdat* #t) + (delete-file* (conc (get-pkts-dir *toppath*) + "/" (servdat-uuid *server-info*) + ".pkt")) ;; remove immediately instead of waiting for on-exit (thread-sleep! 0.2) (exit))) sdat)) (begin ;; sdat not yet contains server info (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) @@ -2037,36 +2004,36 @@ ((or (not (equal? last-host curr-host)) (not (equal? last-port curr-port))) (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") (thread-sleep! 0.25) (loop curr-host curr-port (+ tries 1))) - ((< (- (current-seconds) stime) 3) ;; keep up the looping until at least 3 seconds have passed - (thread-sleep! 1) + ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed + (thread-sleep! 0.5) (loop curr-host curr-port (+ tries 1))) (else - (if (not *server-id*)(set! *server-id* (server:mk-signature))) + (rmt:get-signature) ;; sets *my-signature* as side effect (servdat-status-set! *server-info* 'interface-stable) (debug:print 0 *default-log-port* "SERVER STARTED: " curr-host ":" curr-port - " AT " (current-seconds) " server-id: " *server-id* + " AT " (current-seconds) " server signature: " *my-signature* " with "(servdat-trynum *server-info*)" port changes") (flush-output *default-log-port*) #t)))))) ;; 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. ;; -(define (http-transport:keep-running dbname) +(define (rmt:keep-running dbname) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") (let* ((server-start-time (current-seconds)) (pkts-dir (get-pkts-dir)) - (server-key (server:mk-signature)) + (server-key (rmt:get-signature)) ;; This servers key (is-main (equal? (args:get-arg "-db") ".db/main.db")) (last-access 0) (server-timeout (server:expiration-timeout))) ;; main and run db servers have both got wait logic (could/should merge it) (if is-main @@ -2190,49 +2157,49 @@ ;; all routes though here end in exit ... ;; ;; This is the point at which servers are started ;; (define (rmt:server-launch dbname) - ;;(let* ((tmp-area (common:get-db-tmp-area)) - ;; (server-start (conc tmp-area "/.server-start")) - ;; (server-started (conc tmp-area "/.server-started")) - ;; (start-time (common:lazy-modification-time server-start)) - ;; (started-time (common:lazy-modification-time server-started)) - ;; (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting - ;; (start-time-old (> (- (current-seconds) start-time) 5)) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") - (http-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-") - )) "Server run")) + (rmt:run (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") - (http-transport:keep-running dbname) + (rmt:keep-running dbname) "Keep running")))) (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) - (exit))) + (exit)) + + #f + ) -;; Generate a unique signature for this server -(define (server:mk-signature) +;; Generate a unique signature for this process, used at both client and +;; server side +(define (rmt:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (current-process-id) (argv))))))) -(define (server:get-client-signature) - (if *my-client-signature* *my-client-signature* - (let ((sig (server:mk-signature))) - (set! *my-client-signature* sig) - *my-client-signature*))) +(define (rmt:get-signature) + (if *my-signature* *my-signature* + (let ((sig (rmt:mk-signature))) + (set! *my-signature* sig) + *my-signature*))) + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== ;; run ping in separate process, safest way in some cases ;; #;(define (server:ping-server ifaceport) (with-input-from-pipe @@ -2245,18 +2212,10 @@ ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) - -;;====================================================================== -;; S E R V E R -;;====================================================================== -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== - ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used). ;; #;(define (server:login toppath) (lambda (toppath) (set! *db-last-access* (current-seconds)) ;; might not be needed. @@ -2281,5 +2240,72 @@ ;; (else #f)))) ) + +;;====================================================================== +;; A T T I C +;;====================================================================== + + + ;; (handle-directory spiffy-directory-listing) +;; #;(handle-exception (lambda (exn chain) +;; (signal (make-composite-condition +;; (make-property-condition +;; 'server +;; 'message "server error"))))) +;; +;; ;; Setup the web server and a /ctrl interface +;; ;; +;; (vhost-map `(((* any) . ,(lambda (continue) +;; ;; open the db on the first call +;; ;; This is were we set up the database connections +;; (let* (($ (request-vars source: 'both)) +;; ;; (dat ($ 'dat)) +;; (res #f)) +;; (cond +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "api")) +;; (debug:print 0 *default-log-port* "In api request $=" $) +;; (send-response ;; the $ is the request vars proc +;; body: (http-handle-api *dbstruct-db* $) +;; headers: '((content-type text/plain))) +;; (set! *db-last-access* (current-seconds))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "ping")) +;; (send-response body: (conc *toppath*"/"(args:get-arg "-db")) +;; headers: '((content-type text/plain)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "loop-test")) +;; (send-response body: (alist-ref 'data ($)) +;; headers: '((content-type text/plain)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "")) +;; (send-response body: ((http-get-function 'http-transport:main-page)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "json_api")) +;; (send-response body: ((http-get-function 'http-transport:main-page)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "runs")) +;; (send-response body: ((http-get-function 'http-transport:main-page)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ any)) +;; (send-response body: "hey there!\n" +;; headers: '((content-type text/plain)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "hey")) +;; (send-response body: "hey there!\n" +;; headers: '((content-type text/plain)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "jquery3.1.0.js")) +;; (send-response body: ((http-get-function 'http-transport:show-jquery)) +;; headers: '((content-type application/javascript)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "test_log")) +;; (send-response body: ((http-get-function 'http-transport:html-test-log) $) +;; headers: '((content-type text/HTML)))) +;; ((equal? (uri-path (request-uri (current-request))) +;; '(/ "dashboard")) +;; (send-response body: ((http-get-function 'http-transport:html-dboard) $) +;; headers: '((content-type text/HTML)))) +;; (else (continue)))))))) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -40,11 +40,11 @@ TARGET = "ubuntu/nfs/none" all : build unit test4 # test1 test2 test3 test4 test5 test6 test7 test8 test9 -unit : basicserver.log +unit : basicserver.log server.log # all-rmt.log all-api.log # runs.log misc.log tests.log # inter dependencies on the unit tests, I wish these could be "suggestions" all-rmt.log : all-api.log Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -22,28 +22,31 @@ ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (import rmtmod trace http-client apimod dbmod launchmod) + (trace-call-sites #t) (trace ;; db:get-dbdat ;; rmt:find-main-server - rmt:send-receive-real - rmt:send-receive +;; rmt:send-receive-real +;; rmt:send-receive ;; sexpr->string ;; server-ready? ;; rmt:register-server ;; rmt:open-main-connection - rmt:general-open-connection + ;; rmt:general-open-connection ;; rmt:get-conny ;; common:watchdog ;; rmt:find-main-server ;; get-all-server-pkts ;; get-viable-servers ;; get-best-candidate ;; api:run-server-process + ;; rmt:run + ;; rmt:try-start-server ) (test #f #t (rmt:remote? (let ((r (make-rmt:remote))) (set! *rmt:remote* r) r))) @@ -53,294 +56,25 @@ (pp (hash-table->alist (rmt:remote-conns *rmt:remote*))) (test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))) (define *main* (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")) -(for-each (lambda (tdat) - (test #f tdat (loop-test (rmt:conn-ipaddr *main*) - (rmt:conn-port *main*) tdat))) - (list 'a - '(a "b" 123 1.23 ))) -(test #f #t (number? (rmt:send-receive 'ping #f 'hello))) +;; (for-each (lambda (tdat) +;; (test #f tdat (loop-test (rmt:conn-ipaddr *main*) +;; (rmt:conn-port *main*) tdat))) +;; (list 'a +;; '(a "b" 123 1.23 ))) +(test #f #t (rmt:send-receive 'ping #f 'hello)) (define *db* (db:setup #f)) ;; these let me cut and paste from source easily (define apath *toppath*) (define dbname ".db/2.db") (define remote *rmt:remote*) (define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) +(test #f '() (string->sexpr "()")) (test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/2.db"))) (set! *dbstruct-db* #f) -(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 '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:register-run keyvals "run2" "new" "n/a" "justme" #f)) - -;; (delete-file* "logs/1.log") -;; (define run-id 1) - -;; (test "setup for run" #t (begin (launch:setup) -;; (string? (getenv "MT_RUN_AREA_HOME")))) -;; -;; (test #f #t (and (server:kind-run *toppath*) #t)) -;; -;; -;; (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")) -;; -;; ;; Setup -;; ;; -;; ;; (test #f #f (not (client:setup run-id))) -;; ;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) -;; -;; ;; Login -;; ;; -;; (test #f'(#t "successful login") -;; (rmt:login run-id)) -;; -;; ;; Keys -;; ;; -;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) -;; -;; ;; No data in db -;; ;; -;; (test #f '() (rmt:get-all-run-ids)) -;; (test #f #f (rmt:get-run-name-from-id run-id)) -;; (test #f -;; (vector -;; header -;; (vector #f #f #f #f)) -;; (rmt:get-run-info run-id)) -;; -;; ;; Insert data into db -;; ;; -;; (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 1 (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))) -;; -;; ;; With data in db -;; ;; -;; (print "Using runame=" runname) -;; (test #f '(1) (rmt:get-all-run-ids)) -;; (test #f runname (rmt:get-run-name-from-id run-id)) -;; (test #f -;; runname -;; (let ((run-info (rmt:get-run-info run-id))) -;; (db:get-value-by-header (db:get-rows run-info) -;; (db:get-header run-info) -;; "runname"))) -;; -;; ;; test killing server -;; ;; -;; (for-each -;; (lambda (run-id) -;; (test #f #t (and (tasks:kill-server-run-id run-id) #t)) -;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) -;; (list 0 1)) -;; -;; ;; Tests to assess reading/writing while servers are starting/stopping -;; ;; NO LONGER APPLICABLE -;; -;; ;; Server tests go here -;; (define (server-tests-dont-run-right-now) -;; (for-each -;; (lambda (run-id) -;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) -;; (server:kind-run run-id) -;; (test "did server start within 20 seconds?" -;; #t -;; (let loop ((remtries 20) -;; (running (tasks:server-running-or-starting? (db:delay-if-busy -;; (tasks:open-db)) -;; run-id))) -;; (if running -;; (> running 0) -;; (if (> remtries 0) -;; (begin -;; (thread-sleep! 1) -;; (loop (- remtries 1) -;; (tasks:server-running-or-starting? (db:delay-if-busy -;; (tasks:open-db)) -;; run-id))))))) -;; -;; (test "did server become available" #t -;; (let loop ((remtries 10) -;; (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) -;; (if res -;; (vector? res) -;; (begin -;; (if (> remtries 0) -;; (begin -;; (thread-sleep! 1.1) -;; (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) -;; res))))) -;; ) -;; (list 0 1))) -;; -;; (define start-time (current-seconds)) -;; (define (reading-writing-while-server-starting-stopping-dont-run-now) -;; (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))) -;; (map (lambda (dat) -;; (apply print (intersperse (vector->list dat) ", "))) -;; server-dats) -;; (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 (if first-dat (vector-ref first-dat 0) 'blah) -;; ((running) -;; (print "Server appears to be running. Now ask it to shutdown") -;; (rmt:kill-server run-id) -;; (loop 'server-shutdown)) -;; ((shutting-down) -;; (loop test-state)) -;; (else (print "Don't know what to do if get here")))) -;; ((server-shutdown) -;; (loop test-state))))) -;; ) - -;;====================================================================== -;; END OF TESTS -;;====================================================================== - - -;; (test #f #f (client:setup run-id)) - -;; (set! *transport-type* 'http) -;; -;; (test "setup for run" #t (begin (launch: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 - -debugbcom 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 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 "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 "this is a comment" 1) #t)) -;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 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) 2)) -;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 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))) -;; - -;; (exit) + +(exit) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -20,10 +20,321 @@ ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) +(import rmtmod trace http-client apimod dbmod + launchmod) + +(trace-call-sites #t) +(trace + ;; db:get-dbdat + ;; rmt:find-main-server +;; rmt:send-receive-real +;; rmt:send-receive + ;; sexpr->string + ;; server-ready? + ;; rmt:register-server + ;; rmt:open-main-connection + ;; rmt:general-open-connection + ;; rmt:get-conny + ;; common:watchdog + ;; rmt:find-main-server + ;; get-all-server-pkts + ;; get-viable-servers + ;; get-best-candidate + ;; api:run-server-process + ;; rmt:run + ;; rmt:try-start-server + ) + +(define *db* (db:setup #f)) + +;; these let me cut and paste from source easily +(define apath *toppath*) +(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 '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:register-run keyvals "run2" "new" "n/a" "justme" #f)) + +;; (delete-file* "logs/1.log") +;; (define run-id 1) + +;; (test "setup for run" #t (begin (launch:setup) +;; (string? (getenv "MT_RUN_AREA_HOME")))) +;; +;; (test #f #t (and (server:kind-run *toppath*) #t)) +;; +;; +;; (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")) +;; +;; ;; Setup +;; ;; +;; ;; (test #f #f (not (client:setup run-id))) +;; ;; (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) +;; +;; ;; Login +;; ;; +;; (test #f'(#t "successful login") +;; (rmt:login run-id)) +;; +;; ;; Keys +;; ;; +;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) +;; +;; ;; No data in db +;; ;; +;; (test #f '() (rmt:get-all-run-ids)) +;; (test #f #f (rmt:get-run-name-from-id run-id)) +;; (test #f +;; (vector +;; header +;; (vector #f #f #f #f)) +;; (rmt:get-run-info run-id)) +;; +;; ;; Insert data into db +;; ;; +;; (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 1 (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))) +;; +;; ;; With data in db +;; ;; +;; (print "Using runame=" runname) +;; (test #f '(1) (rmt:get-all-run-ids)) +;; (test #f runname (rmt:get-run-name-from-id run-id)) +;; (test #f +;; runname +;; (let ((run-info (rmt:get-run-info run-id))) +;; (db:get-value-by-header (db:get-rows run-info) +;; (db:get-header run-info) +;; "runname"))) +;; +;; ;; test killing server +;; ;; +;; (for-each +;; (lambda (run-id) +;; (test #f #t (and (tasks:kill-server-run-id run-id) #t)) +;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) +;; (list 0 1)) +;; +;; ;; Tests to assess reading/writing while servers are starting/stopping +;; ;; NO LONGER APPLICABLE +;; +;; ;; Server tests go here +;; (define (server-tests-dont-run-right-now) +;; (for-each +;; (lambda (run-id) +;; (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) +;; (server:kind-run run-id) +;; (test "did server start within 20 seconds?" +;; #t +;; (let loop ((remtries 20) +;; (running (tasks:server-running-or-starting? (db:delay-if-busy +;; (tasks:open-db)) +;; run-id))) +;; (if running +;; (> running 0) +;; (if (> remtries 0) +;; (begin +;; (thread-sleep! 1) +;; (loop (- remtries 1) +;; (tasks:server-running-or-starting? (db:delay-if-busy +;; (tasks:open-db)) +;; run-id))))))) +;; +;; (test "did server become available" #t +;; (let loop ((remtries 10) +;; (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) +;; (if res +;; (vector? res) +;; (begin +;; (if (> remtries 0) +;; (begin +;; (thread-sleep! 1.1) +;; (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) +;; res))))) +;; ) +;; (list 0 1))) +;; +;; (define start-time (current-seconds)) +;; (define (reading-writing-while-server-starting-stopping-dont-run-now) +;; (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))) +;; (map (lambda (dat) +;; (apply print (intersperse (vector->list dat) ", "))) +;; server-dats) +;; (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 (if first-dat (vector-ref first-dat 0) 'blah) +;; ((running) +;; (print "Server appears to be running. Now ask it to shutdown") +;; (rmt:kill-server run-id) +;; (loop 'server-shutdown)) +;; ((shutting-down) +;; (loop test-state)) +;; (else (print "Don't know what to do if get here")))) +;; ((server-shutdown) +;; (loop test-state))))) +;; ) + +;;====================================================================== +;; END OF TESTS +;;====================================================================== + + +;; (test #f #f (client:setup run-id)) + +;; (set! *transport-type* 'http) +;; +;; (test "setup for run" #t (begin (launch: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 - -debugbcom 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 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 "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 "this is a comment" 1) #t)) +;; (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 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) 2)) +;; (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 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))) +;; + +;; (exit) + + +;; all old stuff below + + + (delete-file* "logs/1.log") (define run-id 1) (test "setup for run" #t (begin (launch:setup-for-run) Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -1241,12 +1241,12 @@ ;; read data from tmp file or create if not exists ;; if exists regen in background ;; (define (tests:lazy-dot testrecords outtype sizex sizey) - (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) - (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) + (let ((dfile (conc "/tmp/." (current-user-name) "-" (rmt:mk-signature) ".dot")) + (fname (conc "/tmp/." (current-user-name) "-" (rmt:mk-signature) ".dotdat"))) (tests:write-dot-file testrecords dfile sizex sizey) (if (common:file-exists? fname) (let ((res (with-input-from-file fname (lambda () (read-lines))))) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -40,11 +40,12 @@ ;; ;; extents caches extents calculated on draw ;; ;; proc is called on draw and takes the obj itself as a parameter ;; ;; attrib is an alist of parameters ;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc) ;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache) -;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst +;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) +;; ;; libs: hash of name->lib, insts: hash of instname->inst ;; inits ;; (define (vg:comp-new) (make-vg:comp objs: '() name: #f file: #f))