Megatest

;;
;;  min    hour   dayofmonth month  dayofweek
;; 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)
	  ;; 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
				     (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))))
	   (lambda (month)
	     (for-each ;; dayofmonth
	      (lambda (dom)
		(for-each
		 (lambda (hr) ;; hour
		   (for-each
		    (lambda (minute) ;; minute
	    ;; 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)))
		      (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
	      ;; (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))))))))
  
			  (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)
  (case (string->symbol (string-downcase name))
    ((red)    "223 33 49")

;;
(define (make-runname pre post)
 (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*))
					 (meta  (if (or pmeta smeta)
						    (cdr (or pmeta smeta))

;; 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 
		    `(("-target"     . ,runkey)
		      ("-run-name"   . ,runname)
		      ("-start-dir"  . ,area-path)
		      ("-msg"        . ,reason)
		      ("-contour"    . ,contour))
		    (if mode-patt
			`(("-mode-patt"  . ,mode-patt))
			'())
		    (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))))))

;; collect all needed data and create run pkts for contours with changed inputs
;;

		    (if (not (eq? (length valparts) 6))
			(print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\"")
			(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)
		      (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)))))
				   (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))))
	    (for-each
	     (lambda (runkeydat)
	       (let* ((runkey (car runkeydat))
		      (info   (cadr runkeydat)))
		 (for-each
		  (lambda (area)
		    (if (< (length info) 3)
			(print "ERROR: bad info data for " contour ", " runkey ", " 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)))
			(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))))))


(define (pkt->cmdline pkta)
  (fold (lambda (a res)

# hour           0-23
# day of month   1-31
# 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 * * * *