Megatest

;; re-read the db over and over again for the keys since they never
;; change

;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?

(define (db:get-keys dbstruct)
  (keys:config-get-fields *configdat*)
)
  (if *db-keys* *db-keys* 
      (let ((res '()))
	(db:with-db dbstruct #f #f
		    (lambda (dbdat db)
		      (sqlite3:for-each-row 
		       (lambda (key)
			 (set! res (cons key res)))
		       db
		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
	(set! *db-keys* res)
	res)))
;;  (if *db-keys* *db-keys* 
;;      (let ((res '()))
;;	(db:with-db dbstruct #f #f
;;		    (lambda (dbdat db)
;;		      (sqlite3:for-each-row 
;;		       (lambda (key)
;;			 (set! res (cons key res)))
;;		       db
;;		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
;;	(set! *db-keys* res)
;;	res)))

;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
  (list-index (lambda (x)(equal? x field)) header))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)

(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 (not (dbfile:simple-file-lock lock-file))
    (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file)))
	(begin
	  (dbfile:print-err "INFO: lock file "lock-file" exists, trying again in 1 second.")
	  (thread-sleep! 1)
	  (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)))

			     (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)
	    (dbfile:simple-file-release-lock lock-file)
          )
	  result))))


(define (dbfile:open-no-sync-db dbpath)
  (if *no-sync-db*
      *no-sync-db*
      (begin

	  (thread-sleep! 0.25)
	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))
	      #f)))))
	      #f)
       )
    )
  )
)

(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
  (let ((end-time (+ expire-time (current-seconds))))
    (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time)))
      (if got-lock
	  #t
	  (if (> end-time (current-seconds))

      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))
		 (fmtstr  "~8a~22a~20a~20a~8a\n"))
	    (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "===" "==============" "=========" "========" "=====")
		 (fmtstr  "~33a~22a~20a~20a~8a\n"))
	    (format #t fmtstr "ID" "host:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "==" "=========" "=========" "========" "=====")
	    (for-each ;;  ( mod-time host port start-time pid )
	     (lambda (server)
	       (let* ((mtm (any->number (car server)))
		      (mod (if mtm (- (current-seconds) mtm) "unk"))
		      (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
		      (url (conc (cadr server) ":" (caddr server)))
		      (pid (list-ref server 4))

;; *************** db.scm tests ****************


(define thisdbdat (db:open-db dbstruct #f))
(test #f #t (dbr:dbdat? thisdbdat))

(test #f #t (dbr:dbdat? (db:get-db dbstruct #f)))
(test #f #t (dbr:dbdat? (db:get-db dbstruct 1)))