Megatest

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

;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc

(use (srfi 18) extras tcp stack) ;; RADT => use of require-extension?
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records sql-null)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:)) ;; RADT => prefix??
(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm")
(import (prefix dbi dbi:))

(declare (unit db))
(declare (uses common))

;;
(define (db:repair-db dbdat #!key (numtries 1))
  (let* ((dbpath   (db:dbdat-get-path        dbdat))
	 (dbdir    (pathname-directory       dbpath))
	 (fname    (pathname-strip-directory dbpath)))
    (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
    (cond
     ((eqv? (dbi:db-dbtype (db:dbdat-get-db dbdat)) 'pg)
      #t)
     ((not (file-write-access? dbdir))
      (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
      #f)

     ;; handle special cases, megatest.db and monitor.db
     ;; 
     ;;  NOPE: apply this same approach to all db files

     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     (print "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

			    (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 (eqv? (dbi:db-dbtype db) 'pg) (set! fromrow (list->vector (map (lambda (x) (if (and (string? x) (string-null? x)) (sql-null) x)) (vector->list fromrow)))))
          (if (not same)
              (begin 
                (set! res (apply dbi:prepare-exec stmth (vector->list fromrow)))
                (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))
          (if (and (not same) (eqv? (dbi:get-res res 'affected-rows) 0))
                  (let* ((prep ""))
                    (set! prep (string-intersperse (map cadr fields) ","))

;; 		 (db:delay-if-busy mtdb)
;; 		 (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
;; ;;		       (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
;; 		   (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
;; 		   (db:replace-test-records dbstruct run-id testrecs)
;; 		   (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct)))))
;; 	       run-ids)))

  (if (member 'synctoconfig options)
      (if (configf:get-section *configdat* "ext-sync")
                (let* ((dblist (configf:get-section *configdat* "ext-sync"))
                      (res '())
                      (cfgdb #f))
                      (for-each (lambda (dbitem)
                            (let* ((stringsplit (string-split (cadr dbitem)))
                                  (dbtype (string->symbol (car stringsplit)))
                                  (dbpath (cadr stringsplit)))
                            (case dbtype
                              ((sqlite3) 
                                (set! cfgdb (dbi:open dbtype (cons (cons 'dbname dbpath) '()) ))
                                (db:initialize-main-db (dbi:db-conn cfgdb))
                                (db:initialize-run-id-db (dbi:db-conn cfgdb))
                                (set! res (cons (cons cfgdb dbpath) res)))
                              ((pg)
                                (let* ((dbinfo '()))
                                  (for-each 
                                    (lambda (x)
                                      (if (not (eqv? (string->symbol x) dbtype))
                                        (let* ((pair (string-split x ":")))
                                          (if (not (eqv? pair '()))
                                            (set! dbinfo (cons (cons (string->symbol (car pair)) (cadr pair)) dbinfo))))))
                                  stringsplit)
                                  (set! cfgdb (dbi:open dbtype dbinfo))
                                  (set! res (cons (cons cfgdb (alist-ref 'host dbinfo)) res))
                                  )))))
                      dblist)
                      (for-each (lambda (todb)
                        (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb todb)) res)
                      
                      )))

	;; now ensure all newdb data are synced to megatest.db
	;; do not use the run-ids list passed in to the function
	;;
	(if (member 'new2old options)
	    (set! data-synced
		  (+ (apply db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb slave-dbs)

			"-create-megatest-area"
			"-mark-incompletes"

			"-convert-to-norm"
			"-convert-to-old"
			"-import-megatest.db"
			"-sync-to-megatest.db"
			"-sync-to-configdb"

			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       (db:setup)
       'new2old
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-configdb")
    (begin
      (db:multi-db-sync 
       (db:setup)
       'synctoconfig
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-generate-html")
    (let* ((toppath (launch:setup)))
      (if (tests:create-html-tree #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/runs-index.html")