Megatest

Check-in [d0bca99717]
Login
Overview
Comment:Ensure that db opens are only done once per process per db file. Put out messages if this is not the case.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.70
Files: files | file ages | folders
SHA1: d0bca99717032c8f59079e1f86d604a8febda05c
User & Date: matt on 2022-05-22 15:42:09
Other Links: branch diff | manifest | tags
Context
2022-05-22
18:02
Cleaned up some gratuitous database opens, quietened some debug messages check-in: a6be57bfc9 user: matt tags: v1.70
15:42
Ensure that db opens are only done once per process per db file. Put out messages if this is not the case. check-in: d0bca99717 user: matt tags: v1.70
2022-05-20
19:49
Fixed two cases where dbdats were not being pushed back on stack when done check-in: 4fedbd6b6f user: matt tags: v1.70
Changes

Modified db.scm from [dc9a4cd486] to [73d0c4cca7].

226
227
228
229
230
231
232
233


234
235
236
237
238
239
240
226
227
228
229
230
231
232

233
234
235
236
237
238
239
240
241







-
+
+







	(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
    (condition-case
	(begin
	  (if use-mutex (mutex-lock! *db-with-db-mutex*))
	  (let ((res (apply proc dbdat db params)))
	    (if use-mutex (mutex-unlock! *db-with-db-mutex*))
	    ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
	    (if dbdat (stack-push! (dbr:subdb-dbstack subdb) dbdat))
	    (if dbdat
		(dbfile:add-dbdat dbstruct run-id dbdat))
	    res))
      (exn (io-error)
	   (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
      (exn (corrupt)
	   (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
      (exn (busy)
	   (db:generic-error-printout exn "ERROR: database " fname
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
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







-
-
-
+












-
-
+
+
-







    ;; (cons db dbpath)))
    (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))

;; sync run from tmp disk to nfs disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
  (debug:print-info 0 *default-log-port* "db:sync-touched Syncing: " (conc (if run-id run-id "main") ".db"))

  (let* (
	 (subdb   (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id db:initialize-main-db)))
  (let* ((subdb   (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id db:initialize-main-db)))
         (tmpdbfile (dbr:subdb-tmpdbfile subdb))
	 (mtdb    (dbr:subdb-mtdbdat subdb))
         (tmpdb (dbfile:open-sqlite3-db tmpdbfile #f))
	 (start-t (current-seconds)))
    (mutex-lock! *db-multi-sync-mutex*)
    (let ((update_info (cons "last_update" (if force-sync 0 *db-last-sync*) )))
      (mutex-unlock! *db-multi-sync-mutex*)
      (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb mtdb))
    (mutex-lock! *db-multi-sync-mutex*)
    (set! *db-last-sync* start-t)
    (set! *db-last-access* start-t)
    (mutex-unlock! *db-multi-sync-mutex*)
    (stack-push! (dbr:subdb-dbstack subdb) tmpdb))
  #t
    (dbfile:add-dbdat dbstruct run-id tmpdb)
  #t))
)


;; db:safely-close-sqlite3-db and db:close-all were here, moved to dbfile

;;   (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;;     (if (hash-table? locdbs)
;; 	(for-each (lambda (run-id)
1250
1251
1252
1253
1254
1255
1256
1257

1258
1259
1260
1261
1262
1263
1264
1248
1249
1250
1251
1252
1253
1254

1255
1256
1257
1258
1259
1260
1261
1262







-
+







	      ((schema)
	       (db:patch-schema-maindb (dbr:dbdat-dbh mtdb))
	       (db:patch-schema-maindb (dbr:dbdat-dbh main-tmpdb))
	       (db:patch-schema-rundb  (dbr:dbdat-dbh mtdb))
	       (db:patch-schema-rundb  (dbr:dbdat-dbh main-tmpdb))
               )
              )
	    (stack-push! (dbr:subdb-dbstack subdb) main-tmpdb))
	    (dbfile:add-dbdat dbstruct #f main-tmpdb))
	  options)))
     (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
    (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
    data-synced)
)

;; Sync all changed db's
1709
1710
1711
1712
1713
1714
1715
1716

1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737

1738
1739
1740
1741
1742
1743
1744
1745

1746
1747
1748
1749
1750
1751
1752
1707
1708
1709
1710
1711
1712
1713

1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734

1735
1736
1737
1738
1739
1740
1741
1742

1743
1744
1745
1746
1747
1748
1749
1750







-
+




















-
+







-
+







	 db 
	 (conc
	  "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
             INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
             WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
         last_df > ?;")
	 dneeded))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    (dbfile:add-dbdat dbstruct #f dbdat)
    blocks))
    
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
  (let* ((dbdat        (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
	 (db           (dbr:dbdat-dbh dbdat))
	 (res          #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
     bdisk-name bdisk-path)
    (if res ;; record exists, update df and return id
	(begin
	  (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
                                  WHERE archive_area_name=? AND disk_path=?;"
			   df bdisk-name bdisk-path)
          (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
          (dbfile:add-dbdat dbstruct #f dbdat)
	  res)
	(begin
	  (sqlite3:execute
	   db
	   "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
                VALUES (?,?,?);"
	   bdisk-name bdisk-path df)
          (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
          (dbfile:add-dbdat dbstruct #f dbdat)
	  (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))

;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
1765
1766
1767
1768
1769
1770
1771
1772

1773
1774
1775
1776
1777
1778
1779
1763
1764
1765
1766
1767
1768
1769

1770
1771
1772
1773
1774
1775
1776
1777







-
+







                                          WHERE archive_disk_id=? AND disk_path=?;"
				bdisk-id archive-path du))
	(begin
	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
                                                        VALUES (?,?,?);"
			   bdisk-id archive-path (or du 0))
	  (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    (dbfile:add-dbdat dbstruct #f dbdat)
    res))


;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
  (db:with-db
5080
5081
5082
5083
5084
5085
5086
5087

5088
5089
5090
5091
5092
5093
5094
5078
5079
5080
5081
5082
5083
5084

5085
5086
5087
5088
5089
5090
5091
5092







-
+







     (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
	 outputfile
	 (begin
	   (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
	   (conc (current-directory) "/" outputfile)))
     results)
    ;; brutal clean up
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    (dbfile:add-dbdat dbstruct #f dbdat)
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")

;;======================================================================
;; moving watch dogs here due to dependencies
;;======================================================================

Modified dbfile.scm from [c361d12128] to [0891876475].

21
22
23
24
25
26
27
28





29
30
31
32
33
34
35
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35
36
37
38
39







-
+
+
+
+
+







(declare (unit dbfile))
;; (declare (uses debugprint))
;; (declare (uses commonmod))

(module dbfile
	*
	
(import scheme chicken data-structures extras)
  (import scheme
	  chicken
	  data-structures
	  extras)
  
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18
	srfi-69
	stack
	files
	ports

179
180
181
182
183
184
185


186
187


188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
183
184
185
186
187
188
189
190
191


192
193
194



195
196
197
198
199









200
201
202
203
204
205
206







+
+
-
-
+
+

-
-
-





-
-
-
-
-
-
-
-
-








;; 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* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard
   (else ;;(common:on-homehost?)
    *dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard
   (else
    (let* ((dbstruct (make-dbr:dbstruct)))
      #;(when (not *toppath*)
        (debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
        (launch:setup areapath: areapath))
      (set! *dbstruct-dbs* dbstruct)
      (dbr:dbstruct-areapath-set! dbstruct areapath)
      (dbr:dbstruct-tmppath-set!  dbstruct tmppath)
      dbstruct))))

#;(define (dbfile:get-subdb dbstruct run-id)
  (let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f)))
    (if res
	res
	(let* ((newsubdb (make-dbr:subdb)))
	  (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
	  (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb)
	  newsubdb))))

(define (dbfile:get-subdb dbstruct run-id)
  (let* ((dbfname (dbfile:run-id->dbname run-id)))
    (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f)))

(define (dbfile:set-subdb dbstruct run-id subdb)
  (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb))

262
263
264
265
266
267
268










269
270
271
272
273
274
275
276
277

278

279
280
281
282
283
284
285
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291







+
+
+
+
+
+
+
+
+
+









+

+







	      dbdat
	      (let* ((tmppath   (dbr:dbstruct-tmppath  dbstruct))
		     (tmpdbpath (dbfile:run-id->path tmppath run-id)))
		(dbfile:open-sqlite3-db tmpdbpath init-proc)))))))

;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open
;;

;; this stuff is for initial debugging, please remove it when
;; this code stabilizes
(define *dbopens* (make-hash-table))
(define (dbfile:inc-db-open dbfile)
  (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1)))
    (if (> curr-opens-count 1) ;; this should NOT be happening
	(dbfile:print-err "ERROR: db "dbfile" has been opened "curr-opens-count" times!"))
    (hash-table-set! *dbopens* dbfile curr-opens-count)
    curr-opens-count))

;; Open the classic megatest.db file (defaults to open in toppath)
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;
(define (dbfile:open-sqlite3-db dbpath init-proc)
  (let* ((dbexists     (file-exists? dbpath))
	 (write-access (file-write-access? dbpath))
	 (db           (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath)
    (dbfile:inc-db-open dbpath)
    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
    (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
    ;; (init-proc db)
    (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))

(define (dbfile:print-and-exit . params)
  (with-output-to-port
      (current-error-port)
    (lambda ()
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
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
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512

513
514
515
516
517

518
519
520
521
522
523
524
525







-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+




-
+







;;======================================================================

;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;

(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 10))
  (let* ((lock-file (conc fname".lock"))
	 (retry (lambda ()
		  (thread-sleep! 1.1)
		  (if (> tries-left 0)
		      (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
    (assert (>= tries-left 0) (conc "FATAL: Five attempts in dbfile:cautious-open-database of "fname", giving up."))
    (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file)))
(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 50))
  (let* ((busy-file  (conc fname"-journal"))
	 (delay-time (* (- 51 tries-left) 1.1))
	 (retry      (lambda ()
		       (thread-sleep! delay-time)
		       (if (> tries-left 0)
			   (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
    (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
    (if (and (file-write-access? fname)
	     (file-exists? busy-file))
	(begin
	  (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.")
	  (thread-sleep! 1)
	  (if (eq? tries-left 2)
	      (begin
		(dbfile:print-err "INFO: forcing journal rollup "busy-file)
		(dbfile:brute-force-salvage-db fname)))
	  (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
	(let* ((db-exists (file-exists? fname))
	       (result (condition-case
			   (let* ((db (sqlite3:open-database fname)))
			     (if (and init-proc (not db-exists))
				 (init-proc db))
			     db)
			(exn (io-error)
			     (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
			     (retry))
			(exn (corrupt)
			     (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
			     (retry))
			(exn (busy)
			     (dbfile:print-err exn "ERROR: database " fname
					       " is locked. Try copying to another location, remove original and copy back.")
			     (retry))
			(exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
			     (retry))
			(exn ()
			     (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
					       ((condition-property-accessor 'exn 'message) exn))
			     (retry)))))
          #;(if (file-write-access? fname)
	    (dbfile:simple-file-release-lock lock-file))
	  result))))

(define (dbfile:brute-force-salvage-db fname)
  (let* ((backupfname (conc fname"-"(current-process-id)".bak"))
	 (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;")
		    "cp "backupfname" "fname)))
    (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n"
		      "  "cmd)
    (system cmd)))

(define (dbfile:cautious-open-database-orig fname init-proc #!optional (tries-left 50))
  (let* ((lock-file  (conc fname".lock"))
	 (delay-time (* (- 51 tries-left) 1.1))
	 (retry      (lambda ()
		       (thread-sleep! delay-time)
		       (if (> tries-left 0)
			   (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
    (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
    (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3)))
	(begin
	  (dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in 1 second.")
	  (dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in few seconds.")
	  (thread-sleep! 1)
	  (if (eq? tries-left 2)
	      (begin
		(dbfile:print-err "INFO: stealing the lock "lock-file)
		(delete-file lock-file)))
		(delete-file* lock-file)))
	  (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
	(let* ((db-exists (file-exists? fname))
	       (result (condition-case
			   (let* ((db (sqlite3:open-database fname)))
			     (if (and init-proc (not db-exists))
				 (init-proc db))
			     db)