Megatest

[setup]
pktsdirs /tmp/pkts /some/other/source

[areas]
#         path-to-area   map-target-script(future, optional)
fullrun   tests/fullrun
ext-tests ext-tests

[contours]
#     mode-patt/tag-expr
quick QUICKPATT/quick
# full  MAXPATT/long QUICKPATT/quick

    ("-status"     . s)
    ("-contour"    . c)
    ("-test-patt"  . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-mode-patt"  . o)
    ("-tag-expr"   . x)
    ("-item-patt"  . i)
    ;; misc
    ("-start-dir"  . S)
    ("-set-vars"   . v)
    ("-debug"      . #f)  ;; for *verbosity* > 2
    ("-load"       . #f)  ;; load and exectute a scheme file
    ("-log"        . #f)
    ))
(define *switch-keys*
  '(("-h"          . #f)

(define (lookup-param-by-key key #!key (inlst #f))
  (fold (lambda (a res)
	  (if (eq? (cdr a) key)
	      (car a)
	      res))
	#f
	(or inlst *arg-keys*)))

;; given a mtutil param, return the old megatest equivalent
;;
(define (param-translate param)
  (or (alist-ref (string->symbol param)
		 '((-tag-expr  . "-tagexpr")
		   (-mode-patt . "--modepatt")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")))
      param))

;; Card types:
;;
;; a action
;; u username (Unix)
;; D timestamp
;; T card type

;;
(define (generate-run-pkts mtconf toppath)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (let* ((rgconfdat (find-and-read-config (conc toppath "/rungen.config")))
	    (rgconf    (car rgconfdat))
	    (areas     (map car (configf:get-section mtconf "areas")))
	    (contours  (configf:get-section mtconf "contours"))

	    (torun     (make-hash-table)) ;; target => ( ... info ... )
	    (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
       
       (for-each
	(lambda (runkey)
	  (let* ((keydats (configf:get-section rgconf runkey)))
	    (for-each
	     (lambda (sense) ;; these are the sense rules
	       (let* ((key       (car sense))
		      (val       (cadr sense))
		      (keyparts  (string-split key ":"))
		      (contour   (car keyparts))
		      (ruletype  (let ((res (cdr keyparts)))
				   (if (null? res) #f (cadr keyparts))))
		      (valparts  (string-split val)) ;; runname-rule params
		      (runname   (make-runname #f))
		      (mode-tag  (string-split (or (configf:lookup mtconf "contours" contour) "") "/"))
		      (mode-patt (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))
		      (tag-expr  (if (null? mode-tag) #f (car mode-tag)))
		      (runstarts (find-pkts pdb '(runstart) `((o . ,contour)
							      (t . ,runkey))))
		      (rspkts    (map (lambda (x)
					(alist-ref 'pkta x))
				      runstarts))
		      (starttimes (map string->number (map (lambda (x)
							     (alist-ref 'D x))
							   rspkts)))
		      )

		 ;; (print "rspkts: " rspkts " starttimes: " starttimes)
		 
		 ;; look in runstarts for matching runs by target and contour
		 ;; get the timestamp for when that run started and pass it
		 ;; to the rule logic here where "ruletype" will be applied
		 ;; if it comes back "changed" then proceed to register the runs
		 
		 ;; run the ruletype here
		 ;; if already marked to run (#t) don't unmark it.
		 (if (not (configf:lookup torun runkey contour))
		     (configf:section-var-set! torun runkey contour
					       (list valparts)))
		 (print "key: " key " val: " val)
		 ;; now create a run request packet
		 (if (null? starttimes) ;; primitive, have a previous run? skip for now!
		     (for-each
		      (lambda (area)
			(let ((area-path (configf:lookup mtconf "areas" area)))
			  (print "area: " area " path: " area-path)
			  (let-values (((uuid pkt)
					(command-line->pkt
					 "run"
					 (append 
					  `(("-target"     . ,runkey)
					    ("-run-name"   . ,runname)
					    ("-start-dir"  . ,area-path))
					  (if mode-patt
					      `(("-mode-patt"  . ,mode-patt))
					      '())
					  (if tag-expr
					      `(("-tag-expr"   . ,tag-expr))
					      '())
					  (if (not (or mode-patt tag-expr))
					      `(("-item-patt"  . "%"))
					      '())))))
			    (with-output-to-file
				(conc pktsdir "/" uuid ".pkt")
			      (lambda ()
				(print pkt))))))
		      areas)))) ;; for each area
	     keydats)))
	(hash-table-keys rgconf)))))) ;; for each runkey



(define (pkt->cmdline pkta)
  (fold (lambda (a res)
	  (let* ((key (car a)) ;; get the key name
		 (val (cdr a))
		 (par (lookup-param-by-key key)))
	    ;; (print "key: " key " val: " val " par: " par)
	    (if par
		(conc res " " (param-translate par) " " val)
		res)))
	"megatest -run"
	pkta))

(define (write-pkt pktsdir uuid pkt)
  (if pktsdir
      (with-output-to-file
	  (conc pktsdir "/" uuid ".pkt")
	(lambda ()
	  (print pkt)))
      (print "ERROR: cannot process commands without a pkts directory")))

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (let* ((rgconfdat (find-and-read-config (conc toppath "/rungen.config")))
	    (rgconf    (car rgconfdat))
	    (areas     (configf:get-section mtconf "areas"))
	    (contours  (configf:get-section mtconf "contours"))
	    (pkts      (find-pkts pdb '(cmd) '()))
	    (torun     (make-hash-table)) ;; target => ( ... info ... )
	    (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
       (for-each
	(lambda (pktdat)
	  (let* ((pkta    (alist-ref 'pkta pktdat))
		 (cmdline (pkt->cmdline pkta))
		 (uuid    (alist-ref 'Z pkta))
		 (logf    (conc "logs/" uuid "-run.log")))
	    (system (conc "NBFAKE_LOG=" logf " nbfake " cmdline))
	    (mark-processed pdb (list (alist-ref 'id pktdat)))
	    (let-values (((ack-uuid ack-pkt)
			  (add-z-card
			   (construct-sdat 'P uuid
					   'T "runstart"
					   'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
					   't (alist-ref 't pkta)))))
	      (write-pkt pktsdir ack-uuid ack-pkt))))
	pkts)))))

(define (get-pkts-dir mtconf)
  (let ((pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	(pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f)))
    pktsdir))

	 ;; (for-each
	 ;;  (lambda (key)
	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs)))
	   (write-pkt pktsdir uuid pkt))))





      ((dispatch import rungen)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "dyndat" "toppath")))
	 (case (string->symbol *action*)
	   ((import)   (load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))