Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2635,19 +2635,17 @@ run-id #f (lambda (dbdat db) (let ((res (cons #f #f)) (stmth (db:get-cache-stmth dbdat db "SELECT state,status FROM tests WHERE id=? AND run_id=?;"))) - ;; (db:with-mutex-for-stmth - ;; (lambda() (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (state status) (cons state status)) ;; db stmth ;;"SELECT state,status FROM tests WHERE id=? AND run_id=?;" ;; stmth try not compiling this one - yes, this fixed the bind issue - test-id run-id))) - res)) ;; )) + test-id run-id) + res)))) ;; Use db:test-get* to access ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -512,20 +512,21 @@ (procinf-dbname-set! *procinf* dbfname) (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*)))) - (if (< count 5) + (if (< count 10) (begin - (thread-sleep! 0.5) + (thread-sleep! 0.25) (loop (+ count 1))) (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set!")))) (thread-join! run-thread) ;; run thread will exit on timeout or other conditions ;; replace with call to (dbfile:set-process-done nsdb host pid reason) (procinf-status-set! *procinf* "done") (procinf-end-set! *procinf* (current-seconds)) + ;; either convert this to use set-process-done or get rid of set-process-done (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*))) (debug:print 0 *default-log-port* "Exiting now.") @@ -536,20 +537,11 @@ ;; listener socket has been started by this stage ;; wait for a port before creating the registration file ;; (let* ((db-locked-in #f) (areapath (tt-areapath ttdat)) - (nosyncdbpath (conc areapath"/.mtdb")) - (cleanup (lambda () - (if (tt-cleanup-proc ttdat) - ((tt-cleanup-proc ttdat))) ;; removes .servinfo file - (dbfile:with-no-sync-db nosyncdbpath - (lambda (db) - (let* ((dbtmpname (dbr:dbstruct-dbtmpname dbstruct))) - ;; (debug:print-info 0 *default-log-port* "Running clean up, including removing db file "dbtmpname) - (db:no-sync-del! db dbfname) - )))))) + (nosyncdbpath (conc areapath"/.mtdb"))) (set! *server-info* ttdat) (let loop ((count 0)) (if (> count 240) (begin (debug:print 0 *default-log-port* "FATAL: Could not start a tcp server, giving up.") @@ -629,11 +621,11 @@ (assert #f "Bad server record "leadsrv)))))))) (if ok (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) + (tt:shutdown-server ttdat) (exit))) (let* ((last-update (dbr:dbstruct-last-update dbstruct)) (curr-secs (current-seconds))) (if (and (eq? (tt-state ttdat) 'running) @@ -646,76 +638,36 @@ (if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param)) (begin (thread-sleep! 5) (loop))))) - (cleanup) + ;; (cleanup) ;; all done by tt:shutdown-server (debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running."))) - -;; ;; given an already set up uconn start the cmd-loop -;; ;; -;; (define (tt:cmd-loop ttdat) -;; (let* ((serv-listener (-socket uconn)) -;; (listener (lambda () -;; (let loop ((state 'start)) -;; (let-values (((inp oup)(tcp-accept serv-listener))) -;; ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP -;; (let* ((rdat (deserialize inp)) ;; '(my-host-port qrykey cmd params) -;; (resp (ulex-handler uconn rdat))) -;; (serialize resp oup) -;; (close-input-port inp) -;; (close-output-port oup) -;; ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP -;; ) -;; (loop state)))))) -;; ;; start N of them -;; (let loop ((thnum 0) -;; (threads '())) -;; (if (< thnum 100) -;; (let* ((th (make-thread listener (conc "listener" thnum)))) -;; (thread-start! th) -;; (loop (+ thnum 1) -;; (cons th threads))) -;; (map thread-join! threads))))) -;; -;; -;; -;; (define (wait-and-close uconn) -;; (thread-join! (udat-cmd-thread uconn)) -;; (tcp-close (udat-socket uconn))) -;; -;; (define (tt:shutdown-server ttdat) - (let* ((cleanproc (tt-cleanup-proc ttdat)) - (port (tt-port ttdat))) + (let* ((host (tt-host ttdat)) + (port (tt-port ttdat)) + (sinf (tt-servinf-file ttdat))) (tt-state-set! ttdat 'shutdown) (portlogger:open-run-close portlogger:set-port port "released") - (if cleanproc (cleanproc)) + (if (file-exists? sinf) + (delete-file* sinf)) (tcp-close (tt-socket ttdat)) ;; close up ports here )) -;; (define (wait-and-close uconn) -;; (thread-join! (tt-cmd-thread uconn)) -;; (tcp-close (tt-socket uconn))) - ;; return servid ;; side-effects: ;; ttdat-cleanup-proc is populated with function to remove the serverinfo file (define (tt:create-server-registration-file ttdat dbfname) (let* ((areapath (tt-areapath ttdat)) (servdir (tt:get-servinfo-dir areapath)) (host (tt-host ttdat)) (port (tt-port ttdat)) (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname)) - (serv-id (tt:mk-signature areapath)) - (clean-proc (lambda () - (delete-file* servinf) - ))) + (serv-id (tt:mk-signature areapath))) (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname) - (tt-cleanup-proc-set! ttdat clean-proc) (tt-servinf-file-set! ttdat servinf) (with-output-to-file servinf (lambda () (print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname))) serv-id)) @@ -733,13 +685,13 @@ ;; filter the files here by looking in processes table (if we are not main.db) ;; and or look at the time stamp on the servinfo file, a running server will ;; touch the file every minute (again, this will only apply for main.db) (for-each (lambda (fname) (let* ((age (- (current-seconds)(file-modification-time fname)))) - (if (> age 200) ;; can't trust it if over twenty seconds old + (if (> age 200) ;; can't trust it if over 200 seconds old (begin - (debug:print 0 *default-log-port* "WARNING: removing stale servinfo file "fname) + (debug:print 0 *default-log-port* "WARNING: removing stale servinfo file "fname", it is "age" seconds old") (handle-exceptions exn (debug:print 0 *default-log-port* "WARNING: error attempting to remove stale servinfo file "fname) (delete-file fname))) ;; (set! goodfiles (cons fname goodfiles)))))