Megatest

;; 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")
    ;; (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)))
      (set! *dbstruct-dbs* dbstruct)
      (dbr:dbstruct-areapath-set! dbstruct areapath)
      (dbr:dbstruct-tmppath-set!  dbstruct tmppath)
      dbstruct))))

;; 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 50))
  (let* ((busy-file  (conc fname"-journal"))
  (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
	 (delay-time (* (- 51 tries-left) 1.1))
	 (retry      (lambda ()
		       (thread-sleep! delay-time)
		       (if (> tries-left 0)
         (raw-fname    (pathname-file fname))
	 (dir-writable (file-write-access? parent-dir))
	 (file-exists  (file-exists? fname))
	 (file-write   (if file-exists
			   (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))
			   (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 (file-exists? readyfname)))
	(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
           (if (not readyexists)
             (dbfile:simple-file-lock-and-wait lockfname)
           )
           (let ((db      (sqlite3:open-database fname)))
             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
             (sqlite3:execute db "PRAGMA synchronous = 0;")
             (if (not file-exists)
                 (init-proc db))
             (if (not readyexists)
                 (begin
		(dbfile:print-err "INFO: forcing journal rollup "busy-file)
		(dbfile:brute-force-salvage-db fname)))
                   (dbfile:simple-file-release-lock lockfname)
	  (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
	(let* ((db-exists (file-exists? fname))
                   (with-output-to-file
	       (result (condition-case
			   (let* ((db (sqlite3:open-database fname)))
			     (if (and init-proc (not db-exists))
				 (init-proc db))
			     db)
                       readyfname
                     (lambda ()
                       (print "Ready at " (current-seconds))))))
             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.")
         (exn (io-error)  (dbfile:print-err "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (dbfile:print-err "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (dbfile:print-err "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(dbfile:print-err "ERROR: database " fname " has some permissions problem."))
         (exn () (dbfile:print-err "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))


	(condition-case
         (begin
           (dbfile:print-err "WARNING: opening db in non-writable dir " fname)
           (let ((db (sqlite3:open-database fname)))
             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
             (sqlite3:execute db "PRAGMA synchronous = 0;")
	     ;; (mutex-unlock! *db-open-mutex*)
             db))
         (exn (io-error)  (dbfile:print-err "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
         (exn (corrupt)   (dbfile:print-err "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (dbfile:print-err "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.")
         (exn (permission)(dbfile:print-err "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)
         (exn () (dbfile:print-err "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))

	    (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)