Megatest

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack)
(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack
     matchable)
(require-extension regex posix)

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

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

			(create-directory hed #t)))))
	  (if (and (string? res)
		   (directory? res))
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))
  

;; return the youngest timestamp . filename
;;
(define (common:get-youngest glob-list)
  (let ((all-files (apply append
			  (map (lambda (patt)
				 (handle-exceptions
				     exn
				     '()
				   (glob patt)))
			       glob-list))))
    (fold (lambda (fname res)
	    (let ((last-mod (car res))
		  (curmod   (handle-exceptions
				exn
				0
			      (file-modification-time fname))))
	      (if (> curmod last-mod)
		  (list curmod fname)
		  res)))
	  '(0 "n/a")
	  all-files)))

;;======================================================================
;; T A R G E T S  ,   S T A T E ,   S T A T U S ,   
;;                    R U N N A M E    A N D   T E S T P A T T
;;======================================================================

;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
;;

    ("-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)
    ("-msg"        . M)
    ("-set-vars"   . v)
    ("-debug"      . #f)  ;; for *verbosity* > 2
    ("-load"       . #f)  ;; load and exectute a scheme file
    ("-log"        . #f)
    ))
(define *switch-keys*
  '(("-h"          . #f)

;; 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")))
		   (-test-patt . "-testpatt")
		   (-msg       . "-m")))
      param))

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

	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "dyndata"
    (if mtconf
	(begin
	  (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
    (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
    mtconfdat))

;; make a run request pkt from basic data
;;
(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason)
  (let ((area-path (configf:lookup mtconf "areas" area)))
    (let-values (((uuid pkt)
		  (command-line->pkt
		   "run"
		   (append 
		    `(("-target"     . ,runkey)
		      ("-run-name"   . ,runname)
		      ("-start-dir"  . ,area-path)
		      ("-msg"        . ,reason))
		    (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))))))

;; collect all needed data and create run pkts for contours with changed inputs
;;
(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)))
	  (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))
	       (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)))
		      )

		      (runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
							       (t . ,runkey))))
		      (rspkts     (map (lambda (x)
					 (alist-ref 'pkta x))
				       runstarts))
		      (starttimes ;; sort by age (youngest first) and delete duplicates by target
		       (delete-duplicates
			(sort 
			 (map (lambda (x)
				`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
			      rspkts)
			 (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
			(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
		 ;; (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.

		 (case (string->symbol ruletype)
		   ((file)
		 (if (not (configf:lookup torun runkey contour))
		     (configf:section-var-set! torun runkey contour
					       (list valparts)))
		 (print "key: " key " val: " val)
		    (let* ((file-globs  (cdr valparts))
			   (youngestdat (common:get-youngest file-globs))
			   (youngestmod (car youngestdat)))
		      ;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
		 ;; now create a run request packet
		 (if (null? starttimes) ;; primitive, have a previous run? skip for now!
		     (for-each
		      (lambda (area)
		      (if (null? starttimes) ;; this target has never been run
			  (configf:section-var-set! torun contour runkey `("file:neverrun" ,runname))
			  (for-each
			   (lambda (starttime) ;; look at the time the last run was kicked off for this contour
			(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
			     (if (> youngestmod (cdr starttime))
					      `(("-mode-patt"  . ,mode-patt))
					      '())
				 (begin
					  (if tag-expr
					      `(("-tag-expr"   . ,tag-expr))
					      '())
				   (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
				   (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname)))))
			   starttimes))
					  (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
	(hash-table-keys rgconf))
       
       ;; now have torun populated
       (for-each
	(lambda (contour)
	  (let* ((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))))
	    (for-each
	     (lambda (runkeydat)
	       (let* ((runkey (car runkeydat))
		      (info   (cadr runkeydat)))
		 (for-each
		  (lambda (area)
		    (let ((runname (cadr info))
			  (reason  (car  info)))
		      (print "runkey: " runkey " contour: " contour " info: " info " area: " area  " tag-expr: " tag-expr " mode-patt: " mode-patt)
		      (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason)))
		  areas)))
	     (configf:get-section torun contour))))
	(hash-table-keys torun))))))


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