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
|
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
|
+
+
-
+
-
+
-
+
-
-
+
+
-
+
|
(debug:print-info 13 log-port "Done db:open-db")
;; (set! *dbstruct-db* dbstruct)
alldat))))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
(let ((toppath (alldat-areapath alldat))
(configdat (alldat-mtconfig alldat))
(let ((log-port (alldat-log-port alldat))
(let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
(let* ((max-stale-tmp (configf:lookup-number configdat "server" "filling-db-max-stale-seconds" default: 10))
(dbpath (common:get-db-tmp-area alldat)) ;; path to tmp db area
(dbexists (common:file-exists? dbpath))
(dbexists (file-exists? dbpath))
(tmpdbfname (conc dbpath "/megatest.db"))
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
(dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (file-exists? (conc toppath "/megatest.db")))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc toppath "/megatest.db")) #f))
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? mtdbpath))
|
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
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
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
|
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
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
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
|
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
-
-
-
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
-
-
-
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; 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 alldat tbls last-update fromdb todb . slave-dbs)
(let* ((configdat (alldat-mtconfig alldat)))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
(for-each (lambda (dbdat)
(let ((dbpath (db:dbdat-get-path dbdat)))
(debug:print 0 *default-log-port* " dbpath: " dbpath)
(if (not (db:repair-db dbdat))
(begin
(debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
(exit)))))
(cons todb slave-dbs))
0)
;; this is the work to be done
(cond
((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
-1)
((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
-2)
((not (sqlite3:database? (db:dbdat-get-db fromdb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
-3)
((not (sqlite3:database? (db:dbdat-get-db todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
-4)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
(for-each (lambda (dbdat)
(let ((dbpath (db:dbdat-get-path dbdat)))
(debug:print 0 *default-log-port* " dbpath: " dbpath)
(if (not (db:repair-db dbdat))
(begin
(debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
(exit)))))
(cons todb slave-dbs))
0)
;; this is the work to be done
(cond
((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
-1)
((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
-2)
((not (sqlite3:database? (db:dbdat-get-db fromdb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
-3)
((not (sqlite3:database? (db:dbdat-get-db todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
-4)
((not (file-write-access? (db:dbdat-get-path todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
-5)
((not (null? (let ((readonly-slave-dbs
(filter
(lambda (dbdat)
(not (file-write-access? (db:dbdat-get-path todb))))
slave-dbs)))
(for-each
(lambda (bad-dbdat)
(debug:print-error
0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
readonly-slave-dbs)
readonly-slave-dbs))) -6)
(else
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
(tot-count 0))
(for-each ;; table
(lambda (tabledat)
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(has-last-update (member "last_update" fields))
(use-last-update (cond
((and has-last-update
(member "last_update" fields))
#t) ;; if given a number, just use it for all fields
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields))) #t)
(last-update
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
#f)
(else
#f)))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
(if (number? last-update)
last-update
(cdr last-update))
#f))
(last-update-field (if use-last-update
(if (number? last-update)
"last_update"
(car last-update))
#f))
(num-fields (length fields))
(field->num (make-hash-table))
(num->field (apply vector (map car fields))) ;; BBHERE
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename (if use-last-update ;; apply last-update criteria
(conc " WHERE " last-update-field " >= " last-update-value)
"")
";"))
(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") "100")))
(todat (make-hash-table))
(count 0)
((not (file-write-access? (db:dbdat-get-path todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
-5)
((not (null? (let ((readonly-slave-dbs
(filter
(lambda (dbdat)
(not (file-write-access? (db:dbdat-get-path todb))))
slave-dbs)))
(for-each
(lambda (bad-dbdat)
(debug:print-error
0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
readonly-slave-dbs)
readonly-slave-dbs))) -6)
(else
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
(tot-count 0))
(for-each ;; table
(lambda (tabledat)
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(has-last-update (member "last_update" fields))
(use-last-update (cond
((and has-last-update
(member "last_update" fields))
#t) ;; if given a number, just use it for all fields
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields))) #t)
(last-update
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
#f)
(else
#f)))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
(if (number? last-update)
last-update
(cdr last-update))
#f))
(last-update-field (if use-last-update
(if (number? last-update)
"last_update"
(car last-update))
#f))
(num-fields (length fields))
(field->num (make-hash-table))
(num->field (apply vector (map car fields))) ;; BBHERE
(full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
" FROM " tablename (if use-last-update ;; apply last-update criteria
(conc " WHERE " last-update-field " >= " last-update-value)
"")
";"))
(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") "100")))
(todat (make-hash-table))
(count 0)
(delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
)
;; set up the field->num table
(for-each
(lambda (field)
(hash-table-set! field->num field count)
(set! count (+ count 1)))
fields)
;; set up the field->num table
(for-each
(lambda (field)
(hash-table-set! field->num field count)
(set! count (+ count 1)))
fields)
;; read the source table
(sqlite3:for-each-row
(lambda (a . b)
(set! fromdat (cons (apply vector a b) fromdat))
(if (> (length fromdat) batch-len)
(begin
(set! fromdats (cons fromdat fromdats))
(set! fromdat '())
(set! totrecords (+ totrecords 1)))))
(db:dbdat-get-db fromdb)
full-sel)
;; tack on remaining records in fromdat
(if (not (null? fromdat))
(set! fromdats (cons fromdat fromdats)))
;; read the source table
(sqlite3:for-each-row
(lambda (a . b)
(set! fromdat (cons (apply vector a b) fromdat))
(if (> (length fromdat) batch-len)
(begin
(set! fromdats (cons fromdat fromdats))
(set! fromdat '())
(set! totrecords (+ totrecords 1)))))
(db:dbdat-get-db fromdb)
full-sel)
;; tack on remaining records in fromdat
(if (not (null? fromdat))
(set! fromdats (cons fromdat fromdats)))
(if (common:low-noise-print 120 "sync-records")
(debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
(if (common:low-noise-print 120 "sync-records")
(debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
;; read the target table; BBHERE
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
(db:dbdat-get-db todb)
full-sel)
;; read the target table; BBHERE
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
(db:dbdat-get-db todb)
full-sel)
(when (and delay-handicap (> delay-handicap 0))
(debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
(thread-sleep! delay-handicap)
(debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
)
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(let* ((db (db:dbdat-get-db targdb))
(stmth (sqlite3:prepare db full-ins)))
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db
(lambda ()
(for-each ;;
(lambda (fromrow)
(let* ((a (vector-ref fromrow 0))
(curr (hash-table-ref/default todat a #f))
(same #t))
(let loop ((i 0))
(if (or (not curr)
(not (equal? (vector-ref fromrow i)(vector-ref curr i))))
(set! same #f))
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
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)
(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)
(if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
(sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
tot-count)))))
|
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
|
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
|
-
-
+
+
-
+
|
;; Open the classic megatest.db file (defaults to open in toppath)
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
;;(define (db:reopen-megatest-db
(define (db:open-megatest-db #!key (path #f)(name #f))
(let* ((dbdir (or path *toppath*))
(define (db:open-megatest-db alldat #!key (path #f)(name #f))
(let* ((dbdir (or path (alldat-areapath alldat)))
(dbpath (conc dbdir "/" (or name "megatest.db")))
(dbexists (common:file-exists? dbpath))
(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)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
|
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
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
|
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
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
|
-
-
+
+
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
-
+
+
|
;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))
;;
(define (db:lock-create-open fname initproc)
(let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
(define (db:lock-create-open alldat fname initproc)
(let* ((configdat (alldat-mtconfig alldat))
(parent-dir (or (pathname-directory fname)
(current-directory))) ;; no parent? go local
(raw-fname (pathname-file fname))
(dir-writable (file-write-access? parent-dir))
(file-exists (common:file-exists? fname))
(file-exists (file-exists? fname))
(file-write (if file-exists
(file-write-access? fname)
dir-writable )))
;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
(if file-write ;; dir-writable
(condition-case
(let* ((lockfname (conc fname ".lock"))
(readyfname (conc parent-dir "/.ready-" raw-fname))
(readyexists (common:file-exists? readyfname)))
(readyexists (file-exists? readyfname)))
(if (not readyexists)
(common:simple-file-lock-and-wait lockfname))
(let ((db (sqlite3:open-database fname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
(if (and (configf:lookup configdat "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
(begin
;;(print "DEBUG: Setting tmp_mode for " fname)
(sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
(sqlite3:execute db (configf:lookup configdat "setup" "tmp_mode"))
)
)
(if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
(if (and (configf:lookup configdat "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
(begin
;;(print "DEBUG: Setting nfs_mode for " fname)
(sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
(sqlite3:execute db (configf:lookup configdat "setup" "nfs_mode"))
)
)
(if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))
(configf:lookup *configdat* "setup" "use-wal")
(if (and (not (or (configf:lookup configdat "setup" "tmp_mode") (configf:lookup configdat "setup" "nfs_mode")))
(configf:lookup configdat "setup" "use-wal")
(string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
(sqlite3:execute db "PRAGMA journal_mode=WAL;")
(debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
(if (not file-exists)
(initproc db))
(if (not readyexists)
(begin
|