;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit commonmod))
;; (declare (uses processmod))
(module commonmod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
srfi-1 files format srfi-13 matchable
srfi-69 ports
regex-case regex hostinfo srfi-4
pkts (prefix dbi dbi:)
stack)
;; (import processmod)
(import stml2)
(include "common_records.scm")
(include "megatest-fossil-hash.scm")
(include "megatest-version.scm")
;; no need to export this
(define *verbosity-cache* (make-hash-table))
(define *verbosity* 0)
;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled
(or (hash-table-ref/default *verbosity-cache* vstr #f)
(let ((res (cond
((number? vstr) vstr)
((not (string? vstr)) 1)
;; ((string-match "^\\s*$" vstr) 1)
(vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
(cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
(verbose 2) ;; ((args:get-arg "-v") 2)
(quiet 0) ;; ((args:get-arg "-q") 0)
(else 1))))
(hash-table-set! *verbosity-cache* vstr res)
res)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
(define (debug:debug-mode n)
(cond
((and (number? *verbosity*) ;; number number
(number? n))
(<= n *verbosity*))
((and (list? *verbosity*) ;; list number
(number? n))
(member n *verbosity*))
((and (list? *verbosity*) ;; list list
(list? n))
(not (null? (lset-intersection! eq? *verbosity* n))))
((and (number? *verbosity*)
(list? n))
(member *verbosity* n))))
(define (debug:setup dmode verbose quiet)
(let ((debugstr (or dmode ;; (args:get-arg "-debug")
(get-environment-variable "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr verbose quiet))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (or dmode ;; (args:get-arg "-debug")
(not (get-environment-variable "MT_DEBUG_MODE")))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
(define (debug:print n e . params)
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
(lambda ()
;; (if *logging*
;; (exec-fn 'db:log-event (apply conc params))
(apply print params)
)))) ;; )
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
;; (if *logging*
;; (exec-fn 'db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
(apply print "ERROR: " params)
))) ;; )
;; pass important messages to stderr
(if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
(apply print "ERROR: " params)
))))
(define (debug:print-info n e . params)
(if (debug:debug-mode n)
(with-output-to-port (if (port? e) e (current-error-port))
(lambda ()
;; (if *logging*
;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
;; (exec-fn 'db:log-event res))
;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
(apply print "INFO: (" n ") " params) ;; res)
)))) ;; )
;; (define (common:low-noise-print alldat waitval . keys)
;; (let* ((key (string-intersperse (map conc keys) "-" ))
;; (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0))
;; (currtime (current-seconds)))
;; (if (> (- currtime lasttime) waitval)
;; (begin
;; (hash-table-set! (alldat-denoise alldat) key currtime)
;; #t)
;; #f)))
;;
;; (define (common:version-signature alldat)
;; (conc (alldat-megatest-version alldat)
;; "-" (substring (alldat-megatest-fossil-hash alldat) 0 4)))
;;
;; (define (common:get-fields cfgdat)
;; (let ((fields (hash-table-ref/default cfgdat "fields" '())))
;; (map car fields)))
;;
;; ;;======================================================================
;; ;; 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))))))))
;;
;; ;;======================================================================
;; ;; C O L O R S
;; ;;======================================================================
;;
;; (define (common:name->iup-color name)
;; (case (string->symbol (string-downcase name))
;; ((red) "223 33 49")
;; ((grey) "192 192 192")
;; ((orange) "255 172 13")
;; ((purple) "This is unfinished ...")))
;;
;; ;; (define (common:get-color-for-state-status state status)
;; ;; (case (string->symbol state)
;; ;; ((COMPLETED)
;; ;; (case (string->symbol status)
;; ;; ((PASS) "70 249 73")
;; ;; ((WARN WAIVED) "255 172 13")
;; ;; ((SKIP) "230 230 0")
;; ;; (else "223 33 49")))
;; ;; ((LAUNCHED) "101 123 142")
;; ;; ((CHECK) "255 100 50")
;; ;; ((REMOTEHOSTSTART) "50 130 195")
;; ;; ((RUNNING) "9 131 232")
;; ;; ((KILLREQ) "39 82 206")
;; ;; ((KILLED) "234 101 17")
;; ;; ((NOT_STARTED) "240 240 240")
;; ;; (else "192 192 192")))
;;
;; (define (common:iup-color->rgb-hex instr)
;; (string-intersperse
;; (map (lambda (x)
;; (number->string x 16))
;; (map string->number
;; (string-split instr)))
;; "/"))
;;
;; ;; dot-locking egg seems not to work, using this for now
;; ;; if lock is older than expire-time then remove it and try again
;; ;; to get the lock
;; ;;
;; (define (common:simple-file-lock fname #!key (expire-time 300))
;; (if (file-exists? fname)
;; (if (> (- (current-seconds)(file-modification-time fname)) expire-time)
;; (begin
;; (handle-exceptions exn #f (delete-file* fname))
;; (common:simple-file-lock fname expire-time: expire-time))
;; #f)
;; (let ((key-string (conc (get-host-name) "-" (current-process-id))))
;; (with-output-to-file fname
;; (lambda ()
;; (print key-string)))
;; (thread-sleep! 0.25)
;; (if (file-exists? fname)
;; (handle-exceptions exn
;; #f
;; (with-input-from-file fname
;; (lambda ()
;; (equal? key-string (read-line)))))
;; #f))))
;;
;; (define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
;; (let ((end-time (+ expire-time (current-seconds))))
;; (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
;; (if got-lock
;; #t
;; (if (> end-time (current-seconds))
;; (begin
;; (thread-sleep! 3)
;; (loop (common:simple-file-lock fname expire-time: expire-time)))
;; #f)))))
;;
;; (define (common:simple-file-release-lock fname)
;; (handle-exceptions
;; exn
;; #f ;; I don't really care why this failed (at least for now)
;; (delete-file* fname)))
;;
;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;; ;;
;; (define (common:lazy-modification-time fpath)
;; (handle-exceptions
;; exn
;; 0
;; (file-modification-time fpath)))
;;
;; ;; find timestamp of newest file associated with a sqlite db file
;; (define (common:lazy-sqlite-db-modification-time fpath)
;; (let* ((glob-list (handle-exceptions
;; exn
;; `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
;; (glob (conc fpath "*"))))
;; (file-list (if (eq? 0 (length glob-list))
;; '("/no/such/file")
;; glob-list)))
;; (apply max
;; (map
;; common:lazy-modification-time
;; file-list))))
;;
;;
;; ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; ;; arguments - thunk, message
;; (define (common:fail-safe thunk warning-message-on-exception)
;; (handle-exceptions
;; exn
;; (begin
;; (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception)
;; (debug:print-info 0 *default-log-port*
;; (string-substitute "\n?Error:" "nonfatal condition:"
;; (with-output-to-string
;; (lambda ()
;; (print-error-message exn) ))))
;; (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
;; #f)
;; (thunk)))
;;
;; (define getenv get-environment-variable)
;; (define (safe-setenv key val)
;; (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables.
;; (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
;; (if (and (string? val)
;; (string? key))
;; (handle-exceptions
;; exn
;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
;; (setenv key val))
;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
;;
;; (define home (getenv "HOME"))
;; (define user (getenv "USER"))
;;
;;
;; ;; returns list of fd count, socket count
;; (define (get-file-descriptor-count #!key (pid (current-process-id )))
;; (list
;; (length (glob (conc "/proc/" pid "/fd/*")))
;; (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
;; )
;; )
;;
)