Megatest

	  last-name))))

(define (str-first-char->number str)
  (char->integer (string-ref str 0)))
 
;; example of how to set up and write target mappers
;;

(add-target-mapper 'prefix-contour
		   (lambda (target run-name area area-path reason contour mode-patt)
		     (conc contour "/" target)))

(add-target-mapper 'prefix-area-contour
		   (lambda (target run-name area area-path reason contour mode-patt)
		     (conc area "/" contour "/" target)))
  

(add-runname-mapper 'corporate-ww
		    (lambda (target run-name area area-path reason contour mode-patt)
		      (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
		      (let* ((last-name   (get-last-runname area-path target))
			     (last-letter (let* ((ch (if (string? last-name)
							 (let ((len (string-length last-name)))
							   (substring last-name (- len 1) len))
							 "a"))
						 (chnum (str-first-char->number ch))
						 (a     (str-first-char->number "a"))
						 (z     (str-first-char->number "z")))
					    (if (and (>= chnum a)(<= chnum z))
						chnum
						#f)))
			     (next-letter (if last-letter
					      (list->string
					       (list
						(integer->char
						 (+ last-letter 1)))) ;; surely there is an easier way?
					      "a")))
			;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
			(conc (seconds->wwdate (current-seconds)) next-letter))))

(add-runname-mapper 'auto

		    (lambda (target run-name area area-path reason contour mode-patt)
		      "auto-eh"))

;; run only areas where first letter of area name is "a"
;;
(add-area-checker 'first-letter-a
		 (lambda (area runkey)
		   (string-match "^a.*$" area)))

[fields]
a text
b text
c text

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

[areas]
#         path-to-area   map-target-script(future, optional)
fullrun   path=tests/fullrun
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
#           the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
# ext-tests path=ext-tests; targtrans=prefix-contour;
ext-tests path=ext-tests

[contours]
#     mode-patt/tag-expr
quick selector=QUICKPATT/quick
full  areas=fullrun,ext-tests; selector=MAXPATT/

(declare (uses configf))
;; (declare (uses rmt))

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

(require-library stml)

;; stuff for the mapper and checker functions
;;
(define *target-mappers*  (make-hash-table)) 
(define *runname-mappers* (make-hash-table)) 
(define *area-checkers*   (make-hash-table)) 

;; helpers for mappers/checkers
(define (add-target-mapper name proc)
  (hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
  (hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
  (hash-table-set! *area-checkers* name proc))

;; this needs some thought regarding security implications.
;;
;;   i. Check that owner of the file and calling user are same?
;;  ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;;  iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"

			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append (list 'T "cmd"
					'a action
					'U (current-user-name)
					'D sched)
                           (if (null? extra-dat)
			       '()
			       (list (car extra-dat)(cdr extra-dat)))
			   (map (lambda (x)
				  (let* ((param (car x))
					 (value (cdr x))
					 (pmeta (assoc param *arg-keys*))    ;; translate the card key to a megatest switch or parameter
					 (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
					 (meta  (if (or pmeta smeta)
						    (cdr (or pmeta smeta))   ;; found it?
						    #f)))
				    (if (or pmeta smeta)                     ;; construct the switch/param pair.
					(list meta value)
					'())))
				(filter cdr args-data)))))
    (print  "Alldat: " alldat
	    " args-data: " args-data)
    (add-z-card
     (apply construct-sdat alldat))))

(define (simple-setup start-dir-in)
  (let* ((start-dir (or start-dir-in "."))
	 (mtconfig  (or (args:get-arg "-config") "megatest.config"))
	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect

                   extra-dat: `((a . ,runkey))  ;; we need the run key for marking the run as launched
                   )))
      (with-output-to-file
	  (conc pktsdir "/" uuid ".pkt")
	(lambda ()
	  (print pkt))))))

;; look for areas=a1,a2,a3 OR areafn=somefuncname
;;
(define (val-alist->areas val-alist)
  (let ((areas-string   (alist-ref 'areas  val-alist))
	(areas-procname (alist-ref 'areafn val-alist)))
    (if areas-procname ;; areas-procname take precedence
	areas-procname
	(string-split (or areas-string "") ","))))

(define (area-allowed? area areas runkey)
  (cond
   ((not areas) #t) ;; no spec
   ((string? areas) ;; 
    (let ((check-fn (hash-table-ref/default *area-checkers* areas #f)))
      (if check-fn
	  (check-fn area runkey)
	  #f)))
   ((list? areas)(member area areas))
   (else #f))) ;; shouldn't get here 

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

			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
			(action     (if (> len-key 2)(caddr keyparts) #f))
			(optional   (if (> len-key 3)(cadddr keyparts) #f))
			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
			(val-alist  (val->alist val))
			(runname    (make-runname "" ""))
			(runtrans   (alist-ref 'runtrans val-alist))

			;; these may or may not be defined and not all are used in each handler type in the case below
			(run-name   (alist-ref 'run-name val-alist))
			(target     (alist-ref 'target   val-alist))
			(crontab    (alist-ref 'cron     val-alist))
			(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))
			;; 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
			(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))
			(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)))))
		     (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))

		   (print "val-alist=" val-alist " runtrans=" runtrans)
		   
		   ;; 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
		   
		   (case (string->symbol (or ruletype "no-such-rule"))

		     ((no-such-rule) (print "ERROR: no such rule for " sense))

		     ;; Handle crontab like rules
		     ;;
		     ((scheduled)
		      (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
			  (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
			  (let* (



				 ;; (action   (alist-ref 'action   val-alist))
				 (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X"))
				 (runname  std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
			    ;; (print "last-run: " last-run " need-run: " need-run)
			    ;; (if need-run
			    (case (string->symbol action)
			      ((sync sync-prepend)
			       (if (common:extended-cron crontab #f last-sync)
				   (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":sync-" cron-safe-string))
						    (action  . ,action)
						    (dbdest  . ,dbdest)
						    (append  . ,appendconf)
						    (areas   . ,areas)))))
			      ((run)
			       (if (common:extended-cron crontab #f last-run)
				   (push-run-spec torun contour runkey
						  `((message  . ,(conc ruletype ":" cron-safe-string))
						    (runname  . ,runname)
						    (runtrans . ,runtrans)
						    (action   . ,action)
						    (areas    . ,areas)
						    (target   . ,target)))))
                              ((remove)
                               (push-run-spec torun contour runkey
						  `((message  . ,(conc ruletype ":" cron-safe-string))
						    (runname  . ,runname)
						    (runtrans . ,runtrans)
						    (action   . ,action)
						    (areas    . ,areas)
						    (target   . ,target))))
			      (else
			       (print "ERROR: action \"" action "\" has no scheduled handler")
			       )))))

		     ;; script based sensors
		     ;;
		     ((script)
		      ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
		      ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
		      ;; the script is called like this:  scriptname contour runkey std-runname action extra_param1 extra_param2 ...
		      (for-each
		       (lambda (cmd)
			 (print "cmd: " cmd)

				      (need-run    (> last-change last-run)))
				 (print "last-run: " last-run " need-run: " need-run)
				 (if need-run
				     (let* ((key-msg    `((message  . ,(conc ruletype ":" message))
							  (runname  . ,runname)
							  (runtrans . ,runtrans)
							  (action   . ,action)
							  (areas    . ,areas)
							  (target   . ,new-target))))
				       (print "key-msg: " key-msg)
				       (push-run-spec torun contour
						      (if optional  ;; we need to be able to differentiate same contour, different behavior. 
							  (conc runkey ":" optional)  ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
							  runkey)
						      key-msg)))))))
		       val-alist)) ;; iterate over the param split by ;\s*

		     ;; fossil scm based triggers
		     ;;
		     ((fossil)
		      (for-each
		       (lambda (fspec)
			 (print "fspec: " fspec)
			 (let* ((url         (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
				(branch      (cdr fspec))
				(url-is-file (string-match "^(/|file:).*$" url))
				(fname       (conc (common:get-signature url) ".fossil"))
				(fdir        (conc "/tmp/" (current-user-name) "/mtutil_cache")))
			   ;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all.
			   (fossil:clone-or-sync url fname fdir) ;; )
			   (let-values (((datetime node)
					 (fossil:last-change-node-and-time fdir fname branch)))
			     (if (null? starttimes)
				 (push-run-spec torun contour runkey
						`((message  . ,(conc "fossil:" branch "-neverrun"))
						  (runname  . ,(conc runname "-" node))
						  (runtrans . ,runtrans)
						  (areas    . ,areas)
						  (target   . ,runkey)))
				 (if (> datetime last-run) ;; change time is greater than last-run time
				     (push-run-spec torun contour runkey
						    `((message  . ,(conc "fossil:" branch "-" node))
						      (runname  . ,(conc runname "-" node))
						      (runtrans . ,runtrans)
						      (areas    . ,areas)
						      (target   . ,runkey)))))
			     (print "Got datetime=" datetime " node=" node))))
		       val-alist))

		     ;; sensor looking for one or more files newer than reference
		     ;;
		     ((file file-or) ;; one or more files must be newer than the reference


		      (let* ((youngestdat (common:get-youngest (common:bash-glob file-globs)))
			     (youngestmod (car youngestdat)))
			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
			(if (null? starttimes) ;; this target has never been run
			    (push-run-spec torun contour runkey
					   `((message  . "file:neverrun")
					     (action   . ,action)
					     (runtrans . ,runtrans)
					     (target   . ,runkey)
					     (areas    . ,areas)
					     (runname  . ,runname)))
			;; (for-each
			;;  (lambda (starttime) ;; look at the time the last run was kicked off for this contour
			;;    (if (> youngestmod (cdr starttime))
			;; 	   (begin
			;; 	     (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
			    (if (> youngestmod last-run)
				(push-run-spec torun contour runkey
					       `((message  . ,(conc ruletype ":" (cadr youngestdat)))
						 (action   . ,action)
						 (target   . ,runkey)
						 (runtrans . ,runtrans)
						 (areas    . ,areas)
						 (runname  . ,runname)
						 ))))))


		     ;; all globbed files must be newer than the reference
		     ;;
		     ((file-and) ;; all files must be newer than the reference

		      (let* ((youngestdat (common:get-youngest file-globs))
			     (youngestmod (car youngestdat))
			     (success     #t)) ;; any cases of not true, set flag to #f for AND
			;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
			(if (null? starttimes) ;; this target has never been run
			    (push-run-spec torun contour runkey
					   `((message  . "file:neverrun")
					     (runname  . ,runname)
					     (runtrans . ,runtrans)
					     (areas    . ,areas)
					     (target   . ,runkey)
					     (action   . ,action)))
			    ;; NB// I think this is wrong. It should be looking at last-run only.
			    (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
				
				;; 			    (for-each
				;; 			     (lambda (starttime) ;; look at the time the last run was kicked off for this contour
				;; 			       (if (< youngestmod (cdr starttime))
				;; 				   (set! success #f)))
				;; 			     starttimes))
				;; 			(if success
				;; 			    (begin
				;; 			      (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
				(push-run-spec torun contour runkey
					       `((message  . ,(conc ruletype ":" (cadr youngestdat)))
						 (runname  . ,runname)
						 (runtrans . ,runtrans)
						 (target   . ,runkey)
						 (areas    . ,areas)
						 (action   . ,action)
						 ))))))
		     (else (print "ERROR: unrecognised rule \"" ruletype)))))
	       keydats))) ;; sense rules
	  (hash-table-keys rgconf))
	 
	 ;; now have to run populated
	 (for-each
	  (lambda (contour)
	    (print "contour: " contour)
	    (let* ((val       (or (configf:lookup mtconf "contours" contour) ""))
		   (val-alist (val->alist val))                     ;; BEWARE ... NOT the same val-alist as above!
		   (areas     (val-alist->areas val-alist))
		   (selector  (alist-ref 'selector val-alist))
		   (mode-tag  (and selector (string-split-fields "/" selector #:infix)))
		   (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
		   (tag-expr  (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
	      (for-each
	       (lambda (runkeydatset)
		 ;; (print "runkeydatset: ")(pp runkeydatset)
		 (let ((runkey     (car runkeydatset))
		       (runkeydats (cadr runkeydatset)))
		   (for-each
		    (lambda (runkeydat)
		      (for-each
		       (lambda (area)
			 (if (area-allowed? area areas runkey) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
                             (let ((runname (alist-ref 'runname runkeydat))
                                   (runtrans (alist-ref 'runtrans runkeydat))
				   
                                   (reason   (alist-ref 'message runkeydat))
                                   (sched    (alist-ref 'sched   runkeydat))
                                   (action   (alist-ref 'action  runkeydat))
                                   (dbdest   (alist-ref 'dbdest  runkeydat))
                                   (append   (alist-ref 'append  runkeydat))
                                   (target   (or (alist-ref 'target  runkeydat) runkey))) ;; override with target if forced

			       ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH .... 
			       
                               (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
                               (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
                                     ((noaction) #f)
                                     ((run)      (and runname reason))
				 ((sync sync-prepend)     (and reason dbdest))
                                     (else       #f))
                                   ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt