Megatest

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

;;======================================================================
;; Database access
;;======================================================================

(require-extension (srfi 18) extras tcp)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))

	(let ((dbdat (if (or (not run-id)
			     (eq? run-id 0))
			 (db:open-main dbstruct)
			 (db:open-rundb dbstruct run-id)
			 )))
	  dbdat))))

(defstruct db:dbdat db path writeable)

(define (db:dbdat-get-db dbdat)
  (if (db:dbdat? dbdat)
      (db:dbdat-db dbdat)
      dbdat))

(define (db:dbdat-get-path dbdat)
  (if (db:dbdat? dbdat)
      (db:dbdat-path dbdat)
      #f))

;; mod-read:
;;     'mod   modified data
;;     'read  read data
;;
(define (db:done-with dbstruct run-id mod-read)

	       
(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))

;; open an sql database inside a file lock
;;
;; returns: db:dbdat record <db existed-prior-to-opening
;;
(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))
	 (dir-writable (file-write-access? parent-dir))
	 (file-exists  (file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))
    (make-db:dbdat
     db:
     (if file-write ;; dir-writable or db writeable
	 (let (;; (lock    (obtain-dot-lock fname 1 5 10))
	       (db      (sqlite3:open-database fname)))
	   (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	   (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	   (if (and initproc (not file-exists))
	       (initproc db))
	   ;; (release-dot-lock fname)
	   db)
	 (begin
	   (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
	   (sqlite3:open-database 
	    (if file-exists
		fname
		":memory:"))))
     writeable: file-write
     )))

;; This routine creates the db. It is only called if the db is not already opened
;; 
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((local  (dbr:dbstruct-get-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-get-localdb dbstruct run-id)

				     (set! *megatest-db* db)
				     db)))
		 (write-access (file-write-access? dbpath))
		 ;; (handler      (make-busy-timeout 136000))
		 )
	    (if (and dbexists (not write-access))
		(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
	    (dbr:dbstruct-set-rundb!  dbstruct db) ;; (cons db dbpath))
	    (dbr:dbstruct-set-inuse!  dbstruct #t)
	    (dbr:dbstruct-set-olddb!  dbstruct olddb)
	    ;; (dbr:dbstruct-set-run-id! dbstruct run-id)
	    (mutex-unlock! *rundb-mutex*)
	    (if local
		(begin
		  (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...

  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db)
  (let* ((dbfile       (conc *toppath* "/megatest.db"))
	 (dbpath       *toppath*)
	 (dir-writable (file-write-access? dbpath))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbfile
					    (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))
	(set! *db-write-access* #f))
    (cons db dbpath)))