Megatest

;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
;; 
;; (declare (unit archive))
;; (declare (uses db))
;; (declare (uses common))
;; 
;; (include "common_records.scm")
(include "db_records.scm")
;; 
;;======================================================================
;; 
;;======================================================================

;; NOT CURRENTLY USED
;;

     (print-call-chain (current-error-port))
     (with-output-to-port (current-error-port)
       (lambda ()
	 (print ((condition-property-accessor 'exn 'message) exn))
	 (print "Callback error in " procname)
	 (print "Full condition info:\n" (condition->list exn)))))
   (proc)))

;;      ;; this was cached based on results from profiling but it turned out the profiling
;;      ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;;      ;; in for now but can probably take it out later.
;;      ;;
;;      (define (debug:calc-verbosity vstr)
;;        (or (hash-table-ref/default *verbosity-cache* vstr #f)
;;            (let ((res (cond
;;                        ((number? vstr) vstr)
;;                        ((not (string?  vstr))   1)
;;                        ;; ((string-match  "^\\s*$" vstr) 1)
;;                        (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
;;                                          (cond
;;                                           ((> (length debugvals) 1) debugvals)
;;                                           ((> (length debugvals) 0)(car debugvals))
;;                                           (else 1))))
;;                        ((args:get-arg "-v")   2)
;;                        ((args:get-arg "-q")    0)
;;                        (else                   1))))
;;              (hash-table-set! *verbosity-cache* vstr res)
;;              res)))
;;      
;;      ;; check verbosity, #t is ok
;;      (define (debug:check-verbosity verbosity vstr)
;;        (if (not (or (number? verbosity)
;;      	       (list?   verbosity)))
;;            (begin
;;      	(print "ERROR: Invalid debug value \"" vstr "\"")
;;      	#f)
;;            #t))
;;      
;;      (define (debug:debug-mode n)
;;        (cond
;;         ((and (number? *verbosity*)   ;; number number
;;      	 (number? n))
;;          (<= n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   number
;;      	 (number? n))
;;          (member n *verbosity*))
;;         ((and (list? *verbosity*)     ;; list   list
;;      	 (list? n))
;;          (not (null? (lset-intersection! eq? *verbosity* n))))
;;         ((and (number? *verbosity*)
;;      	 (list? n))
;;          (member *verbosity* n))))
;;      
;;      (define (debug:setup)
;;        (let ((debugstr (or (args:get-arg "-debug")
;;      		      (args:get-arg "-debug-noprop")
;;      		      (getenv "MT_DEBUG_MODE"))))
;;          (set! *verbosity* (debug:calc-verbosity debugstr))
;;          (debug:check-verbosity *verbosity* debugstr)
;;          ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
;;          (if (not *verbosity*)(set! *verbosity* 1))
;;          (if (and (not (args:get-arg "-debug-noprop"))
;;      	     (or (args:get-arg "-debug")
;;      		 (not (getenv "MT_DEBUG_MODE"))))
;;      	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
;;      				    (string-intersperse (map conc *verbosity*) ",")
;;      				    (conc *verbosity*))))))
;;        
;;      (define (debug:print n e . params)
;;        (if (debug:debug-mode n)
;;            (with-output-to-port (or e (current-error-port))
;;      	(lambda ()
;;      	  (if *logging*
;;      	      (db:log-event (apply conc params))
;;      	      (apply print params)
;;      	      )))))
;;      
;;      ;; Brandon's debug printer shortcut (indulge me :)
;;      (define *BB-process-starttime* (current-milliseconds))
;;      (define (BB> . in-args)
;;        (let* ((stack (get-call-chain))
;;               (location "??"))
;;          (for-each
;;           (lambda (frame)
;;             (let* ((this-loc (vector-ref frame 0))
;;                    (temp     (string-split (->string this-loc) " "))
;;                    (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;;               (if (equal? this-func "BB>")
;;                   (set! location this-loc))))
;;           stack)
;;          (let* ((color-on "\x1b[1m")
;;                 (color-off "\x1b[0m")
;;                 (dp-args
;;                  (append
;;                   (list 0 *default-log-port*
;;                         (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
;;                   in-args)))
;;            (apply debug:print dp-args))))
;;      
;;      (define *BBpp_custom_expanders_list* (make-hash-table))
;;      
;;      
;;      
;;      ;; register hash tables with BBpp.
;;      (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;;                       (cons hash-table? hash-table->alist))
;;      
;;      ;; test name converter
;;      (define (BBpp_custom_converter arg)
;;        (let ((res #f))
;;          (for-each
;;           (lambda (custom-type-name)
;;             (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;;                    (custom-type-test      (car custom-type-info))
;;                    (custom-type-converter (cdr custom-type-info)))
;;               (when (and (not res) (custom-type-test arg))
;;                 (set! res (custom-type-converter arg)))))
;;           (hash-table-keys *BBpp_custom_expanders_list*))
;;          (if res (BBpp_ res) arg)))
;;      
;;      (define (BBpp_ arg)
;;        (cond
;;         ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;         ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;;         ((hash-table? arg)
;;          (let ((al (hash-table->alist arg)))
;;            (BBpp_ (cons HASH_TABLE: al))))
;;         ((null? arg) '())
;;         ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;         ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;         (else (BBpp_custom_converter arg))))
;;      
;;      ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
;;      (define (BBpp arg)
;;        (pp (BBpp_ arg)))
;;      
;;      ;(use define-macro)
;;      (define-syntax inspect
;;        (syntax-rules ()
;;          [(_ x)
;;          ;; (with-output-to-port (current-error-port)
;;             (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;;           ;;  )
;;           ]
;;          [(_ x y ...) (begin (inspect x) (inspect y ...))]))
;;      
;;      (define (debug:print-error n e . params)
;;        ;; normal print
;;        (if (debug:debug-mode n)
;;            (with-output-to-port (if (port? e) e (current-error-port))
;;      	(lambda ()
;;      	  (if *logging*
;;      	      (db:log-event (apply conc params))
;;      	      ;; (apply print "pid:" (current-process-id) " " params)
;;      	      (apply print "ERROR: " params)
;;      	      ))))
;;        ;; pass important messages to stderr
;;        (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
;;            (with-output-to-port (current-error-port)
;;      	(lambda ()
;;      	  (apply print "ERROR: " params)
;;      	  ))))
;;      
;;      (define (debug:print-info n e . params)
;;        (if (debug:debug-mode n)
;;            (with-output-to-port (if (port? e) e (current-error-port))
;;      	(lambda ()
;;      	  (if *logging*
;;      	      (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
;;      		(db:log-event res))
;;      	      ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
;;      	      (apply print "INFO: (" n ") " params) ;; res)
;;      	      )))))
;;      
;;      
;;      
;;      ;; if a value is printable (i.e. string or number) return the value
;;      ;; else return an empty string
;;      (define-inline (printable val)
;;        (if (or (number? val)(string? val)) val ""))
;;      
;;      

;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================

(include "megatest-fossil-hash.scm")


;; these come from processmod
;;
;; (define setenv set-environment-variable!)
;; (define unsetenv unset-environment-variable!)
;; (define getenv get-environment-variable)

;;     (dbr:dbstruct-path-set! v path)
;;     (dbr:dbstruct-local-set! v local)
;;     (dbr:dbstruct-locdbs-set! v (make-hash-table))
;;     v))


(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id           vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id       vec) (vector-ref vec 1))
(define-inline (db:test-get-testname     vec) (vector-ref vec 2))
(define-inline (db:test-get-state        vec) (vector-ref vec 3))
(define-inline (db:test-get-status       vec) (vector-ref vec 4))
(define-inline (db:test-get-event_time   vec) (vector-ref vec 5))
(define-inline (db:test-get-host         vec) (vector-ref vec 6))
(define-inline (db:test-get-cpuload      vec) (vector-ref vec 7))
(define-inline (db:test-get-diskfree     vec) (vector-ref vec 8))
(define-inline (db:test-get-uname        vec) (vector-ref vec 9))
;; (define-inline (db:test-get-rundir       vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define-inline (db:test-get-rundir       vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path    vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf   vec) (vector-ref vec 13))
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))
(define-inline (db:test-get-process_id   vec) (vector-ref vec 16))
(define-inline (db:test-get-archived     vec) (vector-ref vec 17))
(define-inline (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define-inline (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define-inline (db:test-get-fail_count   vec) (vector-ref vec 16))
(define-inline (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define-inline (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define-inline (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define-inline (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val))

;; Test record utility functions

;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
  (and (equal? (db:test-get-item-path vec) "")      ;; test is not an item
       (equal? (db:test-get-uname vec)     "n/a"))) ;; test has never been run

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define-inline (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define-inline (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define-inline (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define-inline (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define-inline (db:mintest-get-status       vec)    (vector-ref  vec 4))
(define-inline (db:mintest-get-event_time   vec)    (vector-ref  vec 5))
(define-inline (db:mintest-get-item_path    vec)    (vector-ref  vec 6))

;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define-inline (db:testmeta-get-id            vec)    (vector-ref  vec 0))
(define-inline (db:testmeta-get-testname      vec)    (vector-ref  vec 1))
(define-inline (db:testmeta-get-author        vec)    (vector-ref  vec 2))
(define-inline (db:testmeta-get-owner         vec)    (vector-ref  vec 3))
(define-inline (db:testmeta-get-description   vec)    (vector-ref  vec 4))
(define-inline (db:testmeta-get-reviewed      vec)    (vector-ref  vec 5))
(define-inline (db:testmeta-get-iterated      vec)    (vector-ref  vec 6))
(define-inline (db:testmeta-get-avg_runtime   vec)    (vector-ref  vec 7))
(define-inline (db:testmeta-get-avg_disk      vec)    (vector-ref  vec 8))
(define-inline (db:testmeta-get-tags          vec)    (vector-ref  vec 9))
(define-inline (db:testmeta-set-id!           vec val)(vector-set! vec 0 val))
(define-inline (db:testmeta-set-testname!     vec val)(vector-set! vec 1 val))
(define-inline (db:testmeta-set-author!       vec val)(vector-set! vec 2 val))
(define-inline (db:testmeta-set-owner!        vec val)(vector-set! vec 3 val))
(define-inline (db:testmeta-set-description!  vec val)(vector-set! vec 4 val))
(define-inline (db:testmeta-set-reviewed!     vec val)(vector-set! vec 5 val))
(define-inline (db:testmeta-set-iterated!     vec val)(vector-set! vec 6 val))
(define-inline (db:testmeta-set-avg_runtime!  vec val)(vector-set! vec 7 val))
(define-inline (db:testmeta-set-avg_disk!     vec val)(vector-set! vec 8 val))

;;======================================================================
;; S I M P L E   R U N
;;======================================================================

;; (defstruct id  "runname" "state" "status" "owner" "event_time"

;;======================================================================
;; T E S T   D A T A 
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define-inline (db:test-data-get-id               vec)    (vector-ref  vec 0))
(define-inline (db:test-data-get-test_id          vec)    (vector-ref  vec 1))
(define-inline (db:test-data-get-category         vec)    (vector-ref  vec 2))
(define-inline (db:test-data-get-variable         vec)    (vector-ref  vec 3))
(define-inline (db:test-data-get-value            vec)    (vector-ref  vec 4))
(define-inline (db:test-data-get-expected         vec)    (vector-ref  vec 5))
(define-inline (db:test-data-get-tol              vec)    (vector-ref  vec 6))
(define-inline (db:test-data-get-units            vec)    (vector-ref  vec 7))
(define-inline (db:test-data-get-comment          vec)    (vector-ref  vec 8))
(define-inline (db:test-data-get-status           vec)    (vector-ref  vec 9))
(define-inline (db:test-data-get-type             vec)    (vector-ref  vec 10))
(define-inline (db:test-data-get-last_update      vec)    (vector-ref  vec 11))

(define-inline (db:test-data-set-id!              vec val)(vector-set!  vec 0  val))
(define-inline (db:test-data-set-test_id!         vec val)(vector-set!  vec 1  val))
(define-inline (db:test-data-set-category!        vec val)(vector-set!  vec 2  val))
(define-inline (db:test-data-set-variable!        vec val)(vector-set!  vec 3  val))
(define-inline (db:test-data-set-value!           vec val)(vector-set!  vec 4  val))
(define-inline (db:test-data-set-expected!        vec val)(vector-set!  vec 5  val))
(define-inline (db:test-data-set-tol!             vec val)(vector-set!  vec 6  val))
(define-inline (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
(define-inline (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
(define-inline (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
(define-inline (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 9))
(define-inline (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define-inline (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define-inline (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define-inline (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define-inline (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define-inline (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define-inline (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define-inline (tdb:step-get-comment         vec)    (vector-ref  vec 7))
(define-inline (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
(define-inline (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define-inline (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define-inline (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
(define-inline (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define-inline (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define-inline (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define-inline (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define-inline (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define-inline (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define-inline (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define-inline (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; The data structure for handing off requests via wire
(define (make-cdb:packet)(make-vector 6))
(define-inline (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
(define-inline (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
(define-inline (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
(define-inline (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
(define-inline (cdb:packet-get-params       vec)    (vector-ref  vec 4))
(define-inline (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
(define-inline (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
(define-inline (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
(define-inline (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
(define-inline (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
(define-inline (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
(define-inline (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))

;; (declare (uses keys))
;; (declare (uses ods))
;; (declare (uses client))
;; (declare (uses mt))
;; 
;; (include "common_records.scm")

(include "db_records.scm")
(include "key_records.scm")
;; (include "run_records.scm")

(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

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

;; (declare (uses items))
;; (declare (uses runconfig))
;; ;; (declare (uses sdb))
;; ;; (declare (uses filedb))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
(include "db_records.scm")
;; (include "run_records.scm")
;; 
;; 
;;(rmt:get-test-info-by-id run-id test-id) -> testdat

(define message-window #f)

;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses server))
;; ;; (declare (uses daemon))
;; (declare (uses portlogger))
;; (declare (uses rmt))
;; 
;; (include "common_records.scm")
(include "db_records.scm")
;; (include "js-path.scm")

;; (require-library stml)
(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

	processmod
	rmtmod
	servermod
	subrunmod
	testsmod
	)

(include "db_records.scm")
(include "key_records.scm")

;;======================================================================
;; ezsteps
;;======================================================================

;; ezsteps were going to be coded as

	  ;; tasksmod
	  testsmod
	  
	  )
	
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
;; (include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")

(include "common.scm")
(include "db.scm")
(include "server.scm")
(include "tests.scm")

;; (declare (uses server))
;; (declare (uses runs))
;; (declare (uses rmt))
;; ;; (declare (uses filedb))
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
(include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")

;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.

(define (mt:discard-blocked-tests run-id failed-test tests test-records)

	)

(defstruct alldat
  (areapath #f)
  (ulexdat  #f)
  )

(include "db_records.scm")

;;======================================================================
;; return the handle struct for sending queries to a specific database
;;  - initializes the connection object if this is the first access
;;    - finds the "captain" and asks who to talk to for the given dbfname
;;    - establishes the connection to the current dbowner
;;

	launchmod
	subrunmod
	servermod
	itemsmod
	
	)

(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "key_records.scm")

;; use this struct to facilitate refactoring
;;

;; (declare (uses rmt))
;; (declare (uses common))
;; (declare (uses pgdb))

;; (import pgdb) ;; pgdb is a module

(include "task_records.scm")
(include "db_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================

;; wait up to aprox n seconds for a journal to go away
;;

;; 
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
;; (import (prefix sqlite3 sqlite3:))
;; (require-library stml)
;; 
;; (include "common_records.scm")
;; (include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")

(define (init-java-script-lib)
  (set! *java-script-lib* (conc  (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
  )