Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1929,17 +1929,19 @@ (sort (hash-table-keys all-times) <)) is-in))))) (define (common:extended-cron cron-str now-seconds-in last-done) (let ((expanded-cron (common:cron-expand cron-str))) - (let loop ((hed (car expanded-cron)) - (tal (cdr expanded-cron))) - (if (cron-event hed now-seconds-in last-done) - #t - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))) + (if (string? expanded-cron) + expanded-cron + (let loop ((hed (car expanded-cron)) + (tal (cdr expanded-cron))) + (if (cron-event hed now-seconds-in last-done) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) ;;====================================================================== ;; C O L O R S ;;====================================================================== Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -1,13 +1,13 @@ [setup] pktsdirs /tmp/pkts /some/other/source [areas] # path-to-area map-target-script(future, optional) -fullrun path=tests/fullrun; targtrans=prefix-contour +fullrun path=tests/fullrun ext-tests path=ext-tests; targtrans=prefix-contour [contours] # mode-patt/tag-expr quick selector=quick/QUICKPATT full areas=fullrun,ext-tests; elector=all/MAXPATT - +all areas=fullrun,ext-tests Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -124,10 +124,12 @@ ("-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) + ("-sync-to" . k) + ("-append-config" . d) ;; misc ("-start-dir" . S) ("-msg" . M) ("-set-vars" . v) ("-debug" . #f) ;; for *verbosity* > 2 @@ -143,18 +145,30 @@ ;; misc ("-repl" . #f) ("-immediate" . I) )) +;; alist to map actions to old megatest commands +(define *action-keys* + '((run . "-run") + (sync . "") + (archive . "-archive") + (set-ss . "-set-state-status"))) + +;; inlst is an alternative input +;; (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*))) +(define (lookup-action-by-key key) + (alist-ref (string->symbol key) *action-keys*)) + ;;====================================================================== ;; U T I L S ;;====================================================================== ;; given a mtutil param, return the old megatest equivalent @@ -402,15 +416,19 @@ ;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db. -;; make a run request pkt from basic data +;; make a run request pkt from basic data, this seriously needs to be refactored +;; i. Take the code that builds the info to submit to create-run-pkt and have it +;; generate the pkt keys directly. +;; ii. Pass the pkt keys and values to this proc and go from there. +;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys ;; ;; Override the run start time record with sched. Usually #f is fine. ;; -(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason contour sched) +(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf) (let* ((area-dat (val->alist (or (configf:lookup mtconf "areas" area) ""))) (area-path (alist-ref 'path area-dat)) (area-xlatr (alist-ref 'targtrans area-dat)) (new-target (if area-xlatr (let ((xlatr-key (string->symbol area-xlatr))) @@ -428,36 +446,40 @@ runkey runname area area-path reason contour mode-patt))) (begin (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.") runkey))) runkey))) + ;; some hacks to remove switches not needed in certain cases + (case (string->symbol (or action "run")) + ((sync) + (set! new-target #f) + (set! runame #f))) (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target) (let-values (((uuid pkt) (command-line->pkt - "run" + (if action action "run") (append - `(("-target" . ,new-target) - ("-run-name" . ,runname) - ("-start-dir" . ,area-path) + `(("-start-dir" . ,area-path) ("-msg" . ,reason) ("-contour" . ,contour)) - (if mode-patt - `(("-mode-patt" . ,mode-patt)) - '()) - (if tag-expr - `(("-tag-expr" . ,tag-expr)) - '()) + (if runname '(("-run-name" . ,runname)) '()) + (if new-target `(("-target" . ,new-target)) '()) + (if mode-patt `(("-mode-patt" . ,mode-patt)) '()) + (if tag-expr `(("-tag-expr" . ,tag-expr)) '()) + (if dbdest `(("-sync-to" . ,dbdest)) '()) + (if append-conf `(("-append-config" . ,append-conf)) '()) (if (not (or mode-patt tag-expr)) - `(("-item-patt" . "%")) - '())) + `(("-testpatt" . "%")) + '()) + ) sched))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) -(use trace)(trace create-run-pkt) +;; (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")))) @@ -468,19 +490,21 @@ (rgconf (car rgconfdat)) (all-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 + + (print "rgentargs: " rgentargs) (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 ":")) + (keyparts (string-split key ":")) ;; contour:ruletype:action (contour (car keyparts)) (len-key (length keyparts)) (ruletype (if (> len-key 1)(cadr keyparts) #f)) (action (if (> len-key 2)(caddr keyparts) #f)) ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params @@ -501,10 +525,12 @@ (lambda (a b)(equal? (car a)(car b))))) ;; remove 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)))) ) + + (print "runkey: " runkey " ruletype: " ruletype " action: " action) ;; 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 @@ -516,20 +542,32 @@ (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist) (let* ((run-name (alist-ref 'run-name val-alist)) (target (alist-ref 'target val-alist)) (crontab (alist-ref 'cron val-alist)) - (action (alist-ref 'action val-alist)) + ;; (action (alist-ref 'action val-alist)) (need-run (common:extended-cron crontab #f last-run)) + (cron-safe-string (string-intersperse (string-split (alist-ref 'cron val-alist)) "-")) (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 - (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" (string-intersperse (string-split (alist-ref 'cron val-alist)) "-"))) - (runname . ,runname) - (action . ,action) - (target . ,target))))))) + (case (string->symbol action) + ((sync) + (push-run-spec torun contour runkey + `((message . ,(conc ruletype ":sync-" cron-safe-string)) + (action . ,action) + (dbdest . ,(alist-ref 'dbdest val-alist)) + (append . ,(alist-ref 'appendconf val-alist))))) + ((run) + (push-run-spec torun contour runkey + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) + (action . ,action) + (target . ,target)))) + (else + (print "ERROR: action \"" action "\" has no scheduled handler") + )))))) ((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 ... @@ -599,19 +637,21 @@ (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) (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) (runname . ,runname) )))))) ;; starttimes)) ((file-and) ;; all files must be newer than the reference @@ -619,11 +659,14 @@ (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 `("file:neverrun" ,runname #f)) + (push-run-spec torun contour runkey + `((message . "file:neverrun") + (runname . ,runname) + (action . ,action))) ;; NB// I think this is wrong. It should be looking at last-run only. (if (> youngestmod last-run) ;; (for-each ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour @@ -634,13 +677,14 @@ ;; (begin ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":" (cadr youngestdat))) (runname . ,runname) + (action . ,action) )))))) (else (print "ERROR: unrecognised rule \"" ruletype))))) - keydats))) + keydats))) ;; sense rules (hash-table-keys rgconf)) ;; now have to run populated (for-each (lambda (contour) @@ -647,13 +691,13 @@ (print "contour: " contour) (let* ((val (or (configf:lookup mtconf "contours" contour) "")) (val-alist (val->alist val)) (areas (string-split (or (alist-ref 'areas val-alist) "") ",")) (selector (alist-ref 'selector val-alist)) - (mode-tag (string-split selector "/")) - (mode-patt (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)) - (tag-expr (if (null? mode-tag) #f (car mode-tag)))) + (mode-tag (and selector (string-split selector "/"))) + (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))) @@ -663,35 +707,50 @@ (lambda (area) (let ((runname (alist-ref 'runname 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 - (if (and runname reason) + (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt) + (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) (and reason dbdest)) + (else #f)) ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt - (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason contour sched) - (print "ERROR: Missing info to make a run call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt) + (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append) + (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) ))) all-areas)) runkeydats))) (let ((res (configf:get-section torun contour))) ;; each contour / target ;; (print "res=" res) res)))) (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) - (if par - (conc res " " (param-translate par) " " val) - res))) - "megatest -run" - pkta)) + (let ((action (or (lookup-action-by-key (alist-ref 'a pkta)) "noaction"))) + (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) + (if (member key '(a Z U D)) ;; a is the action + res + (begin + (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") + res))))) + (conc "megatest " (if (not (member action '("sync"))) + (conc action " ") + "")) + pkta))) + +;; (use trace)(trace pkt->cmdline) (define (write-pkt pktsdir uuid pkt) (if pktsdir (with-output-to-file (conc pktsdir "/" uuid ".pkt")