Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -330,16 +330,17 @@ (let* ((dbpath (db:run-id->dbname run-id)) (dbdat (db:get-dbdat dbstruct *toppath* dbpath)) (db (dbr:dbdat-inmem dbdat)) (fname (dbr:dbdat-fname dbdat)) (use-mutex (> *api-process-request-count* 25))) ;; was 25 - (if (and use-mutex + #;(if (and use-mutex (common:low-noise-print 120 "over-50-parallel-api-requests")) (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) - (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) + #;(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) - (condition-case + (apply proc db params) + #;(condition-case (begin (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let ((res (apply proc db params))) (if use-mutex (mutex-unlock! *db-with-db-mutex*)) ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) @@ -1268,13 +1269,14 @@ host TEXT, port INTEGER, servkey TEXT, pid TEXT, ipaddr TEXT, - dbpath TEXT, + apath TEXT, + dbname TEXT, event_time TIMESTAMP DEFAULT (strftime('%s','now')), - CONSTRAINT servers_constraint UNIQUE (dbpath));") + CONSTRAINT servers_constraint UNIQUE (apath,dbname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, @@ -5517,27 +5519,37 @@ ;;====================================================================== ;; these are all intended to be run against main.db ;; run this one in a transaction where first check if host:port is taken -(define (db:register-server dbstruct host port servkey pid ipaddr dbpath) +(define (db:register-server dbstruct host port servkey pid ipaddr apath dbname) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,dbpath) VALUES (?,?,?,?,?,?);" - host port servkey pid ipaddr dbpath)))) - + (sqlite3:with-transaction + db + (lambda () + (let* ((sinfo (db:get-server-info dbstruct apath dbname))) + (if sinfo + (begin + (debug:print-info 0 *default-log-port* "Server already running at "sinfo ", while trying to register server " host":"port) + #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))))))))) + (define (db:get-server-info dbstruct apath dbname) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:fold-row - (lambda (res host port servkey pid ipaddr dbpath) - (list host port servkey pid ipaddr dbpath)) + (lambda (res host port servkey pid ipaddr apath dbpath) + (list host port servkey pid ipaddr apath dbpath)) #f db - "SELECT host,port,servkey,pid,ipaddr,dbpath FROM servers WHERE dbpath=?;" - (conc apath "/" dbname))))) + "SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;" + apath dbname)))) ) Index: fullrununit.sh ================================================================== --- fullrununit.sh +++ fullrununit.sh @@ -1,6 +1,6 @@ #!/bin/bash -(killall mtest -v;sleep 1;killall mtest -v -9;rm tests/simplerun/logs/*;rm tests/basicserver.log) & +(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 Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -261,30 +261,33 @@ (start-main-srv)))) ;; NB// remote is a rmt:remote struct ;; (define (rmt:general-open-connection remote apath dbname #!key (num-tries 5)) - (cond - ((not (rmt:get-conn remote apath (db:run-id->dbname #f))) ;; no channel open to main? - (rmt:open-main-connection remote apath) - (thread-sleep! 2) - (rmt:general-open-connection remote apath dbname)) - ((not (rmt:get-conn remote apath dbname)) ;; no channel open to dbname? - (let* ((res (rmt:send-receive-real remote apath dbname #f 'get-server `(,apath ,dbname)))) - (case res - ((server-started) - (if (> num-tries 0) - (begin - (thread-sleep! 2) - (rmt:general-open-connection remote apath dbname - num-tries: (- num-tries 1))) - (begin - (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname) - (exit 1)))) - (else - (debug:print-info 0 *default-log-port* "Unexpected result: " res) - res)))))) + (let ((mdbname (db:run-id->dbname #f))) + (cond + ((not (rmt:get-conn remote apath mdbname)) ;; no channel open to main? + (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) + (if (> num-tries 0) + (begin + (thread-sleep! 2) + (rmt:general-open-connection remote apath dbname num-tries: (- num-tries 1))) + (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 + (debug:print-info 0 *default-log-port* "Unexpected result: " res) + res))))))))) ;;====================================================================== ;; Defaults to current area ;; @@ -292,16 +295,16 @@ (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (rmt:general-open-connection conns apath dbname) - (rmt:send-receive-real conns apath dbname rid cmd params))) + (rmt:send-receive-real conns apath dbname cmd params))) ;; 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 rid cmd params) +(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") @@ -671,11 +674,14 @@ ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user contour) ;; first register in main.db (thus the #f) (let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))) ;; now register in the run db itself + + ;; NEED A RECORD INSERT INCLUDING SETTING id (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour)) + run-id)) (define (rmt:get-run-name-from-id run-id) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) @@ -1494,11 +1500,11 @@ (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) - #f 'register-server + 'register-server `(,(servdat-uuid sdat) ,(current-process-id) ,(servdat-host sdat) ;; iface ,(servdat-port sdat)))))))) (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db @@ -2271,18 +2277,20 @@ (exit)) (loop start-time (equal? sdat last-sdat) sdat)))))))) -(define (rmt:register-server remote apath iface port server-key db-file) +(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) #f 'register-server `(,iface - ,port - ,server-key - ,(current-process-id) - ,iface - ,db-file))) + (db:run-id->dbname #f) 'register-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 loop ((sdat #f) ;; this is our copy of the *last* *server-info* (tries 0)) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -64,23 +64,28 @@ (define *db* (db:setup #f)) ;; these let me cut and paste from source easily (define apath *toppath*) -(define dbname ".db/1.db") +(define dbname ".db/2.db") (define remote *rmt:remote*) +(define keyvals '(("SYSTEM" "a")("RELEASE" "b"))) -(test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/1.db"))) +(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 'server-started (rmt:send-receive-real remote apath ".db/main.db" #f 'get-server `(,apath ,dbname))) +(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 'server-started (rmt:general-open-connection *rmt:remote* *toppath* ".db/1.db")) +(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:register-run '(("SYSTEM" "a")("RELEASE" "b")) "run1" "new" "n/a" "justme" #f)) +(test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f))) +(test #t 1 (rmt:send-receive 'register-run run-id (list keyvals "run1" "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)