Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -28,14 +28,14 @@ ezsteps.scm lock-queue.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files -MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm +MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm -mofiles/dbfile.o : mofiles/debugprint.o -mofiles/debugprint.o : mofiles/mtargs.o +mofiles/dbfile.o : mofiles/debugprint.o mofiles/commonmod.o commonmod.import.o +mofiles/debugprint.o : mofiles/mtargs.o mofiles/commonmod.o commonmod.import.o # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm @@ -49,23 +49,28 @@ MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) # compiled import files MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) -%.import.o : %.import.scm - csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o +# %.import.o : %.import.scm +# csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o + +# %.import.scm : mofiles/%.o +# sleep 0.1 # I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary... # mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm # @[ -e mofiles ] || mkdir -p mofiles # csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o # cp $*.o mofiles/$*.o # @touch $*.import.scm # ensure it is touched after the .o is made -mofiles/%.o : %.scm +mofiles/%.o %.import.o : %.scm megatest-fossil-hash.scm mkdir -p mofiles - csc $(CSCOPTS) -J -c $< -o mofiles/$*.o + csc $(CSCOPTS) -J -c $< -o mofiles/$*.o # $(shell ls *.o mofiles/*.o) + csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o # $(shell ls *.o mofiles/*.o) + @touch $*.import.scm # ensure it is younger than the .o ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') @@ -210,11 +215,11 @@ if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm $(MOFILES) - csc $(CSCOPTS) -c $< $(MOFILES) + csc $(CSCOPTS) -c $< $(MOFILES) $(MOIMPFILES) $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -146,10 +146,11 @@ ;; - keep it simple, only return the actual result of the call, i.e. no meta info here ;; ;; - returns #( flag result ) ;; (define (api:execute-requests dbstruct dat) + (db:open-no-sync-db) ;; sets *no-sync-db* (handle-exceptions exn (let ((call-chain (get-call-chain))) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn) (print-call-chain (current-error-port)) @@ -254,14 +255,14 @@ ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct params)) ;; NO SYNC DB - ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) - ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) - ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) - ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) + ((no-sync-set) (apply db:no-sync-set (db:no-sync-db *no-sync-db*) params)) + ((no-sync-get/default) (apply db:no-sync-get/default (db:no-sync-db *no-sync-db*) params)) + ((no-sync-del!) (apply db:no-sync-del! (db:no-sync-db *no-sync-db*) params)) + ((no-sync-get-lock) (apply db:no-sync-get-lock (db:no-sync-db *no-sync-db*) params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -26,12 +26,12 @@ (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) (declare (unit common)) -;; (declare (uses commonmod)) -;; (import commonmod) +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") ;; (require-library margs) @@ -402,11 +402,12 @@ ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) - (apply db:multi-db-sync + (debug:print 0 *default-log-port* "WARNING: common:cleanup-db has NOT been reimplemented yet! Please fix!") + #;(apply db:multi-db-sync dbstruct 'schema ;; 'new2old 'killservers 'adj-target @@ -724,55 +725,10 @@ (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) -;; dot-locking egg seems not to work, using this for now -;; if lock is older than expire-time then remove it and try again -;; to get the lock -;; -(define (common:simple-file-lock fname #!key (expire-time 300)) - (let ((fmod-time (handle-exceptions - ext - (current-seconds) - (file-modification-time fname)))) - (if (common:file-exists? fname) - (if (> (- (current-seconds) fmod-time) expire-time) - (begin - (handle-exceptions exn #f (delete-file* fname)) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (common:file-exists? fname) - (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) - #f))))) - -(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) - (let ((end-time (+ expire-time (current-seconds)))) - (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) - (if got-lock - #t - (if (> end-time (current-seconds)) - (begin - (thread-sleep! 3) - (loop (common:simple-file-lock fname expire-time: expire-time))) - #f))))) - -(define (common:simple-file-release-lock fname) - (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) - ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -156,7 +156,97 @@ ;; (define (debug:print-info . params) #f) ;; ;; (define (set-functions dbgp dbgpinfo) ;; (set! debug:print dbgp) ;; (set! debug:print-info dbgpinfo)) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (common:simple-file-lock fname #!key (expire-time 300)) + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + (if (file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (handle-exceptions exn #f (delete-file* fname)) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (common:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (common:simple-file-lock fname #!key (expire-time 300)) + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + (if (file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (handle-exceptions exn #f (delete-file* fname)) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (common:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) ) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -161,22 +161,19 @@ ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; ;; (define db:get-db db:get-subdb) -;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh -;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id))) -;; (if (stack? (dbr:subdb-dbstack subdb)) -;; (if (stack-empty? (dbr:subdb-dbstack subdb)) -;; (let* ((dbname (db:run-id->dbname run-id)) -;; (newdb (db:open-megatest-db path: (db:dbfile-path) -;; name: dbname))) -;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used -;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) -;; newdb) -;; (stack-pop! (dbr:subdb-dbstack subdb))) -;; (db:open-db subdb run-id))) ;; ) +(define (db:get-db dbstruct run-id) + (let* ((subdb (dbfile:get-subdb dbstruct run-id)) + (dbdat (dbfile:get-dbdat dbstruct run-id))) + (if (dbr:dbdat? dbdat) + dbdat + (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db) + ) + ) +) (define-inline (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply debug:print-error 0 *default-log-port* message) (debug:print-error 0 *default-log-port* " params: " params @@ -212,28 +209,28 @@ (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*)) (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) (condition-case - (begin - (if use-mutex (mutex-lock! *db-with-db-mutex*)) - (let ((res (apply proc dbdat db params))) - (if use-mutex (mutex-unlock! *db-with-db-mutex*)) - ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) - (if dbdat (stack-push! (dbr:subdb-dbstack subdb) dbdat)) - res)) - (exn (io-error) - (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) - (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) - (db:generic-error-printout exn "ERROR: database " fname - " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem.")) - (exn () - (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: " - ((condition-property-accessor 'exn 'message) exn)))))) + (begin + (if use-mutex (mutex-lock! *db-with-db-mutex*)) + (let ((res (apply proc dbdat db params))) + (if use-mutex (mutex-unlock! *db-with-db-mutex*)) + ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + (if dbdat (stack-push! (dbr:subdb-dbstack subdb) dbdat)) + res)) + (exn (io-error) + (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) + (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) + (db:generic-error-printout exn "ERROR: database " fname + " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem.")) + (exn () + (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: " + ((condition-property-accessor 'exn 'message) exn)))))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; @@ -2105,10 +2102,27 @@ (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== + +(define (db:no-sync-db db-in) + (if db-in + db-in + (if *no-sync-db* + *no-sync-db* + (begin + (mutex-lock! *db-access-mutex*) + (let ((dbpath (common:get-db-tmp-area)) + (db (dbfile:open-no-sync-db dbpath))) + (set! *no-sync-db* db) + (mutex-unlock! *db-access-mutex*) + db))))) + +(define (with-no-sync-db proc) + (let* ((db (db:no-sync-db *no-sync-db*))) + (proc db))) (define (db:open-no-sync-db) (dbfile:open-no-sync-db (db:dbfile-path))) (define (db:no-sync-close-db db stmt-cache) @@ -5009,12 +5023,20 @@ ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles) (for-each (lambda (file) (let* ((fname (conc (pathname-file file) ".db")) (fulln (conc *toppath*"/.db/"fname)) - (time1 (file-modification-time file)) - (time2 (file-modification-time fulln)) + (time1 (if (file-exists? file) + (file-modification-time file) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file "file) + 1))) + (time2 (if (file-exists? fulln) + (file-modification-time fulln) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln) + 0))) (changed (> time1 time2)) (do-cp (cond ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln) #t) @@ -5061,11 +5083,13 @@ (begin (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.") (let loop () ;; run the sync and print out durations - (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db)) + (let* ((changed (db:run-lock-and-sync no-sync-db))) + (if (not (null? changed)) + (debug:print-info 0 *default-log-port* "Sync durations: "changed))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -17,11 +17,14 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit dbfile)) -;; (declare (uses debugprint)) +(declare (uses debugprint)) +;; (declare (uses debugprint.import)) +(declare (uses commonmod)) +;; (declare (uses commonmod.import)) (module dbfile * (import scheme chicken data-structures extras) @@ -29,10 +32,12 @@ posix typed-records srfi-18 srfi-69 stack files ports + + commonmod ) ;; (import debugprint) ;;====================================================================== @@ -267,23 +272,12 @@ ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (dbfile:open-sqlite3-db dbpath init-proc) - (let* ((dbexists (file-exists? dbpath)) - (db ;; need locking here so multiple open - ;; do not collide - (let* ((db (sqlite3:open-database dbpath))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) - (init-proc db)) - #;(dbfile:lock-create-open dbpath - (lambda (db) - (init-proc db)))) - (write-access (file-write-access? dbpath))) - #;(if (and dbexists (not write-access)) - (set! *db-write-access* #f)) - ;; (cons db dbpath))) + (let* ((write-access (file-write-access? dbpath)) + (db (dbfile:cautious-open-database dbpath init-proc))) (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) (define (dbfile:print-and-exit . params) (with-output-to-port (current-error-port) @@ -440,51 +434,66 @@ ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== -;; if we are not a server create a db handle. this is not finalized -;; so watch for problems. I'm still not clear if it is needed to manually -;; finalize sqlite3 dbs with the sqlite3 egg. -;; -(define (db:no-sync-db db-in) - (if db-in - db-in - (if *no-sync-db* - *no-sync-db* - (begin - (mutex-lock! *db-access-mutex*) - (let ((db (dbfile:open-no-sync-db))) - (set! *no-sync-db* db) - (mutex-unlock! *db-access-mutex*) - db))))) + +(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 10)) + (let* ((retry (lambda () + (thread-sleep! 0.5) + (if (> tries-left 0) + (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) + (condition-case + (let* ((db-exists (file-exists? fname)) + (db (sqlite3:open-database fname))) + (if (and init-proc (not db-exists)) + (init-proc db)) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + db) + (exn (io-error) + (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") + (retry)) + (exn (corrupt) + (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") + (retry)) + (exn (busy) + (dbfile:print-err exn "ERROR: database " fname + " is locked. Try copying to another location, remove original and copy back.") + (retry)) + (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.") + (retry)) + (exn () + (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: " + ((condition-property-accessor 'exn 'message) exn)) + (retry))))) (define (dbfile:open-no-sync-db dbpath) - (let* (;; (dbpath (db:dbfile-path)) - (dbname (conc dbpath "/no-sync.db")) + (if (not (file-exists? dbpath)) + (create-directory dbpath #t)) + (let* ((dbname (conc dbpath "/no-sync.db")) (db-exists (file-exists? dbname)) - (db (sqlite3:open-database dbname))) + (db (dbfile:cautious-open-database dbname))) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (if (not db-exists) (begin (sqlite3:execute db "PRAGMA synchronous = 0;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") - (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));"))) + ;; (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) db)) (define (db:no-sync-set db var val) - (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) + (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) (define (db:no-sync-del! db var) - (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) + (sqlite3:execute db "DELETE FROM no_sync_metadat WHERE var=?;" var)) (define (db:no-sync-get/default db var default) (let ((res default)) (sqlite3:for-each-row (lambda (val) (set! res val)) - (db:no-sync-db db) + db "SELECT val FROM no_sync_metadat WHERE var=?;" var) (if res (let ((newres (if (string? res) (string->number res) @@ -498,22 +507,21 @@ ;; either: ;; fails returns (#f . lock-creation-time) ;; succeeds (returns (#t . lock-creation-time) ;; use (db:no-sync-del! db keyname) to release the lock ;; -(define (db:no-sync-get-lock db-in keyname) - (let ((db (db:no-sync-db db-in))) - (sqlite3:with-transaction - db - (lambda () - (handle-exceptions - exn +(define (db:no-sync-get-lock db keyname) + (sqlite3:with-transaction + db + (lambda () + (handle-exceptions + exn (let ((lock-time (current-seconds))) ;; (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn) (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) `(#t . ,lock-time)) - `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))) + `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))) ;;====================================================================== ;; file utils ;;====================================================================== @@ -546,52 +554,7 @@ (apply max (map dbfile:lazy-modification-time file-list)))) -;; dot-locking egg seems not to work, using this for now -;; if lock is older than expire-time then remove it and try again -;; to get the lock -;; -(define (common:simple-file-lock fname #!key (expire-time 300)) - (let ((fmod-time (handle-exceptions - ext - (current-seconds) - (file-modification-time fname)))) - (if (file-exists? fname) - (if (> (- (current-seconds) fmod-time) expire-time) - (begin - (handle-exceptions exn #f (delete-file* fname)) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (file-exists? fname) - (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) - #f))))) - -(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) - (let ((end-time (+ expire-time (current-seconds)))) - (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) - (if got-lock - #t - (if (> end-time (current-seconds)) - (begin - (thread-sleep! 3) - (loop (common:simple-file-lock fname expire-time: expire-time))) - #f))))) - -(define (common:simple-file-release-lock fname) - (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) - ) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -403,10 +403,11 @@ ;; 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* ((sdat #f) + (no-sync-db (db:open-no-sync-db)) (tmp-area (common:get-db-tmp-area)) (started-file (conc tmp-area "/.server-started")) (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) @@ -506,13 +507,14 @@ (mutex-unlock! *heartbeat-mutex*) (if (common:low-noise-print 120 (conc "server running on " iface ":" port)) (begin (if (not *server-id*) - (set! *server-id* (server:mk-signature))) - (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) - (flush-output *default-log-port*))) + (set! *server-id* (server:mk-signature))) + (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv)) + (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) + (flush-output *default-log-port*))) (if (common:low-noise-print 60 "dbstats") (begin (debug:print 0 *default-log-port* "Server stats:") (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -42,21 +42,28 @@ (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (declare (uses dbmod)) (declare (uses dbmod.import)) +(declare (uses commonmod)) +(declare (uses commonmod.import)) +(declare (uses mtargs)) +(declare (uses mtargs.import)) +(declare (uses debugprint)) +(declare (uses debugprint.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) -;; (declare (uses debugprint)) -;; (declare (uses debugprint.import)) ;; (declare (uses mtargs)) ;; (declare (uses mtargs.import)) ;; (declare (uses ftail)) ;; (import ftail) -(import dbmod +(import (prefix mtargs mod:) + commonmod + (prefix debugprint mod:) + dbmod dbfile) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -22,19 +22,21 @@ directory-utils posix-extras matchable utils) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) - (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) (declare (uses http-transport)) ;;(declare (uses rpc-transport)) (declare (uses launch)) ;; (declare (uses daemon)) + +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -514,24 +514,23 @@ (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" param-key state-patt action-patt test-patt))))) (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) - ;; (handle-exceptions - ;; exn - ;; '() - ;; (sqlite3:first-row - (let ((db (db:delay-if-busy (db:get-db dbstruct))) - (res '())) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (cons (cons a b) res))) - db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue + (db:with-db + dbstruct + #f #f + (lambda (dbdat db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (cons a b) res))) + db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue WHERE target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" - target run-name state-patt action-patt test-patt) - res)) ;; ) + target run-name state-patt action-patt test-patt) + res)))) ;; kill any runner processes (i.e. processes handling -runtests) that match target/runname ;; ;; do a remote call to get the task queue info but do the killing as self here. ;; Index: tests/simplerun/Makefile ================================================================== --- tests/simplerun/Makefile +++ tests/simplerun/Makefile @@ -1,5 +1,5 @@ cleanup : killall mtest dboard -v -9 || true - rm -rf *.log *.bak NB* logs/* .meta .db ../simpleruns/* lt + rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt Index: tests/simplerun/thebeginning.scm ================================================================== --- tests/simplerun/thebeginning.scm +++ tests/simplerun/thebeginning.scm @@ -52,5 +52,8 @@ ;; *************** db.scm tests **************** (define thisdbdat (db:open-db dbstruct #f)) (test #f #t (dbr:dbdat? thisdbdat)) + +(test #f #t (dbr:subdb? (db:get-db dbstruct #f))) +(test #f #t (dbr:subdb? (db:get-db dbstruct 1)))