Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -62,10 +62,12 @@ ;; given a runkey, xlatr-key and other info return one of the following: ;; list of targets, null list to skip processing ;; (define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f)) + (pp aval-alist) + (print "In Map-targets") (let* ((xlatr-key (or xlatr-key-in (conf-get/default mtconf aval-alist 'targtrans))) (proc (hash-table-ref/default *target-mappers* xlatr-key #f))) (if proc (begin @@ -667,10 +669,11 @@ ;; areas - the list of allowed areas from the contour spec -OR- ;; if it is a string then it is the function to use to ;; lookup in *area-checkers* ;; (define (area-allowed? area areas runkey contour mode-patt) + ;;(print "Areas: " areas) (cond ((not areas) #t) ;; no spec ((string? areas) ;; (let ((check-fn (hash-table-ref/default *area-checkers* (string->symbol areas) #f))) (if check-fn @@ -740,14 +743,16 @@ (let-values (((uuid pkt) (command-line->pkt actual-action (append `(("-start-dir" . ,area-path) - ("-msg" . ,reason) + ;;("-msg" . ,reason) + ("-msg" . ,"Script-triggered") ("-contour" . ,contour)) (if (good-val new-runname) `(("-run-name" . ,new-runname)) '()) (if (good-val new-target) `(("-target" . ,new-target)) '()) + (if (good-val area) `(("-area" . ,area)) '()) (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '()) (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '()) (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '()) (if (good-val append-conf) `(("-append-config" . ,append-conf)) '()) (if (equal? action "sync-prepend") '(("-prepend-contour" . " ")) '()) @@ -811,11 +816,11 @@ (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) + (runstarts (find-pkts pdb '(runstart) `((c . ,contour) (t . ,runkey)))) (rspkts (common:get-pkt-alists runstarts)) ;; starttimes is for run start times and is used to know when the last run was launched (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 @@ -883,10 +888,11 @@ (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 = ..." @@ -923,20 +929,92 @@ (let* ((key-msg `((message . ,(conc ruletype ":" message)) (runname . ,new-runname) (runtrans . ,runtrans) (action . ,action) (areas . ,areas) - (target . ,(list new-target)) ;; overriding with result from runing the script + ;;(target . ,(list new-target)) ;; overriding with result from runing the script ))) (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* + ;; script based sensors + ;; + ((area-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) + (print "Areas: " all-areas) + (for-each + (lambda (area) + (if (area-allowed? area "area-needs-to-be-run" runkey contour #f) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...) + + (let* ((script (car cmd)) + (params (cdr cmd)) + (cmd (conc script " " contour " " area " " runkey " " std-runname " " action " " params)) + (res (handle-exceptions + exn + #f + (print "Running " cmd) + (with-input-from-pipe cmd read-lines)))) + (if (and res (not (null? res))) + (let* ((parts (string-split (car res))) ;; + (rem-lines (cdr res)) + (num-parts (length parts)) + (last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned + (new-target (if (> num-parts 1) + (cadr parts) + runkey)) + (new-runname (if (> num-parts 2) + (caddr parts) + std-runname)) + (last-run 9) ;; I think we can do a more valid calculation for this based on the run started packets for this particular area and target + (reason "Area-script-triggered") + (mode-patt #f) + (tag-expr #f) + (sched #f) + (message (if (null? rem-lines) + cmd + (string-intersperse rem-lines "-"))) + (need-run (> last-change last-run))) + (print "last-change: " last-change " last-run: " last-run " need-run: " need-run) + (if need-run + (let* ((key-msg `((message . ,(conc ruletype ":" message)) + (runname . ,new-runname) + (runtrans . ,runtrans) + (action . ,action) + (areas . ,area) + ;;(target . ,(list new-target)) ;; overriding with result from runing the script + )) + (aval (or (configf:lookup mtconf "areas" area) "")) + (aval-alist (common:val->alist aval)) + + (targets (map-targets mtconf aval-alist runkey area contour))) + (pp targets) + (for-each (lambda (target) (create-run-pkt mtconf action area runkey target runname mode-patt + tag-expr pktsdir reason contour sched dbdest append + runtrans)) targets) + + ;;(create-run-pkt mtconf action area runkey target runname + ;; pktsdir reason contour dbdest append + ;; runtrans) + (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) + ))))))) all-areas) + ) val-alist)) ;; iterate over the param split by ;\s* + ;; fossil scm based triggers ;; ((fossil) (for-each (lambda (fspec) @@ -1054,11 +1132,12 @@ (print "contour: " contour " areas=" areas " cval=" cval) (for-each (lambda (runkeydatset) ;; (print "runkeydatset: ")(pp runkeydatset) (let ((runkey (car runkeydatset)) - (runkeydats (cadr runkeydatset))) + (runkeydats (cadr runkeydatset)) + ) (for-each (lambda (runkeydat) (for-each (lambda (area) (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...) @@ -1070,13 +1149,17 @@ (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)) - (targets (or (alist-ref 'target runkeydat) - (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced + (targets ;;(or (alist-ref 'target runkeydat) + (map-targets mtconf aval-alist runkey area contour))) ;; override with target if forced + ;;(targets (or (alist-ref 'target runkeydat) + ;; (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH .... + (print "Targets: " targets) + (print "alist: " (alist-ref 'target runkeydat)) (for-each (lambda (target) (print "Creating pkt for runkey=" runkey " target=" target " 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) @@ -1107,12 +1190,13 @@ (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (or (lookup-param-by-key key) ;; need to check also if it is a switch (lookup-param-by-key key inlst: *switch-keys*)))) - ;; (print "key: " key " val: " val " par: " par) - (if par + (print "key: " key " val: " val " par: " par) + ;;(if (and par (not (string= (symbol->string key) "G"))) + (if (and par) (conc res " " (alist-ref (string->symbol par) param-mapping-alist eq? par) " " val) (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches res (begin (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") @@ -1183,11 +1267,11 @@ (construct-sdat 'P uuid 'T (case (string->symbol action) ((run) "runstart") ((sync) "syncstart") ;; example of translating run -> runstart (else action)) - 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c + 'c (alist-ref 'c pkta) ;; THIS IS WRONG! SHOULD BE 'c 't (alist-ref 't pkta))))) (write-pkt pktsdir ack-uuid ack-pkt)))) (begin ;; access denied! Mark as such (mark-processed pdb (list (alist-ref 'id pktdat))) (let-values (((ack-uuid ack-pkt)