;;======================================================================
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
(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/<stuff>/.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 (not (dbfile:simple-file-lock lock-file))
(begin
(dbfile:print-err "INFO: lock file "lock-file" exists, trying again in 1 second.")
(thread-sleep! 1)
(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)))))
(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)))
)