Megatest

(declare (unit commonmod))

(use srfi-69)

(module commonmod
	*

(import scheme
	chicken

	(prefix sqlite3 sqlite3:)
	data-structures
	extras
	files
	matchable
	md5
	message-digest
	posix
	regex
	regex-case
	srfi-1
	srfi-18
	srfi-69
	typed-records
	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites

;;
(define (get-cfg-areas cfgdat)
  (let ((adat (get-section cfgdat "areas")))
    (map (lambda (entry)
	   `(,(car entry) . 
	     ,(val->alist (cadr entry))))
	 adat)))

;;======================================================================
;; time utils
;;======================================================================

(define (common:human-time)
  (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))

;;======================================================================
;; T I M E   A N D   D A T E
;;======================================================================

;;======================================================================
;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
(define (common:hms-string->seconds tstr)
  (let ((parts     (string-split-fields "\\w+" tstr))
	(time-secs 0)
	;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks
	(trx       (regexp "(\\d+)([smhdMyw])")))
    (for-each (lambda (part)
		(let ((match  (string-match trx part)))
		  (if match
		      (let ((val (string->number (cadr match)))
			    (unt (caddr match)))
			(if val 
			    (set! time-secs (+ time-secs (* val
							    (case (string->symbol unt)
							      ((s) 1)
							      ((m) 60) ;; minutes
							      ((h) 3600)
							      ((d) 86400)
							      ((w) 604800)
							      ((M) 2628000) ;; aproximately one month
							      ((y) 31536000)
							      (else #f))))))))))
	      parts)
    time-secs))
		       
(define (seconds->hr-min-sec secs)
  (let* ((hrs (quotient secs 3600))
	 (min (quotient (- secs (* hrs 3600)) 60))
	 (sec (- secs (* hrs 3600)(* min 60))))
    (conc (if (> hrs 0)(conc hrs "hr ") "")
	  (if (> min 0)(conc min "m ")  "")
	  sec "s")))

(define (seconds->time-string sec)
  (time->string 
   (seconds->local-time sec) "%H:%M:%S"))

(define (seconds->work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "ww%V.%u %H:%M"))

(define (seconds->work-week/day sec)
  (time->string
   (seconds->local-time sec) "ww%V.%u"))

(define (seconds->year-work-week/day sec)
  (time->string
   (seconds->local-time sec) "%yww%V.%w"))

(define (seconds->year-work-week/day-time sec)
  (time->string
   (seconds->local-time sec) "%Yww%V.%w %H:%M"))

(define (seconds->year-week/day-time sec)
  (time->string
   (seconds->local-time sec) "%Yw%V.%w %H:%M"))

(define (seconds->quarter sec)
  (case (string->number
	 (time->string 
	  (seconds->local-time sec)
	  "%m"))
    ((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)
  (let* ((deltat   (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
	 (result   #f)
	 (min      60)
	 (hr       (* 60 60))
	 (day      (* 24 hr))
	 (yr       (* 365 day)) ;; year
	 (mo       (/ yr 12))
	 (wk       (* day 7)))
    (for-each
     (lambda (max-blks)
       (for-each
	(lambda (span) ;; 5 2 1
	  (if (not result)
	      (for-each 
	       (lambda (timeunit timesym) ;; year month day hr min sec
		 (if (not result)
		     (let* ((time-blk (* span timeunit))
			    (num-blks (quotient deltat time-blk)))
		       (if (and (> num-blks 4)(< num-blks max-blks))
			   (let ((first (* (quotient tstart time-blk) time-blk)))
			     (set! result (list span timeunit time-blk first timesym))
			     )))))
	       (list yr mo wk day hr min 1)
	       '(     y  mo w  d   h  m   s))))
	(list 8 6 5 2 1)))
     '(5 10 15 20 30 40 50 500))
    (if values
	(apply values result)
	(values 0 day 1 0 'd))))

;;======================================================================
;; given x y lim return the cron expansion
;;
(define (common:expand-cron-slash x y lim)
  (let loop ((curr x)
	     (res  `()))
    (if (< curr lim)
	(loop (+ curr y) (cons curr res))
	(reverse res))))

;;======================================================================
;; expand a complex cron string to a list of cron strings
;;
;;  x/y   => x, x+y, x+2y, x+3y while x+Ny<max_for_field
;;  a,b,c => a, b ,c
;;
;;   NOTE: with flatten a lot of the crud below can be factored down.
;;
(define (common:cron-expand cron-str)
  (if (list? cron-str)
      (flatten
       (fold (lambda (x res)
	       (if (list? x)
		   (let ((newres (map common:cron-expand x)))
		     (append x newres))
		   (cons x res)))
	     '()
	     cron-str)) ;; (map common:cron-expand cron-str))
      (let ((cron-items (string-split cron-str))
	    (slash-rx   (regexp "(\\d+)/(\\d+)"))
	    (comma-rx   (regexp ".*,.*"))
	    (max-vals   '((min        . 60)
			  (hour       . 24)
			  (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations
			  (month      . 12)
			  (dayofweek  . 7))))
	(if (< (length cron-items) 5) ;; bad spec
	    cron-str ;; `(,cron-str)              ;; just return the string, something downstream will fix it
	    (let loop ((hed  (car cron-items))
		       (tal  (cdr cron-items))
		       (type 'min)
		       (type-tal '(hour dayofmonth month dayofweek))
		       (res  '()))
	      (regex-case
		  hed
		(slash-rx ( _ base incr ) (let* ((basen          (string->number base))
						 (incrn          (string->number incr))
						 (expanded-vals  (common:expand-cron-slash basen incrn (alist-ref type max-vals)))
						 (new-list-crons (fold (lambda (x myres)
									 (cons (conc (if (null? res)
											 ""
											 (conc (string-intersperse res " ") " "))
										     x " " (string-intersperse tal " "))
									       myres))
								       '() expanded-vals)))
					    ;; (print "new-list-crons: " new-list-crons)
					    ;; (fold (lambda (x res)
					    ;; 	    (if (list? x)
					    ;; 		(let ((newres (map common:cron-expand x)))
					    ;; 		  (append x newres))
					    ;; 		(cons x res)))
					    ;; 	  '()
					    (flatten (map common:cron-expand new-list-crons))))
		;;					    (map common:cron-expand (map common:cron-expand new-list-crons))))
		(else (if (null? tal)
			  cron-str
			  (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed)))))))))))

;;======================================================================
;; given a cron string and the last time event was processed return #t to run or #f to not run
;;
;;  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 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 (((     cmin chour cdayofmonth cmonth    cdayofweek)
		     cron-items)
		    ;; 0     1    2        3         4    5      6
		    ((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)))
	  ;; 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)))))

(define (common:extended-cron  cron-str now-seconds-in last-done)
  (let ((expanded-cron (common:cron-expand cron-str)))
    (if (string? expanded-cron)
	(common:cron-event expanded-cron now-seconds-in last-done)
	(let loop ((hed (car expanded-cron))
		   (tal (cdr expanded-cron)))
	  (if (common:cron-event hed now-seconds-in last-done)
	      #t
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal))))))))



;;======================================================================
;; misc stuff
;;======================================================================

(define (common:get-signature str)
  (message-digest-string (md5-primitive) str))

;;======================================================================
;; hash of hashs
;;======================================================================

(define (db:hoh-set! dat key1 key2 val)
  (let* ((subhash (hash-table-ref/default dat key1 #f)))
    (if subhash
	(hash-table-set! subhash key2 val)
	(begin
	  (hash-table-set! dat key1 (make-hash-table))
	  (db:hoh-set! dat key1 key2 val)))))

(define (db:hoh-get dat key1 key2)
  (let* ((subhash (hash-table-ref/default dat key1 #f)))
    (and subhash
	 (hash-table-ref/default subhash key2 #f))))

)