| ︙ | | | ︙ | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses debugprint))
(module dbmod
*
(import scheme
chicken
data-structures
extras
files
(prefix sqlite3 sqlite3:)
matchable
posix
debugprint
)
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
(define (dbmod:get-dbdir dbstruct)
(let* ((areapath (dbr:dbstruct-areapath dbstruct))
(dbdir (conc areapath"/.mtdb")))
(if (and (file-write-access? areapath)
(not (file-exists? dbdir)))
(create-directory dbdir))
dbdir))
(define (dbmod:run-id->full-dbfname dbstruct run-id)
(conc (dbmod:get-dbdir dbstruct
run-id
)"/"(dbmod:run-id->dbfname run-id)))
;;======================================================================
;; Read-only cachedb cached direct from disk method
;;======================================================================
(define *dbmod:nfs-db-handles* (make-hash-table)) ;; dbfname -> dbstruct
|
|
>
>
|
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
|
<
|
<
<
<
|
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses debugprint))
(module dbmod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
data-structures
extras
files
posix
))
(chicken-5
(import chicken.base
chicken.condition
chicken.file
chicken.pathname
chicken.process
chicken.sort
chicken.string
chicken.time
)
(define file-read-access? file-readable?)
(define file-copy copy-file)
))
(import format
(prefix sqlite3 sqlite3:)
matchable
typed-records
srfi-1
srfi-18
srfi-69
commonmod
dbfile
debugprint)
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
(define (dbmod:get-dbdir dbstruct)
(let* ((areapath (dbr:dbstruct-areapath dbstruct))
(dbdir (conc areapath"/.mtdb")))
(if (and (file-write-access? areapath)
(not (file-exists? dbdir)))
(create-directory dbdir))
dbdir))
(define (dbmod:run-id->full-dbfname dbstruct run-id)
(conc (dbmod:get-dbdir dbstruct)
"/"(dbmod:run-id->dbfname run-id)))
;;======================================================================
;; Read-only cachedb cached direct from disk method
;;======================================================================
(define *dbmod:nfs-db-handles* (make-hash-table)) ;; dbfname -> dbstruct
|
| ︙ | | | ︙ | |
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
;;======================================================================
;; The cachedb one-db file per server method goes in here
;;======================================================================
;; NOTE: the r/w is now w/r, #t=db modified by query, #f=db NOT modified by query
(define (dbmod:with-db dbstruct run-id w/r proc params)
(let* ((use-mutex (or (and w/r ;; use the mutex on queries that modify the db and for sync to disk
(> *api-process-request-count* 5)) ;; when writes are happening throttle more
(> *api-process-request-count* 50)))
(dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc)))
(dbh (dbr:dbdat-dbh dbdat)) ;; this will be the cachedb handle
(dbfile (dbr:dbdat-dbfile dbdat)))
;; if nfs mode do a sync if delta > 2
(let* ((last-update (dbr:dbstruct-last-update dbstruct))
(sync-proc (dbr:dbstruct-sync-proc dbstruct))
(curr-secs (current-seconds)))
(if (> (- curr-secs last-update) 5)
(begin
(sync-proc last-update)
;; MOVE THIS CALL TO INSIDE THE sync-proc CALL
(dbr:dbstruct-last-update-set! dbstruct curr-secs)
|
|
|
|
|
|
|
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
;;======================================================================
;; The cachedb one-db file per server method goes in here
;;======================================================================
;; NOTE: the r/w is now w/r, #t=db modified by query, #f=db NOT modified by query
(define (dbmod:with-db dbstruct run-id w/r proc params)
(let* ((use-mutex w/r) ;; (or (and w/r ;; use the mutex on queries that modify the db and for sync to disk
;; (> *api-process-request-count* 5)) ;; when writes are happening throttle more
;; (> *api-process-request-count* 50)))
(dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc)))
(dbh (dbr:dbdat-dbh dbdat)) ;; this will be the cachedb handle
(dbfile (dbr:dbdat-dbfile dbdat)))
;; if nfs mode do a sync if delta > 2
#;(let* ((last-update (dbr:dbstruct-last-update dbstruct))
;; (sync-proc (dbr:dbstruct-sync-proc dbstruct))
(curr-secs (current-seconds)))
(if (> (- curr-secs last-update) 5)
(begin
(sync-proc last-update)
;; MOVE THIS CALL TO INSIDE THE sync-proc CALL
(dbr:dbstruct-last-update-set! dbstruct curr-secs)
|
| ︙ | | | ︙ | |
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.")
(thread-sleep! 1)
(loop (- count 1)))
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.")
(exit 1))))
(exn ()
(dbfile:print-err exn "ERROR: Unknown error with db for run-id "
run-id", message: "
((condition-property-accessor 'exn 'message) exn)
", details: "(condition->list exn))
(exit 2))))))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
res)))
|
|
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.")
(thread-sleep! 1)
(loop (- count 1)))
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.")
(exit 1))))
(exn ()
(dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", message: "
run-id", message: "
((condition-property-accessor 'exn 'message) exn)
", details: "(condition->list exn))
(exit 2))))))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
res)))
|
| ︙ | | | ︙ | |
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
|
(dbr:dbstruct-dbfile-set! dbstruct dbfullname)
(dbr:dbstruct-dbtmpname-set! dbstruct tmpdb)
(dbr:dbstruct-dbfname-set! dbstruct dbfname)
(dbr:dbstruct-sync-proc-set! dbstruct
(lambda (last-update)
(if *sync-in-progress*
(debug:print 0 *default-log-port* "WARNING: overlapping calls to sync to disk")
(let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log"))
(sync-cmd (if (eq? syncdir 'todisk)
(conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&")
(conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&")))
(synclock-file (conc dbfullname".lock"))
(syncer-running-file (conc dbfullname"-sync-running"))
(synclock-mod-time (if (file-exists? synclock-file)
(handle-exceptions
exn
#f
(file-modification-time synclock-file))
#f))
(thethread (lambda ()
(thread-start!
(make-thread
(lambda ()
(set! *sync-in-progress* #t)
(debug:print 0 *default-log-port* "Running "sync-cmd)
(if (file-exists? syncer-running-file)
(debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.")
(system sync-cmd))
(set! *sync-in-progress* #f)))))))
(if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk
(file-modification-time tmpdb)
(file-modification-time dbfullname))
(debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
(if synclock-mod-time
(if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
(begin
(handle-exceptions
exn
#f
(begin
(debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it")
(delete-file synclock-file)
)
)
(thethread))
(debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
(thethread)))))))
;; (dbmod:sync-tables tables #f db cachedb)
;;
(thread-sleep! 1) ;; let things settle before syncing in needed data
(dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb
(dbr:dbstruct-last-update-set! dbstruct (+ (current-seconds) -10)) ;; should this be offset back in time by one second?
dbstruct))
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
>
|
>
>
>
>
|
<
>
>
|
<
<
<
<
|
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
(dbr:dbstruct-dbfile-set! dbstruct dbfullname)
(dbr:dbstruct-dbtmpname-set! dbstruct tmpdb)
(dbr:dbstruct-dbfname-set! dbstruct dbfname)
(dbr:dbstruct-sync-proc-set! dbstruct
(lambda (last-update)
(if *sync-in-progress*
(debug:print 0 *default-log-port* "WARNING: overlapping calls to sync to disk")
(begin
;; turn off writes - send busy or block?
;; call db2db internally
;; turn writes back on
;;
(set! *api-halt-writes* #t) ;; do we need a mutex?
;; (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)
(debug:print-info 2 *default-log-port* "Internal sync running from "tmpdb" to "dbfullname)
(dbmod:db-to-db-sync tmpdb dbfullname last-update (dbfile:db-init-proc) keys)
(set! *api-halt-writes* #f)
))))
;; (dbmod:sync-tables tables #f db cachedb)
;;
(thread-sleep! 1) ;; let things settle before syncing in needed data
(dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb
(dbr:dbstruct-last-update-set! dbstruct (+ (current-seconds) -10)) ;; should this be offset back in time by one second?
dbstruct))
|
| ︙ | | | ︙ | |
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
|
(stmt3 (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;"))
(start-ms (current-milliseconds)))
(debug:print 0 *default-log-port* "stmt3="stmt3)
(if (sqlite3:auto-committing? dbh1)
(begin
(handle-exceptions
exn
(debug:print 0 *default-log-port* "Transaction update of "table" failed.")
(sqlite3:with-transaction
dbh1
(lambda ()
(sqlite3:execute dbh1 stmt1) ;; get all new rows
#;(if (member "last_update" fields)
(sqlite3:execute dbh1 stmt8)) ;; get all updated rows
|
|
|
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
|
(stmt3 (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;"))
(start-ms (current-milliseconds)))
(debug:print 0 *default-log-port* "stmt3="stmt3)
(if (sqlite3:auto-committing? dbh1)
(begin
(handle-exceptions
exn
(debug:print 0 *default-log-port* "Transaction update of "table" failed. "(condition->list exn))
(sqlite3:with-transaction
dbh1
(lambda ()
(sqlite3:execute dbh1 stmt1) ;; get all new rows
#;(if (member "last_update" fields)
(sqlite3:execute dbh1 stmt8)) ;; get all updated rows
|
| ︙ | | | ︙ | |
900
901
902
903
904
905
906
907
|
(sdb (dbmod:safely-open-db src-db init-proc #t))
(ddb (dbmod:safely-open-db dest-db init-proc d-wr))
(res (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todisk keys)))
(sqlite3:finalize! sdb)
(sqlite3:finalize! ddb)
res)))
#f))
)
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
|
(sdb (dbmod:safely-open-db src-db init-proc #t))
(ddb (dbmod:safely-open-db dest-db init-proc d-wr))
(res (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todisk keys)))
(sqlite3:finalize! sdb)
(sqlite3:finalize! ddb)
res)))
#f))
;; ======================================================================
;; dbstats
;;======================================================================
;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~8-d~20-d~20,2-f")) ;; "~20,2-f"
(debug:print 0 *default-log-port* "DB Stats\n========")
(debug:print 0 *default-log-port* (format #f "~40a~8a~20a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let* ((dat (hash-table-ref *db-stats* cmd))
(count (dbstat-cnt dat))
(tottime (dbstat-tottime dat)))
(debug:print 0 *default-log-port*
(format #f fmtstr cmd count tottime
(/ tottime count)))))
(sort (hash-table-keys *db-stats*)
(lambda (a b)
(> (dbstat-tottime (hash-table-ref *db-stats* a))
(dbstat-tottime (hash-table-ref *db-stats* b))))))))
(defstruct dbstat
(cnt 0)
(tottime 0))
(define (db:add-stats cmd run-id params delta)
(let* ((modified-cmd (if (eq? cmd 'general-call)
(string->symbol (conc "general-call-" (car params)))
cmd))
(rec (hash-table-ref/default *db-stats* modified-cmd #f)))
(if (not rec)
(let ((new-rec (make-dbstat)))
(hash-table-set! *db-stats* modified-cmd new-rec)
(set! rec new-rec)))
(dbstat-cnt-set! rec (+ (dbstat-cnt rec) 1))
(dbstat-tottime-set! rec (+ (dbstat-tottime rec) delta))))
)
;; ATTIC
#;(let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log"))
(sync-cmd (if (eq? syncdir 'todisk)
(conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&")
(conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&")))
(synclock-file (conc dbfullname".lock"))
(syncer-running-file (conc dbfullname"-sync-running"))
(synclock-mod-time (if (file-exists? synclock-file)
(handle-exceptions
exn
#f
(file-modification-time synclock-file))
#f))
(thethread (lambda ()
(thread-start!
(make-thread
(lambda ()
(set! *sync-in-progress* #t)
(debug:print-info "Running "sync-cmd)
(if (file-exists? syncer-running-file)
(debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.")
(system sync-cmd))
(set! *sync-in-progress* #f)))))))
(if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk
(file-modification-time tmpdb)
(file-modification-time dbfullname))
(debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
(if synclock-mod-time
(if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
(begin
(handle-exceptions
exn
#f
(begin
(debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it")
(delete-file synclock-file)
)
)
(thethread))
(debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
(thethread))))
|