| ︙ | | | ︙ | |
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
(use (srfi 18) extras tcp stack) ;; RADT => use of require-extension?
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:)) ;; RADT => prefix??
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
|
|
|
|
|
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
(use (srfi 18) extras tcp stack)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
|
| ︙ | | | ︙ | |
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
(db:dbdat-get-db dbdat)
dbstruct))
(use-mutex (> *api-process-request-count* 25)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (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
(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
(exit 50))
|
|
|
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
(db:dbdat-get-db dbdat)
dbstruct))
(use-mutex (> *api-process-request-count* 25)))
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
(handle-exceptions
exn
(begin
(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
(exit 50))
|
| ︙ | | | ︙ | |
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
|
(define (db:multi-db-sync dbstruct . options)
(if (not (launch:setup))
(debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
(tdbdat (tasks:open-db))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
;; kill servers
(if (member 'killservers options)
(for-each
(lambda (server)
(tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration")
(tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
servers))
;; clear out junk records
;;
(if (member 'dejunk options)
(begin
(db:delay-if-busy mtdb) ;; ok to delay on mtdb
|
|
|
|
>
|
|
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
|
(define (db:multi-db-sync dbstruct . options)
(if (not (launch:setup))
(debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
;; (tdbdat (tasks:open-db))
(servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
;; kill servers
(if (member 'killservers options)
(for-each
(lambda (server)
(match-let (((mod-time host port start-time pid) server))
(if (and host pid)
(tasks:kill-server host pid))))
servers))
;; clear out junk records
;;
(if (member 'dejunk options)
(begin
(db:delay-if-busy mtdb) ;; ok to delay on mtdb
|
| ︙ | | | ︙ | |
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
|
(lambda (run-id)
(set! run-ids (cons run-id run-ids)))
db
"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
(reverse run-ids)))))
;; get some basic run stats
;;
;; ( (runname (( state count ) ... ))
;; ( ...
(define (db:get-run-stats dbstruct)
(let* ((totals (make-hash-table))
(curr (make-hash-table))
(res '())
(runs-info '()))
;; First get all the runname/run-ids
(db:with-db
|
>
>
|
>
|
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
|
(lambda (run-id)
(set! run-ids (cons run-id run-ids)))
db
"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
(reverse run-ids)))))
;; get some basic run stats
;;
;; data structure:
;;
;; ( (runname (( state count ) ... ))
;; ( ...
;;
(define (db:get-run-stats dbstruct)
(let* ((totals (make-hash-table))
(curr (make-hash-table))
(res '())
(runs-info '()))
;; First get all the runname/run-ids
(db:with-db
|
| ︙ | | | ︙ | |