Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -459,11 +459,11 @@
(print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
(thread-sleep! 3)
(sqlite3:interrupt! db)
(db:safely-close-sqlite3-db db stmtcache try-num: (- try-num 1)))
(if (sqlite3:database? db)
- (let* ((stmts (hash-table-ref/default stmt-cache db #f)))
+ (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)
#f))))
@@ -826,16 +826,17 @@
)
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
- (let* ((db (db:dbdat-get-db targdb))
- (drp-trigger (if (member "last_update" field-names)
- (db:drop-trigger db tablename)
- #f))
- (is-trigger-dropped (if (member "last_update" field-names)
- (db:is-trigger-dropped db tablename) #f))
+ (let* ((db (db:dbdat-get-db targdb))
+ (drp-trigger (if (member "last_update" field-names)
+ (db:drop-trigger db tablename)
+ #f))
+ (is-trigger-dropped (if (member "last_update" field-names)
+ (db:is-trigger-dropped db tablename)
+ #f))
(stmth (sqlite3:prepare db full-ins)))
;; (db:delay-if-busy targdb) ;; NO WAITING
(if (member "last_update" field-names)
(debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped))
(for-each
@@ -1224,29 +1225,29 @@
FOR EACH ROW
BEGIN
UPDATE runs SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )
- (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
FOR EACH ROW
BEGIN
UPDATE run_stats SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )
- (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
FOR EACH ROW
BEGIN
UPDATE tests SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )
- (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
FOR EACH ROW
BEGIN
UPDATE test_steps SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )
- (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
FOR EACH ROW
BEGIN
UPDATE test_data SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )))
@@ -1261,40 +1262,43 @@
(for-each (lambda (key)
(sqlite3:execute db (cadr key)))
db:trigger-list))
(define (db:drop-all-triggers dbstruct)
-(db:with-db
+ (db:with-db
dbstruct #f #f
(lambda (db)
-(db:drop-triggers db))))
+ (db:drop-triggers db))))
(define (db:is-trigger-dropped db tbl-name)
- (let* ((trigger-name (if (equal? tbl-name "test_steps")
- "update_teststeps_trigger"
- (conc "update_" tbl-name "_trigger"))))
- (sqlite3:for-each-row
- (lambda (name)
- ;(print name)
- (set! res (vector name)))
- db
- "select name from sqlite_master where type = 'trigger' ;"
- )))
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger")))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (name)
+ (if (equal? name trigger-name)
+ (set! res #t)))
+ db
+ "SELECT name FROM sqlite_master WHERE type = 'trigger' ;"
+ )))
(define (db:drop-triggers db)
- (for-each (lambda (key)
- (sqlite3:execute db (conc "drop trigger " (car key))))
- db:trigger-list))
+ (for-each
+ (lambda (key)
+ (sqlite3:execute db (conc "drop trigger if exists " (car key))))
+ db:trigger-list))
(define (db:drop-trigger db tbl-name)
- (let* ((trigger-name (if (equal? tbl-name "test_steps")
- "update_teststeps_trigger"
- (conc "update_" tbl-name "_trigger"))))
- (for-each (lambda (key)
- (if (equal? (car key) trigger-name)
- (sqlite3:execute db (conc "drop trigger " trigger-name))))
- db:trigger-list)))
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each
+ (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
+ db:trigger-list)))
(define (db:create-trigger db tbl-name)
(let* ((trigger-name (if (equal? tbl-name "test_steps")
"update_teststeps_trigger"
(conc "update_" tbl-name "_trigger"))))
@@ -2180,12 +2184,12 @@
(if newres
newres
res))
res)))
-(define (db:no-sync-close-db db stmtcache)
- (db:safely-close-sqlite3-db db stmtcache))
+(define (db:no-sync-close-db db stmt-cache)
+ (db:safely-close-sqlite3-db db stmt-cache))
;; transaction protected lock aquisition
;; either:
;; fails returns (#f . lock-creation-time)
;; succeeds (returns (#t . lock-creation-time)
@@ -2196,13 +2200,14 @@
(sqlite3:with-transaction
db
(lambda ()
(handle-exceptions
exn
- (let ((lock-time (current-seconds)))
- (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
- `(#t . ,lock-time))
+ (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)))))))
;; use a global for some primitive caching, it is just silly to
@@ -2238,11 +2243,12 @@
(n 0))
(if (equal? hed field)
(handle-exceptions
exn
(begin
- (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field ", exn=" exn)
+ (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
+ row " header=" header " field=" field ", exn=" exn)
#f)
(vector-ref row n))
(if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))
;; Accessors for the header/data structure
@@ -4479,11 +4485,11 @@
(db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
(dbfj (conc dbpath "-journal")))
(if (handle-exceptions
exn
(begin
- (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj)
+ (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
(thread-sleep! 1)
(db:delay-if-busy count (- count 1)))
(common:file-exists? dbfj))
(case count
((6)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -324,22 +324,21 @@
;;
(define (server:wait-for-server-start-last-flag areapath)
(let* ((start-flag (conc areapath "/logs/server-start-last")))
(if (file-exists? start-flag)
(let* ((fmodtime (file-modification-time start-flag))
- (reftime (+ 3 (random 5)))
- (delta (- (current-seconds) fmodtime)))
- (if (> delta reftime) ;; good enough
- (begin
- (debug:print-info 0 *default-log-port* "Ready to start server, last start: "
- fmodtime ", delta: " delta ", reftime: " reftime)
- (system (conc "touch " start-flag))) ;; lazy but safe
- (begin
+ (reftime (+ 2 (random 3)))
+ (delta (- (current-seconds) fmodtime))
+ (all-go (> delta reftime)))
+ (if all-go
+ #t ;; (system (conc "touch " start-flag)) ;; lazy but safe
+ (begin
+ (debug:print-info 0 *default-log-port* "Gating server start, last start: "
+ fmodtime ", delta: " delta ", reftime: " reftime ", all-go=" all-go)
(thread-sleep! 5)
(server:wait-for-server-start-last-flag areapath))))
- (system (conc "touch " start-flag)))))
-
+ #;(system (conc "touch " start-flag)))))
;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
;;
(define (server:kind-run areapath)
@@ -356,12 +355,13 @@
((2) 300)
(else 600))
(random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
(lock-file (conc areapath "/logs/server-start.lock")))
(if (> (- (current-seconds) when-run) run-delay)
- (begin
+ (let* ((start-flag (conc areapath "/logs/server-start-last")))
(common:simple-file-lock-and-wait lock-file expire-time: 15)
+ (system (conc "touch " start-flag)) ;; lazy but safe
(server:run areapath)
(thread-sleep! 2) ;; don't release the lock for at least a few seconds
(common:simple-file-release-lock lock-file)))
(hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds))))))