Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1696,44 +1696,88 @@ ;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 ;; ;; #t => yes, run the job ;; #f => no, do not run the job ;; -(define (common:cron-event cron-str ref-seconds last-done) ;; ref-seconds = #f is NOW. - (let ((cron-items (map string->number (string-split cron-str))) - (ref-time (seconds->local-time (or ref-seconds (current-seconds)))) - (last-done-time (seconds->local-time last-done))) +(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. + (let* ((cron-items (map string->number (string-split cron-str))) + (now-seconds (or now-seconds-in (current-seconds))) + (now-time (seconds->local-time now-seconds)) + (last-done-time (seconds->local-time last-done)) + (all-times (make-hash-table))) (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings #f - (match-let ((( min hour dayofmonth month dayofweek) + (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) cron-items) ;; 0 1 2 3 4 5 6 - ((rsec rmin rhour rdayofmonth rmonth ryr rdayofweek r7 r8 r9) - (vector->list ref-time)) - ((csec cmin chour cdayofmonth cmonth cyr cdayofweek c7 c8 c9) + ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) + (vector->list now-time)) + ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) (vector->list last-done-time))) - (let ((have-match (and (or (not dayofweek) - (eq? dayofweek rdayofweek)) ;; either any dayofweek or they are same - (or (not month) - (eq? month (+ rmonth 1))) ;; posix time month is 0-11 - (or (not dayofmonth) - (eq? dayofmonth rdayofmonth)))) - (hour-match (or (not hour) - (eq? hour rhour))) - (min-match (or (not min) - (eq? min rmin)))) - ;; now inject non-"*" times into the ref-time - (vector-set! ref-time 0 0) ;; set seconds to zero - (if min (vector-set! ref-time 1 min)) - (if hour (vector-set! ref-time 2 hour)) - (let* ((ref-transition-seconds (local-time->seconds ref-time)) - (done-since (> last-done ref-transition-seconds))) - ;; (print "have-match: " have-match " hour-match: " hour-match " min-match: " min-match " ref-transition-seconds - last-done: " (- ref-transition-seconds last-done) " done-since: " done-since) - (and have-match - (not done-since)))))))) - + ;; create all possible time slots + ;; remove invalid slots due to (for example) day of week + ;; get the start and end entries for the ref-seconds (current) time + ;; if last-done > ref-seconds => this is an ERROR! + ;; does the last-done time fall in the legit region? + ;; yes => #f do not run again this command + ;; no => #t ok to run the command + (for-each ;; month + (lambda (month) + (for-each ;; dayofmonth + (lambda (dom) + (for-each + (lambda (hr) ;; hour + (for-each + (lambda (minute) ;; minute + (let ((copy-now (apply vector (vector->list now-time)))) + (vector-set! copy-now 0 0) ;; force seconds to zero + (vector-set! copy-now 1 minute) + (vector-set! copy-now 2 hr) + (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced + (vector-set! copy-now 4 month) + (let* ((copy-now-secs (local-time->seconds copy-now)) + (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector + (if (or (not cdayofweek) + (equal? (vector-ref new-copy 6) + cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified + (if (or (not cdayofmonth) + (equal? (vector-ref new-copy 3) + (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified + (hash-table-set! all-times copy-now-secs new-copy)))))) + (if cmin + `(,cmin) ;; if given cmin, have to use it + (list (- nmin 1) nmin (+ nmin 1))))) ;; minute + (if chour + `(,chour) + (list (- nhour 1) nhour (+ nhour 1))))) ;; hour + (if cdayofmonth + `(,cdayofmonth) + (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) + (if cmonth + `(,cmonth) + (list (- nmonth 1) nmonth (+ nmonth 1)))) + (let ((before #f) + (is-in #f)) + (for-each + (lambda (moment) + (if (and before + (<= before now-seconds) + (>= moment now-seconds)) + (begin + (print) + (print "Before: " (time->string (seconds->local-time before))) + (print "Now: " (time->string (seconds->local-time now-seconds))) + (print "After: " (time->string (seconds->local-time moment))) + (print "Last: " (time->string (seconds->local-time last-done))) + (if (< last-done before) + (set! is-in before)) + )) + (set! before moment)) + (sort (hash-table-keys all-times) <)) + is-in))))) + ;;====================================================================== ;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -241,16 +241,21 @@ (time->string (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M")) ;; collect, translate, collate and assemble a pkt from the command-line ;; -(define (command-line->pkt action args-alist) - (let* ((args-data (if args-alist +(define (command-line->pkt action args-alist sched-in) + (let* ((sched (cond + ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time + ((number? sched-in) sched-in) + (else (current-seconds)))) + (args-data (if args-alist args-alist (hash-table->alist args:arg-hash))) (alldat (apply append (list 'a action - 'U (current-user-name)) + 'U (current-user-name) + 'D sched) (map (lambda (x) (let* ((param (car x)) (value (cdr x)) (pmeta (assoc param *arg-keys*)) (smeta (assoc param *switch-keys*)) @@ -287,11 +292,11 @@ ;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db. ;; make a run request pkt from basic data ;; -(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason contour) +(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason contour sched) (let ((area-path (configf:lookup mtconf "areas" area))) (let-values (((uuid pkt) (command-line->pkt "run" (append @@ -306,11 +311,12 @@ (if tag-expr `(("-tag-expr" . ,tag-expr)) '()) (if (not (or mode-patt tag-expr)) `(("-item-patt" . "%")) - '()))))) + '())) + sched))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) @@ -366,14 +372,15 @@ (let* ((run-name (car valparts)) (crontab (string-intersperse (cdr valparts))) (last-run (if (null? starttimes) ;; never run 0 (apply max (map cdr starttimes)))) - (need-run (common:cron-event crontab #f last-run))) + (need-run (common:cron-event crontab #f last-run)) + (runname (if need-run (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))) (print "last-run: " last-run " need-run: " need-run) (if need-run - (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (string-intersperse (cdr valparts) "-")) ,runname)))))) + (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (string-intersperse (cdr valparts) "-")) ,runname ,need-run)))))) ((file file-or) ;; one or more files must be newer than the reference (let* ((file-globs (cdr valparts)) (youngestdat (common:get-youngest file-globs)) (youngestmod (car youngestdat))) ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) @@ -382,35 +389,35 @@ (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))))) + (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname #f))))) starttimes)) )) ((file-and) ;; all files must be newer than the reference (let* ((file-globs (cdr valparts)) (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 - (configf:section-var-set! torun contour runkey `("file:neverrun" ,runname)) + (configf:section-var-set! 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) - (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname)))))) + (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname #f)))))) ))) keydats))) (hash-table-keys rgconf)) - ;; now have torun populated + ;; now have to run 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)))) @@ -418,14 +425,17 @@ (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 contour))) + (if (< (length info) 3) + (print "ERROR: bad info data for " contour ", " runkey ", " area) + (let ((runname (cadr info)) + (reason (car info)) + (sched (caddr 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 contour sched)))) areas))) (configf:get-section torun contour)))) (hash-table-keys torun)))))) Index: runconfigs.config ================================================================== --- runconfigs.config +++ runconfigs.config @@ -14,6 +14,6 @@ # month 1-12 (or names, see below) # day of week 0-7 (0 or 7 is Sun, or use names) # every friday at midnight run all all:scheduled auto 0 0 0 0 5 -quick:scheduled auto 39 22 * * * +quick:scheduled auto 47 * * * *