| ︙ | | |
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
-
+
|
;;
(define (db:lock-create-open fname initproc)
;; (if (file-exists? fname)
;; (let ((db (sqlite3:open-database fname)))
;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
;; db)
(let* ((parent-dir (pathname-directory fname))
(let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
(dir-writable (file-write-access? parent-dir))
(file-exists (file-exists? fname))
(file-write (if file-exists
(file-write-access? fname)
dir-writable )))
(if file-write ;; dir-writable
(let (;; (lock (obtain-dot-lock fname 1 5 10))
|
| ︙ | | |
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
|
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
|
-
+
-
+
|
(begin
(dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ...
db)
(begin
(dbr:dbstruct-inmem-set! dbstruct inmem)
;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
(db:sync-tables db:sync-tests-only db inmem)
(db:sync-tables db:sync-tests-only #f db inmem)
(db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve?
(dbr:dbstruct-refdb-set! dbstruct refdb)
(db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
(db:sync-tables db:sync-tests-only #f inmem refdb) ;; use inmem as the reference, don't read again from db
;; sync once more to deal with delays?
;; (db:sync-tables db:sync-tests-only db inmem)
;; (db:sync-tables db:sync-tests-only inmem refdb)
inmem)))))))
;; This routine creates the db if not already present. It is only called if the db is not already ls opened
;;
|
| ︙ | | |
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
-
-
+
+
|
(or *dbstruct-db*
(let ((dbstruct (db:setup #f local: #t)))
(set! *dbstruct-db* dbstruct)
dbstruct)))
;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db)
(let* ((dbpath (conc *toppath* "/megatest.db"))
(define (db:open-megatest-db #!key (path #f))
(let* ((dbpath (or path (conc *toppath* "/megatest.db")))
(dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
(db:initialize-run-id-db db))))
(write-access (file-write-access? dbpath)))
(if (and dbexists (not write-access))
|
| ︙ | | |
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
-
+
-
+
|
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
force-sync)
(begin
(db:delay-if-busy maindb)
(db:delay-if-busy olddb)
(let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
(let ((num-synced (db:sync-tables (db:sync-main-list maindb) #f maindb olddb)))
(dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
num-synced)
0))
(begin
;; this can occur when using local access (i.e. not in a server)
;; need a flag to turn it off.
;;
(debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized")
0))
;; any other runid is a run
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
force-sync)
(begin
(db:delay-if-busy rundb)
(db:delay-if-busy olddb)
(dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
(let ((num-synced (db:sync-tables db:sync-tests-only #f inmem refdb rundb olddb)))
;; (mutex-unlock! *http-mutex*)
num-synced)
(begin
;; (mutex-unlock! *http-mutex*)
0))))))
(define (db:close-main dbstruct)
|
| ︙ | | |
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
|
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
|
+
+
+
+
-
+
|
(finalize! db)
#t))))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
;; if last-update specified ("field-name" . time-in-seconds)
;; then sync only records where field-name >= time-in-seconds
;; IFF field-name exists
;;
(define (db:sync-tables tbls fromdb todb . slave-dbs)
(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
(mutex-lock! *db-sync-mutex*)
(handle-exceptions
exn
(begin
(mutex-unlock! *db-sync-mutex*)
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
|
| ︙ | | |
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
|
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
|
+
+
+
+
+
+
+
+
-
+
+
+
+
|
(numrecs (make-hash-table))
(start-time (current-milliseconds))
(tot-count 0))
(for-each ;; table
(lambda (tabledat)
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(use-last-update (if last-update
(if (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields))
(begin
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields
#f))
#f))
(num-fields (length fields))
(field->num (make-hash-table))
(num->field (apply vector (map car fields)))
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename ";"))
" FROM " tablename (if use-last-update ;; apply last-update criteria
(conc " " (car last-update) ">=" (cdr last-update))
"")
";"))
(full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
" VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
(fromdat '())
(fromdats '())
(totrecords 0)
(batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10")))
(todat (make-hash-table))
|
| ︙ | | |
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
|
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
|
+
-
+
|
fromdat-lst))
))
fromdats)
(sqlite3:finalize! stmth)))
(append (list todb) slave-dbs))))
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (or (debug:debug-mode 12)
(should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate.
(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
(if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
(for-each
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
(set! tot-count (+ tot-count count))
(if (> count 0)
|
| ︙ | | |
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
|
810
811
812
813
814
815
816
817
818
819
820
821
822
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
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
last_update INTEGER DEFAULT (strftime('%s','now')))")
(sqlite3:execute maindb "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;"))
(define *global-db-store* (make-hash-table))
(define (db:get-access-mode)
(if (args:get-arg "-use-db-cache") 'cached 'rmt))
;; Add db direct
;;
(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
(if (eq? access-mode 'cached)
(apply db:call-with-cached-db db-cmd params)
(apply rmt-cmd params)))
;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
;; (common:sync-to-megatest.db #t) ;; BUG!! DON'T LEAVE THIS HERE!
(if (and (hash-table-ref/default *global-db-store* target #f)
(>= (file-modification-time target)(file-modification-time source)))
(hash-table-ref *global-db-store* target)
(let* ((toppath (launch:setup))
(targ-db-last-mod (if (file-exists? target)
(file-modification-time target)
0))
(cache-db (or (hash-table-ref/default *global-db-store* target #f)
(db:open-megatest-db path: target)))
(source-db (db:open-megatest-db path: source))
(curr-time (current-seconds))
(res '())
(last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
(db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
(db:sync-tables db:sync-tests-only last-update source-db cache-db)
(hash-table-set! *global-db-store* target cache-db)
cache-db)))
;; call a proc with a cached db
;;
(define (db:call-with-cached-db proc . params)
;; first cache the db in /tmp
(let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
(fname (conc (common:get-area-path-signature) ".db"))
(cache-dir (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name) "/" cname-part)
(conc "/tmp/" (current-user-name) "-" cname-part)
(conc "/tmp/" (current-user-name) "_" cname-part)))))
;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
(if (not cache-dir)
(begin
(debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
(exit 1))
(let* ((cache-db (db:cache-for-read-only
(conc *toppath* "/megatest.db")
(conc cache-dir "/" fname)
use-last-update: #t)))
(apply proc cache-db params)
))))
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
;; 'adj-testids - move test-ids into correct ranges
;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db
;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db
;; 'closeall - close all opened dbs
;; 'schema - attempt to apply schema changes
;;
;; run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
(let* ((toppath (launch:setup))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
(mtdb (if toppath (db:open-megatest-db)))
|
| ︙ | | |
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
|
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
|
-
+
-
+
|
servers))
;; clear out junk records
;;
(if (member 'dejunk options)
(begin
(db:delay-if-busy mtdb)
(db:clean-up mtdb)))
(db:clean-up mtdb)))
;; adjust test-ids to fit into proper range
;;
(if (member 'adj-testids options)
(begin
(db:delay-if-busy mtdb)
(db:prep-megatest.db-for-migration mtdb)))
;; sync runs, test_meta etc.
;;
(if (member 'old2new options)
(begin
(db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
(db:sync-tables (db:sync-main-list mtdb) #f mtdb (db:get-db dbstruct #f))
(for-each
(lambda (run-id)
(db:delay-if-busy mtdb)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
(db:replace-test-records dbstruct run-id testrecs)
|
| ︙ | | |
877
878
879
880
881
882
883
884
885
886
887
888
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
|
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
985
986
987
988
989
990
991
992
|
+
-
-
-
-
+
+
+
+
-
+
-
+
|
(map
(lambda (run-id)
(thread-start!
(make-thread
(lambda ()
(let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
(frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
(if (member 'schema options)
(if (eq? run-id 0)
(let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
(db:patch-schema-maindb run-id maindb))
(db:patch-schema-rundb run-id frundb)))
(if (eq? run-id 0)
(let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
(db:patch-schema-maindb run-id maindb))
(db:patch-schema-rundb run-id frundb))))
(set! count (+ count 1))
(debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
all-run-ids))
;; Then sync and fix db's
(set! count 0)
(process-fork
(lambda ()
(map
(lambda (th)
(thread-join! th))
(map
(lambda (run-id)
(thread-start!
(make-thread
(lambda ()
(let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
(frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
(if (eq? run-id 0)
(let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
(db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb)
(db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb)
(set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
(begin
;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
(db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)
(db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb)
(db:clean-up-rundb (db:get-db fromdb run-id)))))
(set! count (+ count 1))
(debug:print 0 *default-log-port* "Finished clean up of "
(if (eq? run-id 0)
" main.db " (conc run-id ".db")) ", " count " of " total)))))
all-run-ids))))
|
| ︙ | | |