Megatest

(if (or (args:any? "-h" "help" "-help" "--help")
	(member *action* '("-h" "-help" "--help" "help")))
    (begin
      (print help)
      (exit 1)))

;;======================================================================
;; pkts
;;======================================================================

(define (with-queue-db mtconf proc)
  (let* ((pktsdirs (configf:lookup mtconf "setup"  "pktsdirs"))
	 (pktsdir  (if pktsdirs (car (string-split pktsdirs " ")) #f))
	 (toppath  (configf:lookup mtconf "dyndat" "toppath"))
	 (pdbpath  (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
    (if (not (and  pktsdir toppath pdbpath))
	(begin
	  (print "ERROR: settings are missing in your megatest.config for area management.")
	  (print "  you need to have pktsdir in the [setup] section."))
	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))
	       (res  (proc pktsdirs pktsdir pdb)))
	  (dbi:close pdb)
	  res
	  ))))

(define (load-pkts-to-db mtconf)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (for-each
      (lambda (pktsdir) ;; look at all
	(if (and (file-exists? pktsdir)
		 (directory? pktsdir)
		 (file-read-access? pktsdir))
	    (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	      (for-each
	       (lambda (pkt)
		 (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
			(exists  (lookup-by-uuid pdb uuid #f)))
		   (if (not exists)
		       (let* ((pktdat (string-intersperse
				       (with-input-from-file pkt read-lines)
				       "\n"))
			      (apkt   (pkt->alist pktdat))
			      (ptype  (alist-ref 'T apkt))
			      (parent (alist-ref 'P apkt)))
			 (add-to-queue pdb pktdat uuid (or ptype 'cmd) parent 0)
			 (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
		       (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
		       )))
	       pkts))))
      (string-split pktsdirs)))))

(define (get-pkt-alists pkts)
  (map (lambda (x)
	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
       pkts))

;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
(define (get-pkt-times pkts)
  (delete-duplicates
   (sort 
    (map (lambda (x)
	   `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
	 pkts)
    (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
   (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target

;;======================================================================
;; Runs
;;======================================================================

;; make a runname
;;
(define (make-runname pre post)

	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
		     mtconfig
		     ;; environ-patt: "env-override"
		     given-toppath: start-dir
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "dyndata"
    ;; we set some dynamic data in a section called "scratchdata"
    (if mtconf
	(begin
	  (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
    ;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
	  (configf:section-var-set! mtconf "scratchdat" "toppath" start-dir)))
    ;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath"))
    mtconfdat))


;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.


;; make a run request pkt from basic data, this seriously needs to be refactored

;; (use trace)(trace create-run-pkt)

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
    (with-queue-db
    (common:with-queue-db
     mtconf
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )

			(areas      (val-alist->areas    val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
			(dbdest     (alist-ref 'dbdest   val-alist))
			(appendconf (alist-ref 'appendconf val-alist))
			(file-globs (alist-ref 'glob val-alist))
			
			(runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
								 (t . ,runkey))))
			(rspkts     (get-pkt-alists runstarts))
			(rspkts     (common:get-pkt-alists runstarts))
			;; starttimes is for run start times and is used to know when the last run was launched
			(starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
			(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
			(last-run   (if (null? starttimes) ;; if '() then it has never been run, else get the max
					0
					(apply max (map cdr starttimes))))
			;; synctimes is for figuring out the last time a sync was done
			(syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
			(sspkts     (get-pkt-alists syncstarts))
			(synctimes  (get-pkt-times  sspkts))
			(sspkts       (common:get-pkt-alists syncstarts))
			(synctimes    (common:get-pkt-times  sspkts))
			(last-sync  (if (null? synctimes) ;; if '() then it has never been run, else get the max
					0
					(apply max (map cdr synctimes))))
			)

		   (let ((delta (lambda (x)
				  (round (/ (- (current-seconds) x) 60)))))

		     exn
		     #f
		   (create-directory "logs")
		   #t)
		 #t)
	     "logs"
	     "/tmp")))
    (with-queue-db
    (common:with-queue-db
     mtconf
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))

	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f)))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "dyndat" "toppath")))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath")))
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (load-pkts-to-db mtconf)
			 (common:load-pkts-to-db mtconf)
			 (generate-run-pkts mtconf toppath)
			 (load-pkts-to-db mtconf)
			 (common:load-pkts-to-db mtconf)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (load-pkts-to-db mtconf)) ;; import pkts
	   ((import)   (common:load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath)))))
      ;; misc
      ((show)
       (if (> (length remargs) 0)
	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
		  (mtconf    (car mtconfdat))