Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,12 @@ ;; 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:)) @@ -790,11 +791,33 @@ (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 ;;====================================================================== Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -124,10 +124,11 @@ ("-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) )) @@ -155,11 +156,12 @@ (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 @@ -292,10 +294,36 @@ (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 @@ -308,76 +336,79 @@ (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)) - (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) - + (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)) + (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 + ) ;; 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 + + (case (string->symbol ruletype) + ((file) + (let* ((file-globs (cdr valparts)) + (youngestdat (common:get-youngest file-globs)) + (youngestmod (car youngestdat))) + ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) + (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 + (if (> youngestmod (cdr starttime)) + (begin + (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) + (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname))))) + starttimes)) + ))))) 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))