Megatest

           cgisetup/models/pgdb.scm

# server.scm http-transport.scm client.scm rmt.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            configfmod.scm servermod.scm clientmod.scm rmtmod.scm        \
            artifacts.scm apimod.scm

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

# dbmod.import.o is just a hack here
mofiles/dbfile.o mofiles/clientmod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/servermod.o  : mofiles/artifacts.o
mofiles/rmtmod.o     : mofiles/apimod.o

# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\

monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o

# tests.o tasks.o dashboard-tasks.o : task_records.scm

runs.o : test_records.scm

mofiles-made : $(MOFILES)
	make $(MOIMPFILES)

megatest.o : mofiles-made megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)

(declare (unit api))
(declare (uses rmtmod))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(declare (uses debugprint))

(import dbmod)
(import dbfile)
(import rmtmod
	debugprint)














































































































(define *db-write-mutexes* (make-hash-table))

;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )

;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit apimod))
(declare (uses commonmod))


(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys
    get-key-vals
    test-toplevel-num-items
    get-test-info-by-id
    get-steps-info-by-id
    get-data-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-top-process-pid
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    get-run-status
    get-run-state
    get-run-stats
    get-run-times
    get-targets
    get-target
    ;; register-run
    get-tests-tags
    get-test-times
    get-tests-for-run
    get-tests-for-run-state-status
    get-test-id
    get-tests-for-runs-mindata
    get-tests-for-run-mindata
    get-run-name-from-id
    get-runs
    simple-get-runs
    get-num-runs
    get-runs-cnt-by-patt
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    get-steps-for-test
    read-test-data
    read-test-data-varpatt
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    ;; synchash-get
    get-changed-record-ids
    get-run-record-ids 
    get-not-completed-cnt))

(define api:write-queries
  '(
    get-keys-write ;; dummy "write" query to force server start

    ;; SERVERS
    ;; start-server
    ;; kill-server

    ;; TESTS
    test-set-state-status-by-id
    delete-test-records
    delete-old-deleted-test-records
    test-set-state-status
    test-set-top-process-pid
    set-state-status-and-roll-up-items
    
    update-pass-fail-counts
    top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")

    ;; RUNS
    register-run
    set-tests-state-status
    delete-run
    lock/unlock-run
    update-run-event_time
    mark-incomplete
    set-state-status-and-roll-up-run
    ;; STEPS
    teststep-set-status!
    delete-steps-for-test
    ;; TEST DATA
    test-data-rollup
    csv->test-data

    ;; MISC
    sync-inmem->db
    drop-all-triggers
    create-all-triggers
    update-tesdata-on-repilcate-db 

    ;; TESTMETA
    testmeta-add-record
    testmeta-update-field

    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))



)

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(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))
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")

(import debugprint)

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

;; NOT CURRENTLY USED
;;

;;(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
;;     message-digest matchable spiffy uri-common intarweb http-client
;;     spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit clientmod))
(declare (uses servermod))
(declare (uses artifacts))
(declare (uses debugprint))

(module clientmod
*

(import scheme
	chicken

	posix
	data-structures
	srfi-18
	typed-records

	artifacts
	servermod
	debugprint
	)

(defstruct con ;; client connection
  (hdir       #f) ;; this is the directory sdir/serverhost.serverpid
  (sdir       #f)
  (obj-to-str #f)
  (str-to-obj #f)
  (host       #f)
  (pid        #f)
  (sdat       #f) ;; server artifact data
  (areapath   #f)
  )

(define *my-client-signature* #f)

(define (client:find-server areapath)
  (let* ((sdir  (conc areapath"/.server"))
	 (sarfs (glob (conc sdir"/*.artifact")))) ;; server artifacts
    (if (null? sarfs)
	(begin
	  (server:launch areapath)
	  (thread-sleep! 1)
	  (client:find-server areapath))
	(let* ((sarf (car sarfs))
	       (sdat (read-artifact->alist sarf))
	       (hdir (alist-ref 'd sdat)))
	  (make-con hdir: hdir sdir: sdir sdat: sdat)))))

;; move this into artifacts
;; find the artifact with key set to val
;;
(define (client:find-artifact arfs key val)
  (let loop ((rem arfs))
    (if (null? rem) ;; didn't find a match
	#f
	(let* ((arf       (car rem))
	       (adat      (read-artifact->alist arf))
	       (val-found (alist-ref key adat)))
	  (if (equal? val-found val)
	      (cons (cons 'path arf) adat) ;; return the artifact as alist anotated with 'path
	      (loop (cdr rem)))))))

(define (client:send-receive con cmd params)
  (let* ((obj->string (con-obj-to-str con))
	 (string->obj (con-str-to-obj con))
	 (arf  `((c . ,cmd)
		 (p . ,(obj->string params))
		 (h . ,(con-host con))  ;; tells server where to put response
		 (i . ,(con-pid  con))));; and is where this client looks
	 (hdir  (con-hdir con))
	 (sdir  (con-sdir con))
	 (uuid  (write-alist->artifact hdir arf ptype: 'Q))
	 (respdir (conc sdir"/"(con-host con)"."(con-pid con)"/responses")))
    (let loop ((start (current-milliseconds)))
      (let* ((arfs (glob (conc respdir"/*.artifact")))
	     (res  (client:find-artifact arfs 'P uuid)))
	(if res ;; we found our response!
	    (let ((arf  (alist-ref 'path res))
		  (rstr (alist-ref 'r res)))
	      (delete-file arf) ;; done with it, future - move to archive area
	      (string->obj rstr))
	    (begin ;; no response yet, look again in 500ms
	      (thread-sleep! 0.5)
	      (loop (current-milliseconds))))))))


;; client:get-signature
(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

)

     (prefix nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     pkts (prefix dbi dbi:)
     )

(declare (unit common))
(declare (uses commonmod))
(declare (uses debugprint))

(import commonmod
	debugprint)

(include "common_records.scm")


;; (require-library margs)
;; (include "margs.scm")

(define *db-keys* #f)

(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done

(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
;; (define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit
(define *default-area-tag* "local")

;; DATABASE
;; (define *dbstruct-dbs*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.



;; db access
(define *db-last-access*      (current-seconds)) ;; last db access, used in server
;; (define *db-write-access*     #t)
;; db sync
;; (define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
;; (define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*

(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
;; (define *no-sync-db*          #f)  ;; moved to dbfile

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg

;; (define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *server-id*         #f)
(define *server-info*       #f)  ;; good candidate for easily convert to non-global
(define *time-to-exit*      #f)
(define *server-run*        #t)
(define *run-id*            #f)

;;
(define-inline (with-mutex mtx accessor record . val)
  (mutex-lock! mtx)
  (let ((res (apply accessor record val)))
    (mutex-unlock! mtx)
    res))

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

;;  testsuite and area utilites
;;
;;======================================================================

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

;; Globals

(define *runremote*           #f)                ;; if set up for server communication this will hold <host port>
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
(define *toppath*             #f)
(define *db-keys*             #f)
(define *keyvals*             #f)

(define (get-full-version)
  (conc megatest-version "-" megatest-fossil-hash))

(define (version-signature)
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

(define *common:denoise*    (make-hash-table)) ;; for low noise printing

	     ,(val->alist (cadr entry))))
	 adat)))

;;======================================================================
;; misc stuff
;;======================================================================







)

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

(use regex regex-case matchable) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses debugprint))

(include "common_records.scm")

(import debugprint)

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (common:file-exists? cfname)
	    (list toppath cfname configname)

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit configfmod))
(declare (uses mtargs))
(declare (uses debugprint))
;; (declare (uses keysmod))

(module configfmod
*	

(import srfi-1
  

;;	chicken.process-context
;;	chicken.process-context.posix
;;	chicken.sort
;;	chicken.string
;;	chicken.time
;;	chicken.eval
;;	
	debugprint
	(prefix mtargs args:)
;;	pkts
;;	keysmod
;;
;;	(prefix base64 base64:)
;;	(prefix dbi dbi:)
;;	(prefix sqlite3 sqlite3:)
;;	(srfi 18)

(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses debugprint))


(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(import debugprint)

(define (dboard:launch-testpanel run-id test-id)
  (let* ((dboardexe (common:find-local-megatest "dashboard"))
         (cmd (conc dboardexe
                    " -test " run-id "," test-id
                    " &")))
    (system cmd)))

(declare (uses keys))
(declare (uses db))
(declare (uses tasks))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")


(define (control-panel db tdb keys)
  (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
	 (key-params (make-hash-table))
	 (monitordat '()) ;; list of monitor records
	 (keyentries (iup:frame 
		      #:title "Keys"

(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(import debugprint)

;;======================================================================
;; C O M M O N
;;======================================================================

(define *dashboard-comment-share-slot* #f)

(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbfile))        
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

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

(import debugprint)

(dbfile:db-init-proc db:initialize-main-db)

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version 
              " license GPL, Copyright (C) Matt Welland 2012-2017

     typed-records
     matchable
     files)

(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses dbfile))
(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)

(import dbmod
	dbfile
	debugprint)

;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
  (state #f)
  (status #f)

	testname)
       res))))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; ;; NOTE: Can remove the regex and base64 encoding for zmq
;; (define (db:obj->string obj #!key (transport 'http))
;;   (case transport
;;     ;; ((fs) obj)
;;     ((http fs)
;;      (string-substitute
;;       (regexp "=") "_"
;;       (base64:base64-encode 
;;        (z3:encode-buffer
;; 	(with-output-to-string
;; 	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
;;       #t))
;;     ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
;;     (else obj))) ;; rpc
;; 
;; (define (db:string->obj msg #!key (transport 'http))
;;   (case transport
;;     ;; ((fs) msg)
;;     ((http fs)
;;      (if (string? msg)
;; 	 (with-input-from-string 
;; 	     (z3:decode-buffer
;; 	      (base64:base64-decode
;; 	       (string-substitute 
;; 		(regexp "_") "=" msg #t)))
;; 	   (lambda ()(deserialize)))
;; 	 (begin
;; 	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
;;            (print-call-chain (current-error-port))
;; 	   msg))) ;; crude reply for when things go awry
;;     ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
;;     (else msg))) ;; rpc

;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;;  (let ((dbdat  (db:get-subdb dbstruct run-id)))
;;    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; 	(db:general-call dbdat 'set-test-start-time (list test-id)))

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme
	  chicken
	  data-structures
	  extras
	  matchable)
  
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18 srfi-1
	srfi-69
	stack
	files
	ports

	commonmod
	debugprint
	)



;;======================================================================
;;  R E C O R D S
;;======================================================================

;; a single Megatest area with it's multiple dbs is
;; managed in a dbstruct
;;

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit dbmod))
(declare (uses debugprint))

(module dbmod
	*
	
(import scheme
	chicken
	ports
	s11n
	z3
	
	data-structures
	extras
	(prefix base64 base64:)
	message-digest
	regex

	debugprint
	)

(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18
	srfi-69)

(define (db:run-id->dbname run-id)
  (cond
   ((number? run-id)(conc run-id ".db"))
   ((not run-id)    "main.db")
   (else            run-id)))

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
  (case transport
    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode 
       (z3:encode-buffer
	(with-output-to-string
	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
      #t))
    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
    (else obj))) ;; rpc

(define (db:string->obj msg #!key (transport 'http))
  (case transport
    ;; ((fs) msg)
    ((http fs)
     (if (string? msg)
	 (with-input-from-string 
	     (z3:decode-buffer
	      (base64:base64-decode
	       (string-substitute 
		(regexp "_") "=" msg #t)))
	   (lambda ()(deserialize)))
	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc


;;======================================================================
;; hash of hashs
;;======================================================================

(use regex typed-records matchable)

(declare (unit dcommon))

(declare (uses gutils))
(declare (uses db))
(declare (uses commonmod))
(declare (uses debugprint))

(import commonmod
	debugprint
	)
;; (declare (uses synchash))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(declare (unit diff-report))
(declare (uses common))
(declare (uses rmtmod))
(declare (uses debugprint))
         
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(import debugprint)

(define css "")

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit env))
(declare (uses debugprint))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(import debugprint)

(define (env:open-db fname)
  (let* ((db-exists (common:file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (

     z3 csv typed-records pathname-expand matchable)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses debugprint))
;; (declare (uses sdb))
;; (declare (uses filedb))

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

(import debugprint)
;;(rmt:get-test-info-by-id run-id test-id) -> testdat

;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit genexample))
(declare (uses debugprint))

(use posix regex matchable)
(import debugprint)

(include "db_records.scm")

(define genexample:example-logpro
#<<EOF
  ;; You should have at least one expect:required. This ensures that your process ran
  ;; comment out the line below and replace "put pattern here" with a pattern that will

;; (define itemdat '((ripeness    "green ripe overripe")
;; 		     (temperature "cool medium hot")
;; 		     (season      "summer winter fall spring")))

(declare (unit items))
(declare (uses common))
(declare (uses debugprint))

(include "common_records.scm")

(import debugprint)

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

(declare (unit keys))
(declare (uses common))
(declare (uses debugprint))

(use srfi-1 posix regex regex-case srfi-69
     (prefix sqlite3 sqlite3:))

(import debugprint)
	

(include "key_records.scm")
(include "common_records.scm")

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))
(declare (uses debugprint))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

(import debugprint)

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

;; ezsteps were going to be coded as
;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute

;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;



(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))
(declare (uses debugprint))

(use (prefix sqlite3 sqlite3:) srfi-18)
(import debugprint)

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================

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

(declare (uses rmtmod))
(declare (uses clientmod))
(declare (uses servermod))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	commonmod
	dbfile
	servermod
	debugprint
	)

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

;; MLAUNCH
;;
;;   take jobs from the given queue and keep launching them keeping
;;   the cpu load at the targeted level
;;
;;======================================================================



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

(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)

(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses runs))
(declare (uses rmtmod))
;; (declare (uses filedb))
(declare (uses debugprint))

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

(import debugprint)

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

;;======================================================================
;;  R U N S
;;======================================================================

     matchable
     )

;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))


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

(define help (conc "
mtserv, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "

     (prefix sqlite3 sqlite3:)
     nanomsg)

(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses debugprint))

(use ducttape-lib)

(import debugprint)

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

(require-library stml)

;; stuff for the mapper and checker functions
;;

;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(declare (uses debugprint))

;; (declare (uses tree))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(import debugprint)

(define help (conc 
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2011

Usage: dashboard [options]

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))

(declare (unit portlogger))
(declare (uses db))
(declare (uses debugprint))
(import debugprint)

;; lsof -i

(define (portlogger:open-db fname)
  (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
	 (exists   (common:file-exists? fname))
	 (db       (if avail 

;;======================================================================
;; Process convience utils
;;======================================================================

(use regex directory-utils)
(declare (unit process))
(declare (uses debugprint))

(import debugprint)

(define (process:conservative-read port)
  (let loop ((res ""))
    (if (not (eof-object? (peek-char port)))
	(loop (conc res (read-char port)))
	res)))

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(declare (uses debugprint))

(include "common_records.scm")
;; (declare (uses rmtmod))

(import dbfile
	debugprint
	) ;; rmtmod)

;; ;;
;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;; ;;
;; 
;; ;; generate entries for ~/.megatestrc with the following
;; ;;

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

(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses clientmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses apimod))

(module rmtmod
*

(import scheme
	chicken
	data-structures
	posix
	;; regex
	srfi-1
	srfi-18
	srfi-69
	extras

	commonmod
	clientmod
	dbmod
	apimod
	debugprint
	)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; generate entries for ~/.megatestrc with the following

;; else return #f to let the calling proc know that there is no server available
;;
(define (rmt:get-connection-info areapath) ;; TODO: push areapath down.
  (if *runremote*
      *runremote*
      (begin
	(set! *runremote* (client:find-server areapath))
	(con-obj-to-str-set! *runremote* db:obj->string)
	(con-str-to-obj-set! *runremote* db:string->obj)
	(con-host-set! *runremote* (get-host-name))
	(con-pid-set!  *runremote* (current-process-id))
	(con-areapath-set! *runremote* areapath)
	*runremote*)))
      
  #;(let* ((cinfo     (if (remote? runremote)
			(remote-conndat runremote)
			#f)))
	  (if cinfo
	      cinfo

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

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
  (let* ((con      (rmt:get-connection-info *toppath*)))
    (client:send-receive con cmd params)))
    

  
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected

			     (if (> tot 10)
				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

#;(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
	 (db-file-path    (db:dbfile-path)) ;;  0))
	 (dbstructs-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only       (not (file-write-access? db-file-path)))
	 (start           (current-milliseconds))
	 (resdat          (if (not (and read-only qry-is-write))
			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))

	  (if qry-is-write
	      (let ((start-time (current-seconds)))
		(mutex-lock! *db-multi-sync-mutex*)
/		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! *db-multi-sync-mutex*)))))
    res))

#;(define (rmt:send-receive-no-auto-client-setup runremote cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (res  	   (http-transport:client-api-send-receive run-id runremote cmd params)))
    (if (and res (vector-ref res 0))
	(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
	#f)))

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

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature))))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
#;(define (rmt:login-no-auto-client-setup runremote)
  (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))

	(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))

#;(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
  (assert (number? run-id) "FATAL: Run id required.")
  (let* ((test-path (if (string? work-area)
			work-area
			(rmt:test-get-rundir-from-test-id run-id test-id))))
    (debug:print 3 *default-log-port* "TEST PATH: " test-path)
    (open-test-db test-path)))

;;  2. Continue as above
;; 
;;(define (rmt:get-steps-for-test run-id test-id)
;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))

(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
  (assert (number? run-id) "FATAL: Run id required.")
  (let* ((state     state-in)   ;; (items:check-valid-items "state" state-in))
	 (status    status-in)) ;; (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))


(define (rmt:delete-steps-for-test! run-id test-id)

(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))

(define (rmt:test-get-archive-block-info archive-block-id)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))

;; 
;; (define (rmtmod:calc-ro-mode runremote *toppath*)
;;   (if (and runremote
;; 	   (remote-ro-mode-checked runremote))
;;       (remote-ro-mode runremote)
;;       (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
;; 	     (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
;; 	(if runremote
;; 	    (begin
;; 	      (remote-ro-mode-set! runremote ro-mode)
;; 	      (remote-ro-mode-checked-set! runremote #t)
;; 	      ro-mode)
;; 	    ro-mode))))
;; 
;; (define (extras-readonly-mode rmt-mutex log-port cmd params)
;;   (mutex-unlock! rmt-mutex)
;;   (debug:print-info 12 log-port "rmt:send-receive, case 3")
;;   (debug:print 0 log-port "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
;;   #f)
;; 
;; (define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
;;   (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
;;   (mutex-lock! *rmt-mutex*)
;;   (http-transport:close-connections runremote)
;;   (remote-server-url-set! runremote #f)
;;   (mutex-unlock! *rmt-mutex*)
;;   (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
;;   (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;   
;; (define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
;;   (if (and (vector? res)
;; 	   (eq? (vector-length res) 2)
;; 	   (eq? (vector-ref res 1) 'overloaded)) ;; since we are
;; 						 ;; looking at the
;; 						 ;; data to carry the
;; 						 ;; error we'll use a
;; 						 ;; fairly obtuse
;; 						 ;; combo to minimise
;; 						 ;; the chances of
;; 						 ;; some sort of
;; 						 ;; collision.  this
;; 						 ;; is the case where
;; 						 ;; the returned data
;; 						 ;; is bad or the
;; 						 ;; server is
;; 						 ;; overloaded and we
;; 						 ;; want to ease off
;; 						 ;; the queries
;;       (let ((wait-delay (+ attemptnum (* attemptnum 10))))
;; 	(debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
;; 	(mutex-lock! *rmt-mutex*)
;; 	(http-transport:close-connections runremote)
;; 	(set! *runremote* #f) ;; force starting over
;; 	(mutex-unlock! *rmt-mutex*)
;; 	(thread-sleep! wait-delay)
;; 	(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;       res)) ;; All good, return res
;; 
;; #;(set-functions rmt:send-receive                       remote-server-url-set!
;; 	       http-transport:close-connections	      remote-conndat-set!
;; 	       debug:print                            debug:print-info
;; 	       remote-ro-mode                         remote-ro-mode-set!
;; 	       remote-ro-mode-checked-set!            remote-ro-mode-checked)
;; 
	
)

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================



(declare (unit runconfig))
(declare (uses common))
(declare (uses debugprint))

(use format directory-utils)
(import debugprint)

(include "common_records.scm")

(define (runconfig:read fname target environ-patt)
  (let ((ht (make-hash-table)))
    (if target (hash-table-set! ht target '()))
    (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))

(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
(declare (uses debugprint))

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

(import debugprint)
;; (include "debugger.scm")

;; use this struct to facilitate refactoring
;;

(defstruct runs:dat
  reglen regfull

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;======================================================================

(declare (unit servermod))
(declare (uses artifacts))
(declare (uses debugprint))

(use md5 message-digest posix typed-records extras)

(module servermod
*

(import scheme
	chicken

	extras
	md5
	message-digest
	ports
	posix
	srfi-18

	typed-records
	data-structures

	artifacts
	debugprint
	)

(defstruct srv
  (areapath #f)
  (host     #f)
  (pid      #f)
  (type     #f)

;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')




(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
;;(declare (uses archive))
;; (declare (uses filedb))
(declare (uses debugprint))

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format
     call-with-environment-variables)

(import debugprint)

;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

(declare (unit tasks))
(declare (uses dbfile))
(declare (uses db))
(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))
(declare (uses debugprint))

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


(include "db_records.scm")

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

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

(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses clientmod))
(declare (uses mt))
(declare (uses db))
(declare (uses debugprint))

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

(import debugprint)

;;======================================================================
;;
;; T E S T   D A T A B A S E S
;;
;;======================================================================

(declare (uses commonmod))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses servermod))
;;(declare (uses stml2))
(declare (uses debugprint))

(import debugprint)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod)
(require-library stml)

(include "common_records.scm")

(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(declare (uses debugprint))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")

(import debugprint)

;;======================================================================
;; T R E E   S T U F F 
;;======================================================================

;; path is a list of nodes, each the child of the previous
;; this routine returns the id so another node can be added