Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -107,22 +107,25 @@ ;; TASKS tasks-add tasks-set-state-given-param-key )) -;; These are called by the server on recipt of /api calls +;; These are called by the server on receipt of /api calls ;; - 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) (handle-exceptions exn (let ((call-chain (get-call-chain))) + (debug:print 0 *default-log-port* "------------------------------") (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer") + (debug:print 0 *default-log-port* "dbstruct="dbstruct" dat="dat) (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "------------------------------") (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t @@ -294,6 +297,5 @@ ;; (number? res) ;; (boolean? res)) ;; res ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) (db:obj->string res transport: 'http))) - Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -142,13 +142,16 @@ (if (common:low-noise-print 120 (conc "parallel-api-requests" *max-api-process-requests*)) (debug:print-info 0 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) (handle-exceptions exn (begin + (debug:print 0 *default-log-port* "------------------------------") (print-call-chain (current-error-port)) (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) ;; there is no recovering at this time. exit + (set! *time-to-exit* #t) + (debug:print 0 *default-log-port* "------------------------------") (exit 50)) (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let ((res (apply proc db params))) (if use-mutex (mutex-unlock! *db-with-db-mutex*)) ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) @@ -349,13 +352,42 @@ ;; (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 ((tdbs (map db:dbdat-get-db (stack->list (dbr:dbstruct-dbstack dbstruct)))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (map sqlite3:finalize! tdbs) - (if mdb (sqlite3:finalize! mdb)) - (if rdb (sqlite3:finalize! rdb)))))) + (map + (lambda (db) + (handle-exception + exn + (begin + (debug:print 0 *default-log-port* "------------------------------") + (debug:print 0 *default-log-port* "EXCEPTION: stack db database finalize failed: "db) + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "------------------------------")) + (sqlite3:finalize! db))) + tdbs) + + (handle-exception + exn + (begin + (debug:print 0 *default-log-port* "------------------------------") + (debug:print 0 *default-log-port* "EXCEPTION: mdb database finalize failed.") + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "------------------------------")) + (if mdb (sqlite3:finalize! mdb))) + + (handle-exception + exn + (begin + (debug:print 0 *default-log-port* "------------------------------") + (debug:print 0 *default-log-port* "EXCEPTION: rdb database finalize failed.") + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "------------------------------")) + (if rdb (sqlite3:finalize! rdb))))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -1965,11 +1997,11 @@ ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; (define (db:update-run-stats dbstruct run-id stats) - ;; (mutex-lock! *db-transaction-mutex*) + (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f @@ -1987,11 +2019,11 @@ (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) (apply sqlite3:execute stmt2 run-id dat)) stats))))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2) - ;; (mutex-unlock! *db-transaction-mutex*) + (mutex-unlock! *db-transaction-mutex*) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct @@ -3185,11 +3217,11 @@ (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (db:test-get-id tl-testdat))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbstruct 'set-test-start-time (list test-id))) - ;; (mutex-lock! *db-transaction-mutex*) + (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f (lambda (db) (let ((tr-res (sqlite3:with-transaction @@ -3223,11 +3255,11 @@ (newstatus (if (> bad-not-started 0) "CHECK" (car all-curr-statuses)))) ;; (print "Setting toplevel to: " newstate "/" newstatus) (db:test-set-state-status dbstruct run-id tl-test-id newstate newstatus #f))))))) - ;; (mutex-unlock! *db-transaction-mutex*) + (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) tr-res))))) (define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)