Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -570,10 +570,13 @@ dbpath))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) +(define (common:get-signature str) + (message-digest-string (md5-primitive) str)) + ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) @@ -1731,10 +1734,15 @@ ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) + +;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch +;; +(define (common:date-time->seconds datetime) + (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) ;; given span of seconds tstart to tend ;; find start time to mark and mark delta ;; (define (common:find-start-mark-and-mark-delta tstart tend) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -12,11 +12,11 @@ ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - srfi-18 extras format pkts regex + srfi-18 extras format pkts regex regex-case (prefix dbi dbi:)) ;; zmq extras) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) @@ -185,10 +185,72 @@ (configf:section-var-set! torun contour runkey (cons spec (or (configf:lookup torun contour runkey) '())))) +(define (fossil:clone-or-sync url name dest-dir) + (let ((targ-file (conc dest-dir "/" name))) ;; do not force usage of .fossil extension + (handle-exceptions + exn + (print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn)) + (create-directory dest-dir #t)) + (handle-exceptions + exn + (print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn)) + (if (file-exists? targ-file) + (system (conc "fossil pull --once " url " -R " targ-file)) + (system (conc "fossil clone " url " " targ-file)) + )))) + +(define (fossil:last-change-node-and-time fossils-dir fossil-name branch) + (let* ((fossil-file (conc fossils-dir "/" fossil-name)) + (timeline-port (if (file-read-access? fossil-file) + (handle-exceptions + exn + (begin + (print "ERROR: failed to get timeline from " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn)) + #f) + (open-input-pipe (conc "fossil timeline -t ci -W 0 -n 0 -R " fossil-file))) + #f)) + (get-line (lambda () + (handle-exceptions + exn + (begin + (print "ERROR: failed to read from file " fossil-file " message: " ((condition-property-accessor 'exn 'message) exn)) + #f) + (read-line timeline-port)))) + (date-rx (regexp "^=== (\\S+) ===$")) + (node-rx (regexp "^(\\S+) \\[(\\S+)\\].*\\(.*tags:\\s+([^\\)]+)\\)$"))) + (let loop ((inl (get-line)) + (date #f) + (node #f) + (time #f)) + (cond + ((and date time node) ;; have all, return 'em + (close-input-port timeline-port) + (values (common:date-time->seconds (conc date " " time)) node)) + ((and inl (not (eof-object? inl))) ;; have a line to process + (regex-case inl + (date-rx ( _ newdate ) (loop (get-line) newdate node time)) + ;; 22:47:48 [a024d9e60f] Added *user-hash-data* - a global that can be used in -repl and #{scheme ...} calls by the end user (user: matt tags: v1.63) + (node-rx ( _ newtime newnode alltags ) + (let ((tags (string-split-fields ",\\s*" alltags #:infix))) + (print "tags: " tags) + (if (member branch tags) + (loop (get-line) date newnode newtime) + (loop (get-line) date node time)))) + (else ;; have some unrecognised junk? spit out error message + (print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"") + (loop (get-line) date node time)))) + (else ;; no more datat and last node on branch not found + (close-input-port timeline-port) + (values (common:date-time->seconds (conc date " " time)) node)))))) + +;;====================================================================== +;; GLOBALS +;;====================================================================== + ;; Card types: ;; ;; a action ;; u username (Unix) ;; D timestamp @@ -445,11 +507,13 @@ ;; 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)) + ((scheduled) (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)) @@ -462,10 +526,11 @@ (push-run-spec torun contour runkey `((message . ,(conc ruletype ":" (string-intersperse (string-split (alist-ref 'cron val-alist)) "-"))) (runname . ,runname) (action . ,action) (target . ,target))))))) + ((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 @@ -501,50 +566,79 @@ (action . ,action) (target . ,new-target)))) (print "key-msg: " key-msg) (push-run-spec torun contour runkey key-msg))))))) val-alist)) ;; iterate over the param split by ;\s* + + ((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 + (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)))) + (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)))))) + (print "Got datetime=" datetime " node=" node)))) + val-alist)) + ((file file-or) ;; one or more files must be newer than the reference (let* ((file-globs (alist-ref 'glob val-alist)) (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") (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) - (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" (cadr youngestdat))) - (runname . ,runname) - ))))) - starttimes)) - )) + ;; (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))) + (runname . ,runname) + )))))) + ;; starttimes)) + ((file-and) ;; all files must be newer than the reference (let* ((file-globs (alist-ref 'glob val-alist)) (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)) - (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) - )))))) + ;; 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 + ;; (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) + )))))) (else (print "ERROR: unrecognised rule \"" ruletype))))) keydats))) (hash-table-keys rgconf)) ;; now have to run populated