Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -194,10 +194,11 @@ #t ) #f ) ) + (define (dbfile:run-id->path apath run-id) (conc apath"/"(dbfile:run-id->dbname run-id))) (define (db:dbname->path apath dbname) @@ -205,16 +206,22 @@ (define (dbfile:run-id->dbnum run-id) (cond ((number? run-id) (modulo run-id (num-run-dbs))) - ((not run-id) "main") ;; 0 or main? - (else run-id))) + ((not run-id) "main") ;; 0 or main? No, not 0. + (else + (assert #f "FATAL: run-id is required to be a number or #f")))) -;; POTENTIAL BUG: this implementation could produce a db file if run-id is neither #f or a number +;; just the filename +(define (dbfile:run-id->dbfname run-id) + (conc (dbfile:run-id->dbnum run-id)".db")) + +;; the path in MTRAH with the filename (define (dbfile:run-id->dbname run-id) - (conc ".mtdb/"(dbfile:run-id->dbnum run-id)".db")) + (conc ".mtdb/"(dbfile:run-id->dbfname run-id))) + ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -41,10 +41,12 @@ commonmod dbfile debugprint ) + +(define dbcache-mode (make-parameter 'tmp)) ;; 'inmem, 'tmp ;; NOTE: This returns only the name "1.db", "main.db", not the path ;; (define (dbmod:run-id->dbfname run-id) (conc (dbfile:run-id->dbnum run-id)".db")) @@ -165,12 +167,20 @@ (let* ((dbstruct (or dbstruct-in (make-dbr:dbstruct areapath: areapath))) (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id))) (dbpath (dbmod:get-dbdir dbstruct)) ;; directory where all the .db files are kept (dbfullname (conc dbpath"/"dbfname)) ;; (dbmod:run-id->full-dbfname dbstruct run-id)) (dbexists (file-exists? dbfullname)) + (tmpdir (conc "/tmp/"(current-user-name))) + (tmpdb (let* ((fname (conc tmpdir"/"(current-process-id)"-"dbfname))) + (if (not (file-exists? tmpdir))(create-directory tmpdir)) + ;; check if tmpdb already exists, either delete it or + ;; add something to the name + fname)) (inmem (dbmod:open-inmem-db init-proc - (conc "/tmp/"(current-process-id)"-"dbfname) ;; will create /tmp file + (if (eq? (dbcache-mode) 'inmem) + #f + tmpdb) )) (write-access (file-write-access? dbpath)) (db (dbmod:safely-open-db dbfullname init-proc write-access)) (tables (db:sync-all-tables-list keys))) (assert (sqlite3:database? inmem) "FATAL: open-dbmoddb: inmem is not a db") Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -128,12 +128,10 @@ (set! *runremote* newremote) (set! runremote newremote))) (let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id))) (tt:handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))) - - (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")) (for-each (lambda (cmd) Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -115,22 +115,26 @@ (define (tt:make-remote areapath) (make-tt areapath: areapath)) ;; 1 ... or #f -(define (tt:valid-run-id run-id) - (or (number? run-id) - (not run-id))) +;; and check that dbfname matches. FIXME: the propagation of dbfname and run-id +;; might not make the best sense +;; +(define (tt:valid-run-id run-id dbfname) + (and (or (number? run-id) + (not run-id)) + (equal? (dbfile:run-id->dbfname run-id) dbfname))) (tcp-buffer-size 2048) ;; (max-connections 4096) ;; do all the busy work of finding and setting up conn for ;; connecting to a server ;; (define (tt:client-connect-to-server ttdat dbfname run-id testsuite) - (assert (tt:valid-run-id run-id) "FATAL: invalid run-id "run-id) + (assert (tt:valid-run-id run-id dbfname) "FATAL: invalid run-id "run-id) (let* ((conn (hash-table-ref/default (tt-conns ttdat) dbfname #f)) (server-start-proc (lambda () (tt:server-process-run (tt-areapath ttdat) testsuite ;; (dbfile:testsuite-name) @@ -176,11 +180,11 @@ (debug:print-info 0 *default-log-port* "No server found. Starting one for run-id "run-id" in dbfile "dbfname) (server-start-proc) (tt-last-serv-start-set! ttdat (current-seconds)))) (thread-sleep! 1) (tt:client-connect-to-server ttdat dbfname run-id testsuite))))))) - + (define (tt:ping host port server-id) (let* ((res (tt:send-receive-direct host port `(ping #f #f #f)))) ;; please send me your server-id ;; ;; need two threads, one a 5 second timer ;; @@ -265,11 +269,15 @@ (define (tt:get-server-info-sorted ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (sfiles (tt:find-server areapath dbfname)) (sdats (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read (sorted (sort sdats (lambda (a b) - (< (list-ref a 2)(list-ref b 2))))) + (let* ((starta (list-ref a 2)) + (startb (list-ref b 2))) + (if (eq? starta startb) + (string>? (list-ref a 3)(list-ref b 3)) ;; if servers started at same time look at server-id + (< starta startb)))))) (count 0)) (for-each (lambda (rec) (if (or (> (length sorted) 1) (common:low-noise-print 120 "server info sorted")) @@ -429,11 +437,11 @@ ;; can't ping and file has been on disk 15 seconds, go ahead and try to remove it (debug:print-info 0 *default-log-port* "Removing apparently dead server info file: "servinfofile) (delete-file* servinfofile) #t) ;; not the server but the server is not reachable (begin - (debug:print 0 *default-log-port* "I'm not the server but could not ping "host":"port", trying again.") + (debug:print 0 *default-log-port* "I'm not the server but could not ping "host":"port", will try again.") (thread-sleep! 1) ;; just because #t))))) (else ;; should never get here (debug:print 0 *default-log-port* "BAD SERVER RECORD: "leadsrv) (assert #f "Bad server record "leadsrv)))))))) @@ -440,10 +448,11 @@ (if ok ;; (if (> *api-process-request-count* 0) ;; have requests in flight ;; (tt-last-access-set! ttdat (current-seconds))) (tt-last-access-set! ttdat *db-last-access*) ;; bit silly, just use db-last-access (begin + (debug:print 0 *default-log-port* "Exiting immediately") (cleanup) (exit))) (let* ((last-update (dbr:dbstruct-last-update dbstruct)) (curr-secs (current-seconds)))