Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -140,11 +140,11 @@ (dbfile:setup do-sync *toppath*)) ;; looks up subdb and returns it, if not found then set up ;; and then return it. ;; -(define (db:get-subdb dbstruct run-id) +(define (db:get-db dbstruct run-id) (let* ((res (dbfile:get-subdb dbstruct run-id))) (if res res (let* ((newsubdb (make-dbr:subdb))) (dbfile:set-subdb dbstruct run-id newsubdb) @@ -157,11 +157,11 @@ ;; if run-id is a string treat it as a filename ;; if db already open - return inmem ;; 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 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)) @@ -241,11 +241,11 @@ ;; open an sql database inside a file lock ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;; (define *db-open-mutex* (make-mutex)) - +;; (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) (file-exists (common:file-exists? fname)) @@ -337,15 +337,25 @@ (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db)) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (write-access (file-write-access? mtdbfname)) - ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime - ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced - ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) - ;(fmt (file-modification-time tmpdbfname)) + + ;; (mtdbmodtime (if mtdbexists + ;; (common:lazy-sqlite-db-modification-time mtdbpath) + ;; #f)) ; moving this before db:open-megatest-db is + ;; called. if wal mode is on -WAL and -shm file get + ;; created with causing the tmpdbmodtime timestamp + ;; always greater than mtdbmodtime (tmpdbmodtime (if + ;; dbfexists (common:lazy-sqlite-db-modification-time + ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm + ;; file get created when db:open-megatest-db is + ;; called. modtimedelta will always be < 10 so db in + ;; tmp not get synced (tmpdbmodtime (if dbfexists + ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt + ;; (file-modification-time tmpdbfname)) + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) (when write-access (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger") (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger")) @@ -389,15 +399,12 @@ ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; - -;;(define (db:reopen-megatest-db - (define (db:open-megatest-db dbpath) - (let* ((dbexists (common:file-exists? dbpath)) + (let* ((dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db)))) (write-access (file-write-access? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -49,15 +49,16 @@ ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb (dbname #f) ;; .db/1.db - (mtdb #f) ;; mtrah/.db/1.db + (mtdbfile #f) ;; mtrah/.db/1.db + (mtdbdat #f) ;; only need one of these for syncing ;; (dbdats (make-hash-table)) ;; id => dbdat - (tmpdb #f) ;; /tmp/.../.db/1.db - (refndb #f) ;; /tmp/.../.db/1.db_ref - (dbstack (make-stack)) ;; stack for tmp db handles, ????? why => do not initialize with a stack + (tmpdbfile #f) ;; /tmp/.../.db/1.db + ;; (refndbfile #f) ;; /tmp/.../.db/1.db_ref + (dbstack (make-stack)) ;; stack for tmp dbr:dbdat, (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (last-sync 0) (last-write (current-seconds)) @@ -161,21 +162,22 @@ ;; 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. ;; -(define (dbfile:setup do-sync areapath) +(define (dbfile:setup do-sync areapath tmppath) (cond (*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard (else ;;(common:on-homehost?) - (let* ((dbstructs (make-dbr:dbstruct))) + (let* ((dbstruct (make-dbr:dbstruct))) #;(when (not *toppath*) (debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") (launch:setup areapath: areapath)) - (set! *dbstruct-dbs* dbstructs) - (dbr:dbstruct-areapath-set! dbstructs areapath) - dbstructs)))) + (set! *dbstruct-dbs* dbstruct) + (dbr:dbstruct-areapath-set! dbstruct areapath) + (dbr:dbstruct-tmppath-set! dbstruct tmppath) + dbstruct)))) #;(define (dbfile:get-subdb dbstruct run-id) (let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f))) (if res res @@ -197,24 +199,224 @@ ;; if run-id is a string treat it as a filename ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (dbfile:get-dbh 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)) - #f - (stack-pop! (dbr:subdb-dbstack subdb))) - #f))) - -(define (dbfile:add-dbh dbstruct run-id dbh) - (let* ((subdb (dbfile:get-subdb dbstruct run-id))) - (if (not (stack? (dbr:subdb-dbstack subdb))) - (dbr:subdb-dbstack-set! subdb (make-stack))) - (stack-push! (dbr:subdb-dbstack subdb) dbh))) - +(define (dbfile:get-dbdat dbstruct run-id) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (if (stack-empty? (dbr:subdb-dbstack subdb)) + #f + (stack-pop! (dbr:subdb-dbstack subdb))))) + +;; return a previously opened db handle to the stack of available handles +(define (dbfile:add-dbdat dbstruct run-id dbdat) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (stack-push! (dbr:subdb-dbstack subdb) dbdat))) + +;; returns the dbstruct with needed data populated +;; 1. if needed setup the subdb for the given run-id +;; 2. if there is no existing db handle in the stack +;; create a new handle and return it (do NOT add +;; it to the stack). +;; +(define (dbfile:open-db dbstruct run-id init-proc) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (if (not subdb) ;; not yet defined + (let* ((dbname (db:run-id->dbname run-id)) + (areapath (dbr:dbstruct-areapath dbstruct)) + (tmppath (dbr:dbstruct-tmppath dbstruct)) + (mtdbpath (db:run-id->path areapath run-id)) + (tmpdbpath (db:run-id->path tmppath run-id)) + (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc)) + (tmpdbdat (dbfile:open-sqlite3-db tmpdbpath init-proc)) ;; push this on the stack + (newsubdb (make-dbr:subdb dbname: dbname + mtdbfile: mtdbpath + tmpdbfile: tmpdbpath + mtdbdat: mtdbdat))) + (dbfile:add-dbdat dbstruct run-id tmpdbdat) + (dbfile:set-subdb dbstruct run-id newsubdb) + (dbfile:open-db dbstruct run-id init-proc)) + (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) + (if dbdat + dbdat + (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) + (tmpdbpath (db:run-id->path tmppath run-id))) + (dbfile:open-sqlite3-db tmpdbpath init-proc))))))) + +;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open +;; + +;; Open the classic megatest.db file (defaults to open in toppath) +;; +;; NOTE: returns a dbdat not a dbstruct! +;; +(define (dbfile:open-sqlite-db dbpath init-proc) + (let* ((dbexists (file-exists? dbpath)) + (db (dbfile:lock-create-open dbpath + (lambda (db) + (db:initialize-main-db db)))) + (write-access (file-write-access? dbpath))) + (dbfile:print-err "db:open-megatest-db "dbpath) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + ;; (cons db dbpath))) + (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) + (lambda () + (apply print params))) + (exit 1)) + +(define (dbfile:print-err . params) + (with-output-to-port + (current-error-port) + (lambda () + (apply print params)))) + +;; open an sql database inside a file lock +;; returns: db existed-prior-to-opening +;; RA => Returns a db handler; sets the lock if opened in writable mode +;; +;; (define *db-open-mutex* (make-mutex)) +;; +(define (dbfile:lock-create-open fname initproc) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local + (raw-fname (pathname-file fname)) + (dir-writable (file-write-access? parent-dir)) + (file-exists (file-exists? fname)) + (file-write (if file-exists + (file-write-access? fname) + dir-writable ))) + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. + (if file-write ;; dir-writable + (condition-case + (let* ((lockfname (conc fname ".lock")) + (readyfname (conc parent-dir "/.ready-" raw-fname)) + (readyexists (common:file-exists? readyfname))) + (if (not readyexists) + (common:simple-file-lock-and-wait lockfname)) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not file-exists) + (initproc db)) + (if (not readyexists) + (begin + (common:simple-file-release-lock lockfname) + (with-output-to-file + readyfname + (lambda () + (print "Ready at " + (seconds->year-work-week/day-time + (current-seconds))))))) + db)) + (exn (io-error) (dbfile:print-and-exit "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (dbfile:print-and-exit "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (dbfile:print-and-exit "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(dbfile:print-and-exit "ERROR: database " fname " has some permissions problem.")) + (exn () (dbfile:print-and-exit "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + + (condition-case + (begin + (dbfile:print-err "WARNING: opening db in non-writable dir " fname) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (mutex-unlock! *db-open-mutex*) + db)) + (exn (io-error) + (dbfile:print-and-exit + "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) + (dbfile:print-and-exit + "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) + (dbfile:print-and-exit + "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission) + (dbfile:print-and-exit + "ERROR: database " fname " has some permissions problem.")) + (exn () + (dbfile:print-and-exit + "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + ))) + + +;; This routine creates the db if not already present. It is only called if the db is not already opened +;; +(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t)) + (let* ((subdb (dbfile:get-subdb dbstruct run-id)) + (tmpdb-stack (dbr:subdb-dbstack subdb)) + (max-stale-tmp (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) + (dbpath (dbr:dbstruct-tmppath dbstruct)) ;; (db:dbfile-path)) ;; path to tmp db area + (dbname (db:run-id->dbname run-id)) + (dbexists (file-exists? dbpath)) + (areapath (dbr:dbstruct-areapath dbstruct)) + (mtdbfname (conc areapath "/"dbname)) + (mtdbexists (file-exists? mtdbfname)) + (mtdbmodtime (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname) #f)) + (mtdb (db:open-sqlite-db mtdbfname init-proc)) + ;; the reference db for syncing + (refdbfname (conc dbpath "/"dbname"_ref")) + (refndb (db:open-megatest-db refdbfname)) + ;; (mtdbpath (dbr:dbdat-dbfile mtdb)) + ;; the tmpdb + (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db + (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db)) + (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + + (write-access (file-write-access? mtdbfname)) + + ;; (mtdbmodtime (if mtdbexists + ;; (common:lazy-sqlite-db-modification-time mtdbpath) + ;; #f)) ; moving this before db:open-megatest-db is + ;; called. if wal mode is on -WAL and -shm file get + ;; created with causing the tmpdbmodtime timestamp + ;; always greater than mtdbmodtime (tmpdbmodtime (if + ;; dbfexists (common:lazy-sqlite-db-modification-time + ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm + ;; file get created when db:open-megatest-db is + ;; called. modtimedelta will always be < 10 so db in + ;; tmp not get synced (tmpdbmodtime (if dbfexists + ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt + ;; (file-modification-time tmpdbfname)) + + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) + + (when write-access + (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger") + (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger")) + + ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) + ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + (if (and dbexists (not write-access)) + (begin + (set! *db-write-access* #f) + (dbr:subdb-read-only-set! subdb #t))) + (dbr:subdb-mtdb-set! subdb mtdb) + (dbr:subdb-tmpdb-set! subdb tmpdb) + (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? + (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path) + (dbr:subdb-refndb-set! subdb refndb) + (if (and (or (not dbfexists) + (and modtimedelta + (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + do-sync) + (begin + (dbfile:print-err "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) + (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb) + ;; touch tmp db to avoid wal mode wierdness + (set! (file-modification-time tmpdbfname) (current-seconds)) + (dbfile:print-err "INFO: db:sync-all-tables-list done.") + ) + (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) ) + ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically + tmpdb)) + ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== (define (dbfile:open-no-sync-db dbpath) @@ -227,8 +429,87 @@ (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;"))) db)) + +;;====================================================================== +;; file utils +;;====================================================================== + +;;====================================================================== +;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 +;; +(define (dbfile:lazy-modification-time fpath) + (handle-exceptions + exn + (begin + (dbfile:print-err "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn) + 0) + (if (file-exists? fpath) + (file-modification-time fpath) + 0))) + +;;====================================================================== +;; find timestamp of newest file associated with a sqlite db file +(define (dbfile:lazy-sqlite-db-modification-time fpath) + (let* ((glob-list (handle-exceptions + exn + (begin + (dbfile:print-err "Failed to glob " fpath "*, exn=" exn) + `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) + (glob (conc fpath "*")))) + (file-list (if (eq? 0 (length glob-list)) + '("/no/such/file") + glob-list))) + (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: tests/simplerun/thebeginning.scm ================================================================== --- tests/simplerun/thebeginning.scm +++ tests/simplerun/thebeginning.scm @@ -1,12 +1,21 @@ -(use trace test) +(use trace test (prefix sqlite3 sqlite3:)) (import dbfile) (trace-call-sites #t) + +(trace + ;; dbfile:get-subdb + ) (test #f #t (dbr:dbstruct? (db:setup #t))) (define dbstruct *dbstruct-dbs*) (test #f #f (dbfile:get-subdb dbstruct #f)) ;; get main.db (never opened yet) (test #f #f (dbfile:get-subdb dbstruct 1)) ;; get 1.db -(test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct) )) +(test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct))) + +(test #f #t (sqlite3:database? (db:open-db dbstruct #f))) +(test #f #t (sqlite3:database? (db:open-db dbstruct 1))) + +(test #f #t (stack? (dbr:subdb-dbstack subdb (test #f #f (db:get-subdb dbstruct 1)) ;; (test #f #f (stack? (dbr:subdb-dbstack subdb)))