ADDED dbfile.scm
Index: dbfile.scm
==================================================================
--- /dev/null
+++ dbfile.scm
@@ -0,0 +1,641 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit dbfile))
+;; (declare (uses debugprint))
+;; (declare (uses commonmod))
+
+(module dbfile
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18
+ srfi-69
+ stack
+ files
+ ports
+
+ ;; commonmod
+ )
+
+;; (import debugprint)
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; a single Megatest area with it's multiple dbs is
+;; managed in a dbstruct
+;;
+(defstruct dbr:dbstruct
+ (areapath #f)
+ (homehost #f)
+ (tmppath #f)
+ (read-only #f)
+ (subdbs (make-hash-table))
+ )
+
+;; NOTE: Need one dbr:subdb per main.db, 1.db ...
+;;
+(defstruct dbr:subdb
+ (dbname #f) ;; .db/1.db
+ (mtdbfile #f) ;; mtrah/.db/1.db
+ (mtdbdat #f) ;; only need one of these for syncing
+ ;; (dbdats (make-hash-table)) ;; id => dbdat
+ (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))
+ ) ;; goal is to converge on one struct for an area but for now it is too confusing
+
+;; need to keep dbhandles and cached statements together
+(defstruct dbr:dbdat
+ (dbfile #f)
+ (dbh #f)
+ (stmt-cache (make-hash-table))
+ (read-only #f))
+
+(define *dbstruct-dbs* #f)
+(define *db-access-mutex* (make-mutex))
+(define *no-sync-db* #f)
+
+(define (dbfile:run-id->key run-id)
+ (or run-id 'main))
+
+(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
+ (if (<= try-num 0)
+ #f
+ (handle-exceptions
+ exn
+ (begin
+ (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
+ (thread-sleep! 3)
+ (sqlite3:interrupt! db)
+ (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
+ (if (sqlite3:database? db)
+ (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
+ (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
+ (sqlite3:finalize! db)
+ #t)
+ (begin
+ (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db")
+ #f
+ )
+ ))))
+
+;; close all opened run-id dbs
+(define (db:close-all dbstruct)
+ (if (dbr:dbstruct? dbstruct)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
+;; (print-call-chain *default-log-port*))
+ ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
+ (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
+ (for-each
+ (lambda (subdb)
+ (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb)))
+ (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb)))
+ #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb))))
+
+ (map (lambda (dbdat)
+ (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat))
+ (dbh (dbr:dbdat-dbh dbdat)))
+ (db:safely-close-sqlite3-db dbh stmt-cache)))
+ tdbs)
+ (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache (dbr:subdb-mtdbdat subdb)))
+ ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
+ #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ subdbs)
+ #t
+ )
+ #f
+ )
+)
+
+;; ;; set up a single db (e.g. main.db, 1.db ... etc.)
+;; ;;
+;; (define (db:setup-db dbstruct areapath run-id)
+;; (let* ((dbname (db:run-id->dbname run-id))
+;; (dbstruct (hash-table-ref/default dbstructs dbname #f)))
+;; (if dbstruct
+;; dbstruct
+;; (let* ((dbstruct-new (make-dbr:dbstruct)))
+;; (db:open-db dbstruct-new run-id areapath: areapath do-sync: #t)
+;; (hash-table-set! dbstructs dbname dbstruct-new)
+;; dbstruct-new))))
+
+;; ; Returns the dbdat for a particular dbfile inside the area
+;; ;;
+;; (define (dbr:dbstruct-get-dbdat dbstruct dbfile)
+;; (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))
+;;
+;; (define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
+;; (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))
+;;
+;; (define (db:run-id->first-num run-id)
+;; (let* ((s (number->string run-id))
+;; (l (string-length s)))
+;; (substring s (- l 1) l)))
+
+;; 1234 => 4/1234.db
+;; #f => 0/main.db
+;; (abandoned the idea of num/db)
+;;
+(define (dbfile:run-id->path apath run-id)
+ (conc apath"/"(dbfile:run-id->dbname run-id)))
+
+(define (db:dbname->path apath dbname)
+ (conc apath"/"dbname))
+
+(define (dbfile:run-id->dbname run-id)
+ (cond
+ ((number? run-id) (conc ".db/" (modulo run-id 100) ".db"))
+ ((not run-id) (conc ".db/main.db"))
+ (else 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.
+;;
+(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* ((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* 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
+ (let* ((newsubdb (make-dbr:subdb)))
+ (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
+ (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb)
+ newsubdb))))
+
+(define (dbfile:get-subdb dbstruct run-id)
+ (let* ((dbfname (dbfile:run-id->dbname run-id)))
+ (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f)))
+
+(define (dbfile:set-subdb dbstruct run-id subdb)
+ (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb))
+
+;; Get/open a database
+;; if run-id => get run specific db
+;; if #f => get main db
+;; 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-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)))
+
+;; set up a subdb
+;;
+(define (dbfile:init-subdb dbstruct run-id init-proc)
+ (let* ((dbname (dbfile:run-id->dbname run-id))
+ (areapath (dbr:dbstruct-areapath dbstruct))
+ (tmppath (dbr:dbstruct-tmppath dbstruct))
+ (mtdbpath (dbfile:run-id->path areapath run-id))
+ (tmpdbpath (dbfile:run-id->path tmppath run-id))
+ (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc))
+ (newsubdb (make-dbr:subdb dbname: dbname
+ mtdbfile: mtdbpath
+ tmpdbfile: tmpdbpath
+ mtdbdat: mtdbdat)))
+ (dbfile:set-subdb dbstruct run-id newsubdb)
+ newsubdb)) ;; return the new subdb - but shouldn't really use it
+
+;; returns dbdat with dbh and dbfilepath
+;; 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
+ (begin
+ (dbfile:init-subdb dbstruct run-id init-proc)
+ (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 (dbfile: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-sqlite3-db dbpath init-proc)
+ (let* ((dbexists (file-exists? dbpath))
+ (write-access (file-write-access? dbpath))
+ (db (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath)
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
+ ;; (init-proc db)
+ (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 (dbfile: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
+;;======================================================================
+
+;; 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 (dbfile:cautious-open-database fname init-proc #!optional (tries-left 10))
+ (let* ((lock-file (conc fname".lock"))
+ (retry (lambda ()
+ (thread-sleep! 1.1)
+ (if (> tries-left 0)
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
+ (assert (>= tries-left 0) (conc "FATAL: Five attempts in dbfile:cautious-open-database of "fname", giving up."))
+ (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file)))
+ (begin
+ (dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in 1 second.")
+ (thread-sleep! 1)
+ (if (eq? tries-left 2)
+ (begin
+ (dbfile:print-err "INFO: stealing the lock "lock-file)
+ (delete-file lock-file)))
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
+ (let* ((db-exists (file-exists? fname))
+ (result (condition-case
+ (let* ((db (sqlite3:open-database fname)))
+ (if (and init-proc (not db-exists))
+ (init-proc db))
+ 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)))))
+ (if (file-write-access? fname)
+ (dbfile:simple-file-release-lock lock-file)
+ )
+ result))))
+
+
+(define (dbfile:open-no-sync-db dbpath)
+ (if *no-sync-db*
+ *no-sync-db*
+ (begin
+ (if (not (file-exists? dbpath))
+ (create-directory dbpath #t))
+ (let* ((dbname (conc dbpath "/no-sync.db"))
+ (db-exists (file-exists? dbname))
+ (init-proc (lambda (db)
+ (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));"))
+ )))
+ (db (dbfile:cautious-open-database dbname init-proc))) ;; (sqlite3:open-database dbname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ ;;(sqlite3:execute db "PRAGMA journal_mode=WAL;")
+ (set! *no-sync-db* db)
+ db))))
+
+(define (db:no-sync-set db 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 "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
+ "SELECT val FROM no_sync_metadat WHERE var=?;"
+ var)
+ (if res
+ (let ((newres (if (string? res)
+ (string->number res)
+ #f)))
+ (if newres
+ newres
+ res))
+ res)))
+
+;; transaction protected lock aquisition
+;; 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 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))))))
+
+
+;;======================================================================
+;; 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 modification 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 (dbfile: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))
+ (dbfile:simple-file-lock fname expire-time: expire-time))
+ #f)
+ (let ((key-string (conc (get-host-name) "-" (current-process-id)))
+ (oup (open-output-file fname)))
+ (with-output-to-port
+ oup
+ (lambda ()
+ (print key-string)))
+ (close-output-port oup)
+ #;(with-output-to-file fname ;; bizarre. with-output-to-file does not seem to be cleaning up after itself.
+ (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 (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
+ (let ((end-time (+ expire-time (current-seconds))))
+ (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time)))
+ (if got-lock
+ #t
+ (if (> end-time (current-seconds))
+ (begin
+ (thread-sleep! 3)
+ (loop (dbfile:simple-file-lock fname expire-time: expire-time)))
+ #f)))))
+
+(define (dbfile:simple-file-release-lock fname)
+ (handle-exceptions
+ exn
+ #f ;; I don't really care why this failed (at least for now)
+ (delete-file* fname)))
+
+
+)