22
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
|
(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))
(module dbfile
*
(import scheme
chicken
data-structures
extras
matchable
(prefix sqlite3 sqlite3:)
posix posix-extras typed-records
srfi-18
srfi-1
srfi-69
stack
files
ports
hostinfo
commonmod
debugprint
)
;; parameters
;;
(define dbfile:testsuite-name (make-parameter #f))
(define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic
(define num-run-dbs (make-parameter 10)) ;; number of db's in .mtdb
(define dbfile:sync-method (make-parameter 'attach)) ;; 'attach or 'original
|
>
|
>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
22
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
92
93
94
95
96
97
98
99
100
101
102
103
|
(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))
(module dbfile
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
data-structures
extras
matchable
(prefix sqlite3 sqlite3:)
posix posix-extras typed-records
srfi-18
srfi-1
srfi-69
stack
files
ports
hostinfo
commonmod
debugprint
)
)
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
stack
system-information
commonmod
debugprint
)
(define file-write-access? file-writable?)
(define file-move move-file)
))
;; parameters
;;
(define dbfile:testsuite-name (make-parameter #f))
(define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic
(define num-run-dbs (make-parameter 10)) ;; number of db's in .mtdb
(define dbfile:sync-method (make-parameter 'attach)) ;; 'attach or 'original
|
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
|
;; just the filename
(define (dbfile:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
;; the path in MTRAH with the filename
(define (dbfile:run-id->dbname run-id)
(conc ".mtdb/"(dbfile:run-id->dbfname 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*
(dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized")
*dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard
(else
(let* ((dbstruct (make-dbr:dbstruct areapath: areapath tmppath: tmppath)))
(set! *dbstruct-dbs* dbstruct)
|
|
|
|
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
|
;; just the filename
(define (dbfile:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
;; the path in MTRAH with the filename
(define (dbfile:run-id->dbname run-id)
(conc (dbfile:run-id->dbfname 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 areapath tmppath)
(cond
(*dbstruct-dbs*
(dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized")
*dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard
(else
(let* ((dbstruct (make-dbr:dbstruct areapath: areapath tmppath: tmppath)))
(set! *dbstruct-dbs* dbstruct)
|
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
|
dbname TEXT,
mtversion TEXT,
reason TEXT DEFAULT 'none',
CONSTRAINT no_sync_processes UNIQUE (host,pid));"
))))))
(on-tmp (equal? (car (string-split dbpath "/")) "tmp"))
(db (if on-tmp
(dbfile:cautious-open-database dbname init-proc 0 "WAL" force-init: #t)
(dbfile:cautious-open-database dbname init-proc 0 #f force-init: #t)
;; (sqlite3:open-database dbname)
)))
(if on-tmp ;; done in cautious-open-database
(begin
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))))
db))
;; mtest processes registry calls
(define (dbfile:insert-or-update-process nsdb dat)
(let* ((host (procinf-host dat))
(pid (procinf-pid dat))
|
|
|
>
|
|
|
|
|
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
|
dbname TEXT,
mtversion TEXT,
reason TEXT DEFAULT 'none',
CONSTRAINT no_sync_processes UNIQUE (host,pid));"
))))))
(on-tmp (equal? (car (string-split dbpath "/")) "tmp"))
(db (if on-tmp
(dbfile:cautious-open-database dbname init-proc 1 "WAL" force-init: #t) ;; WAL MODE should use syncronous=1
;; (dbfile:cautious-open-database dbname init-proc 0 #f force-init: #t)
(dbfile:cautious-open-database dbname init-proc 0 "MEMORY" force-init: #t) ;; Journal mode = memory is fastest?
;; (sqlite3:open-database dbname)
)))
;; (if on-tmp ;; done in cautious-open-database
;; (begin
;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; why was this here when is is handled by cautious-open-database?
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) ;; ))
db))
;; mtest processes registry calls
(define (dbfile:insert-or-update-process nsdb dat)
(let* ((host (procinf-host dat))
(pid (procinf-pid dat))
|
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
|
(define (dbfile:register-process nsdb host port pid starttime endtime status purpose dbname mtversion)
(sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,endtime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?,?);"
host port pid starttime endtime status purpose dbname mtversion))
(define (dbfile:set-process-status nsdb host pid newstatus)
(sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid))
(define (dbfile:get-process-options nsdb purpose dbname)
(sqlite3:fold-row
;; host port pid starttime status mtversion
(lambda (res . row)
(cons row res))
'()
nsdb
"SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status='alive';"
purpose dbname))
(define (dbfile:get-process-info nsdb host pid)
(let ((res (sqlite3:fold-row
;; host port pid starttime status mtversion
(lambda (res . row)
(cons row res))
'()
nsdb
"SELECT host,port,pid,starttime,endtime,status,purpose,dbname,mtversion FROM processes WHERE host=? AND pid=?;"
host pid)))
(if (null? res)
#f
(car res))))
(define (dbfile:set-process-done nsdb host pid reason)
(sqlite3:execute nsdb "UPDATE processes SET status='ended',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid)
(dbfile:cleanup-old-entries nsdb))
(define (dbfile:cleanup-old-entries nsdb)
(sqlite3:execute nsdb "DELETE FROM process WHERE status='ended' AND endtime<?;" (- (current-seconds) (* 3600 48))))
;; other no-sync functions
(define (dbfile:with-no-sync-db dbpath proc)
(mutex-lock! *no-sync-db-mutex*)
(let* ((already-open *no-sync-db*)
(db (or already-open (dbfile:raw-open-no-sync-db dbpath)))
|
>
>
|
>
>
>
>
>
>
>
>
|
|
|
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
|
(define (dbfile:register-process nsdb host port pid starttime endtime status purpose dbname mtversion)
(sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,endtime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?,?);"
host port pid starttime endtime status purpose dbname mtversion))
(define (dbfile:set-process-status nsdb host pid newstatus)
(sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid))
;; as sorted should be stable. can use to choose "winner"
;;
(define (dbfile:get-process-options nsdb purpose dbname)
(sqlite3:fold-row
;; host port pid starttime status mtversion
(lambda (res . row)
(cons row res))
'()
nsdb
"SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status IN ('running','alive') ORDER BY starttime ASC,host,port;"
purpose dbname))
(define (dbfile:get-process-info nsdb host pid)
(let ((res (sqlite3:fold-row
;; host port pid starttime status mtversion
(lambda (res . row)
(cons row res))
'()
nsdb
"SELECT host,port,pid,starttime,endtime,status,purpose,dbname,mtversion FROM processes WHERE host=? AND pid=?;"
host pid)))
(if (null? res)
#f
(car res))))
(define (dbfile:row->procinf row)
(match row
((host port pid starttime endtime status mtversion)
(make-procinf host: host port: port pid: pid starttime: starttime endtime: endtime status: status mtversion: mtversion))
(else
(debug:print 0 *default-log-port* "ERROR: row "row" did not match host,port,pid,starttime,endtime,status,mtversion")
#f)))
(define (dbfile:set-process-done nsdb host pid reason)
(sqlite3:execute nsdb "UPDATE processes SET status='done',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid)
(dbfile:cleanup-old-entries nsdb))
(define (dbfile:cleanup-old-entries nsdb)
(sqlite3:execute nsdb "DELETE FROM process WHERE status='done' AND endtime<?;" (- (current-seconds) (* 3600 48))))
;; other no-sync functions
(define (dbfile:with-no-sync-db dbpath proc)
(mutex-lock! *no-sync-db-mutex*)
(let* ((already-open *no-sync-db*)
(db (or already-open (dbfile:raw-open-no-sync-db dbpath)))
|