; Copyright 2006-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/>.
;;
;; (include "common.scm")
(include "megatest-version.scm")
;; 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-19 srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
nanomsg)
(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
(define *target-mappers* (make-hash-table))
(define *runname-mappers* (make-hash-table))
(define *area-checkers* (make-hash-table))
(define (mtut:stml->string in-stml)
(with-output-to-string
(lambda ()
(s:output-new
(current-output-port)
in-stml))))
;; helpers for mappers/checkers
(define (add-target-mapper name proc)
(hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
(hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
(hash-table-set! *area-checkers* name proc))
;; given a runkey, xlatr-key and other info return one of the following:
;; list of targets, null list to skip processing
;;
(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
(pp aval-alist)
(print "In Map-targets")
(let* ((xlatr-key (or xlatr-key-in
(conf-get/default mtconf aval-alist 'targtrans)))
(proc (hash-table-ref/default *target-mappers* xlatr-key #f)))
(if proc
(begin
(print "Using target mapper: " xlatr-key)
(handle-exceptions
exn
(begin
(print "FAILED TO RUN TARGET MAPPER FOR " area ", called " xlatr-key)
(print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
(proc runkey area contour)))
(begin
(if xlatr-key
(print "ERROR: Failed to find named target translator " xlatr-key ", using original target."))
`(,runkey))))) ;; no proc then use runkey
;; given mtconf and areaconf extract a translator/filter, first look at areaconf
;; then if not found look at default
;;
(define (conf-get/default mtconf areaconf keyname #!key (default #f))
(let ((res (or (alist-ref keyname areaconf)
(configf:lookup mtconf "default" (conc keyname))
default)))
(if res
(string->symbol res)
res)))
;; this needs some thought regarding security implications.
;;
;; i. Check that owner of the file and calling user are same?
;; ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
;; required to use .mtutil.scm.
;;
(if (common:file-exists? "megatest.config")
(if (common:file-exists? ".mtutil.so")
(load ".mtutil.so")
(if (common:file-exists? ".mtutil.scm")
(load ".mtutil.scm"))))
;; main three types of run
;; "-run" => initiate a run
;; "-rerun-clean" => set failed, aborted, killed, etc. (not pass/fail) to NOT_STARTED and kick off run
;; "-rerun-all" => set all tests NOT_STARTED and kick off run again
;; deprecated/do not use
;; "-runall" => synonym for run, do not use
;; "-runtests" => synonym for run, do not use
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; Contour actions
;; import : import pkts
;; dispatch : dispatch queued run jobs from imported pkts
;; rungen : look at input sense list in [rungen] and generate run pkts
(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: mtutil action [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
Run management:
run : initiate or resume a run, already completed and in-progress
tests are not affected.
rerun-clean : clean and rerun all not completed pass/fail tests
rerun-all : clean and rerun entire run
kill-run : kill all tests in run
kill-rerun : kill all tests in run and restart non-completed tests
remove : remove runs
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
Queries:
show [areas|contours... ] : show areas, contours or other section from megatest.config
gendot : generate a graphviz dot file from pkts.
Contour actions:
process : runs import, rungen and dispatch
Trigger propagation actions:
tsend a=b,c=d... : send trigger info to all recpients in the [listeners] section
tlisten -port N : listen for trigger info on port N
Selectors
-immediate : apply this action immediately, default is to queue up actions
-area areapatt1,area2... : apply this action only to the specified areas
-target key1/key2/... : run for key1, key2, etc.
-test-patt p1/p2,p3/... : % is wildcard
-run-name : required, name for this particular test run
-contour contourname : run all targets for contourname, requires -run-name, -target
-state-status c/p,c/f : Specify a list of state and status patterns
-tag-expr tag1,tag2%,.. : select tests with tags matching expression
-mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT
if -testpatt and -tagexpr are not specified
-new state/status : specify new state/status for set-ss
Misc
-start-dir path : switch to this directory before running mtutil
-set-vars V1=1,V2=2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-log logfile : send stdout and stderr to logfile
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
-debug N|N,M,O... : enable debug messages 0-N or N and M and O ...
-list-pkt-keys : list all pkt keys
Utility
db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
gatherdb [propagate] : gather dbs from all areas into /tmp/$USER_megatest/alldbs,
optionally propagate the data to megatest2.0 format
Examples:
# Start a megatest run in the area \"mytests\"
mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
# Start a contour
mtutil run -contour quick -target v1.63/aa3e
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; args and pkt key specs
;;
(define *arg-keys*
;; used keys
;; a - action
'(
("-area" . G) ;; maps to group
("-contour" . c)
("-append-config" . d)
("-state" . e)
("-item-patt" . i)
("-sync-to" . k)
("-new" . l) ;; l (see below) is new-ss
("-run-name" . n)
("-mode-patt" . o)
("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
("-status" . s)
("-target" . t)
("-reqtarg" . R)
("-tag-expr" . x)
;; misc
("-debug" . #f) ;; for *verbosity* > 2
("-load" . #f) ;; load and exectute a scheme file
("-log" . #f)
("-override-user" . #f)
("-msg" . M)
("-start-dir" . S)
("-set-vars" . v)
("-config" . h)
("-time-out" . u)
("-archive" . b)
))
(define *switch-keys*
'(
("-h" . #f)
("-help" . #f)
("--help" . #f)
("-manual" . #f)
("-version" . #f)
;; misc
("-repl" . #f)
("-immediate" . I)
("-preclean" . r)
("-prepend-contour" . w)
("-force" . F)
("-list-pkt-keys" . #f)
))
;; alist to map actions to old megatest commands
(define *action-keys*
'((run . "-run")
(rerun-clean . "-rerun-clean")
(rerun-all . "-rerun-all")
(kill-run . "-kill-runs")
(kill-rerun . "-kill-rerun")
(lock . "-lock")
(unlock . "-unlock")
(sync . "")
(archive . "")
(set-ss . "-set-state-status")
(remove . "-remove-runs")))
;; manually keep this list updated from the keys to
;; the case *action* near the end of this file.
(define *other-actions*
'(run remove rerun set-ss archive kill list
dispatch import rungen process
show gendot db tsend tlisten))
;; Card types:
;;
;; A action
;; U username (Unix)
;; D timestamp
;; T card type
;; a summary list of used card types for helping to not accidentally re-use them
;;
;; ADGIMSTUZabcdefghiklnoprstuvwx
;; utilitarian alist for standard cards
;;
(define *additional-cards*
'(
;; Standard Cards
(A . action )
(D . timestamp )
(T . cardtype )
(U . user ) ;; username
(Z . shar1sum )
;; Extras
(a . runkey ) ;; needed for matching up pkts with target derived from runkey
;; (l . new-ss ) ;; new state/status
(b . branch ) ;; repository branch or tag (fossil or git)
(f . url ) ;; repository URL (e.g. fossil or git)
(g . clone ) ;; existing clone area (cached in /tmp)
))
;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
(fold (lambda (a res)
(if (eq? (cdr a) key)
(car a)
res))
#f
(or inlst *arg-keys*)))
(define (lookup-action-by-key key)
(alist-ref (string->symbol key) *action-keys*))
(define (swizzle-alist lst)
(map (lambda (x)(cons (cdr x)(car x))) lst))
;;======================================================================
;; U T I L S
;;======================================================================
;; given a mtutil param, return the old megatest equivalent
;;
(define (megatest-param->mtutil-param param)
(let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
(alist-ref (string->symbol param) mapping-alist eq? param)
param))
(define val->alist common:val->alist)
(define (push-run-spec torun contour runkey spec)
(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 (common: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
;;======================================================================
;; first token is our action, but only if no leading dash
(define *action* (if (and (> (length (argv)) 1)
(not (string-match "^\\-.*" (cadr (argv)))))
(cadr (argv))
#f))
;; process arguments, extract switches and parameters first
(define remargs (args:get-args
(if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name)
(map car *arg-keys*)
(map car *switch-keys*)
args:arg-hash
0))
;; handle requests for help
;;
(if (or (member *action* '("-h" "-help" "help" "--help"))
(args:any-defined? "-h" "-help" "--help"))
(begin
(print help)
(exit 1)))
(define (print-pkt-keys inlst)
(for-each
(lambda (p)
(let ((sw (car p))
(c (cdr p)))
(print (or c "n/a") "\t" sw)))
inlst))
(define (print-duplicate-keys . all)
(let ((card-hash (make-hash-table)))
(for-each
(lambda (lst)
(for-each
(lambda (card-spec)
(let ((k (cdr card-spec)))
;; (print "card-spec: " card-spec ", k: " k)
(if k (hash-table-set! card-hash k (+ (hash-table-ref/default card-hash k 0) 1)))))
lst))
all)
(for-each
(lambda (k)
(if (> (hash-table-ref card-hash k) 1)
(print k "\t" (hash-table-ref card-hash k))))
(sort (hash-table-keys card-hash) (lambda (a b)(>= (hash-table-ref card-hash a)(hash-table-ref card-hash b)))))
))
(define (print-pkt-key-info)
(print "Argument keys")
(print-pkt-keys *arg-keys*)
(print "\nSwitch keys")
(print-pkt-keys *switch-keys*)
(print "\nAction keys")
(print-pkt-keys *action-keys*)
(print "\nAdditional cards")
(print-pkt-keys (swizzle-alist *additional-cards*))
(print "\nDuplicate keys")
(print-duplicate-keys *arg-keys* *switch-keys* *action-keys* (swizzle-alist *additional-cards*))
(print "\nEnd of report.")
)
;; list packet keys
;;
(if (args:get-arg "-list-pkt-keys")
(begin (print-pkt-key-info)(exit 0)))
;; (print "*action*: " *action*)
;; (let-values (((uuid pkt)
;; (command-line->pkt #f args:arg-hash)))
;; (print pkt))
;; Add args that use remargs here
;;
(if (and (not (null? remargs))
(not (or
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
(member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen
(equal? *action* "show") ;; just keep going if list
)))
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
(if (or (args:any? "-h" "help" "-help" "--help")
(member *action* '("-h" "-help" "--help" "help")))
(begin
(print help)
(exit 1)))
;;======================================================================
;; Nanomsg transport
;;======================================================================
(define-inline (encode data)
(with-output-to-string
(lambda ()
(write data))))
(define-inline (decode data)
(with-input-from-string
data
(lambda ()
(read))))
(define (is-port-in-use port-num)
(let* ((ret #f))
(let-values (((inp oup pid)
(process "netstat" (list "-tulpn" ))))
(let loop ((inl (read-line inp)))
(if (not (eof-object? inl))
(begin
(if (string-search (regexp (conc ":" port-num)) inl)
(begin
;(print "Output: " inl)
(set! ret #t))
(loop (read-line inp)))))))
ret))
;;start a server, returns the connection
;;
(define (start-nn-server portnum )
(let ((rep (nn-socket 'rep)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
(print "ERROR: Failed to start server \"" emsg "\"")
(exit 1))
(nn-bind rep (conc "tcp://*:" portnum)))
rep))
(define (can-user-kill-listner user-info attrib)
(let* ((contacts (alist-ref 'contact attrib))
(user-id (cadddr (cdr user-info)))
(ret #f)
(contact-list (string-split contacts ",")))
(for-each
(lambda (admin)
(if (string-contains user-id (car (string-split admin "@")))
(set! ret #t)))
contact-list)
ret))
;; open connection to server, send message, close connection
;;
(define (open-send-close-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
(let ((req (nn-socket 'req))
(uri (conc "tcp://" host-port))
(res #f)
(contacts (alist-ref 'contact attrib))
(mode (alist-ref 'mode attrib)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;; Send notification
(print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
(if (equal? mode "production")
(begin
(print " Sending email to contacts : " contacts )
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
(sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
(print " mode : " mode " Not sending any emails" ))
#f)
(nn-connect req uri)
(print "Connected to the server " )
(nn-send req msg)
(print "Request Sent")
(let* ((th1 (make-thread (lambda ()
(let ((resp (nn-recv req)))
(nn-close req)
(set! res (if (equal? resp "ok")
#t
#f))))
"recv thread"))
(th2 (make-thread (lambda ()
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
(define (open-send-receive-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
(let ((req (nn-socket 'req))
(uri (conc "tcp://" host-port))
(res #f)
(contacts (alist-ref 'contact attrib))
(mode (alist-ref 'mode attrib)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;; Send notification
(print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
(if (equal? mode "production")
(begin
(print " Sending email to contacts : " contacts )
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
(sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
(print " mode : " mode " Not sending any emails" ))
#f)
(nn-connect req uri)
(print "Connected to the server " )
(nn-send req msg)
(print "Request Sent")
;; receive code here
;;(print (nn-recv req))
(let* ((th1 (make-thread (lambda ()
(let ((resp (nn-recv req)))
(nn-close req)
(print resp)
(set! res (if (equal? resp "ok")
#t
#f))))
"recv thread"))
(th2 (make-thread (lambda ()
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
;;======================================================================
;; Runs
;;======================================================================
;; make a runname
;;
(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
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;; extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
(let* ((sched (cond
((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
((number? sched-in) sched-in)
(else (current-seconds))))
(user (if (and args-alist (hash-table? args-alist))
(hash-table-ref/default args-alist "-override-user" (current-user-name))
(current-user-name)))
(args-data (if args-alist
(if (hash-table? args-alist) ;; seriously?
(hash-table->alist args-alist)
args-alist)
(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
(alldat (apply append
(list 'A action
'U user
'D sched)
(if area-path
(list 'S area-path) ;; the area-path is mapped to the start-dir
'())
(if (list? extra-dat)
extra-dat
(begin
(debug:print 0 *default-log-port* "ERROR: command-line->pkt received bad extra-dat " extra-dat)
'()))
(map (lambda (x)
(let* ((param (car x))
(value (cdr x))
(pmeta (assoc param *arg-keys*)) ;; translate the card key to a megatest switch or parameter
(smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
(meta (if (or pmeta smeta)
(cdr (or pmeta smeta)) ;; found it?
#f)))
(if meta ;; construct the switch/param pair.
(list meta value)
'())))
(filter cdr args-data)))))
(print "Alldat: " alldat ) ;;Do not remove. This is uesed by other applications to calculate z card
;(exit)
(add-z-card
(apply construct-sdat alldat))))
(define (simple-setup start-dir-in)
(let* ((start-dir (or start-dir-in "."))
(mtconfig (or (args:get-arg "-config") "megatest.config"))
(mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
mtconfig
;; environ-patt: "env-override"
given-toppath: start-dir
;; pathenvvar: "MT_RUN_AREA_HOME"
))
(mtconf (if mtconfdat (car mtconfdat) #f)))
;; we set some dynamic data in a section called "scratchdata"
(if mtconf
(begin
(configf:section-var-set! mtconf "scratchdat" "toppath" start-dir)))
;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath"))
mtconfdat))
;;======================================================================
;; Areas
;;======================================================================
;; look for areas=a1,a2,a3 OR areafn=somefuncname
;;
(define (val-alist->areas val-alist)
(let ((areas-string (alist-ref 'areas val-alist))
(areas-procname (alist-ref 'areafn val-alist)))
(if areas-procname ;; areas-procname take precedence
areas-procname
(string-split (or areas-string "") ","))))
;; area - the current area under consideration
;; areas - the list of allowed areas from the contour spec -OR-
;; if it is a string then it is the function to use to
;; lookup in *area-checkers*
;;
(define (area-allowed? area areas runkey contour mode-patt)
;;(print "Areas: " areas)
(cond
((not areas) #t) ;; no spec
((string? areas) ;;
(let ((check-fn (hash-table-ref/default *area-checkers* (string->symbol areas) #f)))
(if check-fn
(check-fn area runkey contour mode-patt)
#f)))
((list? areas)(member area areas))
(else #f))) ;; shouldn't get here
(define (get-area-names mtconf)
(map car (configf:get-section mtconf "areas")))
;;======================================================================
;; Pkts for remote control
;;======================================================================
;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
;; make a run request pkt from basic data, this seriously needs to be refactored
;; i. Take the code that builds the info to submit to create-run-pkt and have it
;; generate the pkt keys directly.
;; ii. Pass the pkt keys and values to this proc and go from there.
;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
;;
;; Override the run start time record with sched. Usually #f is fine.
;;
(define (create-run-pkt mtconf action area runkey target runname mode-patt
tag-expr pktsdir reason contour sched dbdest append-conf
runtrans)
(let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
(area-dat (common:val->alist (or (configf:lookup mtconf "areas" area) "")))
(area-path (alist-ref 'path area-dat))
;; (area-xlatr (alist-ref 'targtrans area-dat))
;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f))
(new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
(mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
(if (and callname
(not (equal? callname "auto"))
(not mapper))
(print "No mapper " callname " for area " area " using " callname " as the runname"))
(if mapper
(handle-exceptions
exn
(begin
(print-call-chain)
(print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runname)
(print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
(mapper runkey runname area area-path reason contour mode-patt))
(case callname
((auto #f) runname)
(else runtrans)))))
(new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
(actual-action (if action
(if (equal? action "sync-prepend")
"sync"
action)
"run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
;; some hacks to remove switches not needed in certain cases
(case (string->symbol (or action "run"))
((sync sync-prepend)
(set! new-target #f)
(set! runame #f)))
;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target)
(let-values (((uuid pkt)
(command-line->pkt
actual-action
(append
`(("-start-dir" . ,area-path)
;;("-msg" . ,reason)
("-msg" . ,"Script-triggered")
("-contour" . ,contour))
(if (good-val new-runname) `(("-run-name" . ,new-runname)) '())
(if (good-val new-target) `(("-target" . ,new-target)) '())
(if (good-val area) `(("-area" . ,area)) '())
(if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '())
(if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '())
(if (good-val dbdest) `(("-sync-to" . ,dbdest)) '())
(if (good-val append-conf) `(("-append-config" . ,append-conf)) '())
(if (equal? action "sync-prepend") '(("-prepend-contour" . " ")) '())
(if (not (or mode-patt tag-expr))
`(("-testpatt" . "%"))
'())
(if (or (not action)
(equal? action "run"))
`(("-preclean" . " ")
("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder
'())
)
sched
extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched
)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))
;; (use trace)(trace create-run-pkt)
(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
(let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
(packets-generated 0))
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
(rgconf (car rgconfdat))
(all-areas (map car (configf:get-section mtconf "areas")))
(contours (configf:get-section mtconf "contours"))
(torun (make-hash-table)) ;; target => ( ... info ... )
(rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
;;(print "rgentargs: " rgentargs)
(for-each
(lambda (runkey)
(let* ((keydats (configf:get-section rgconf runkey)))
(for-each
(lambda (sense) ;; these are the sense rules
(let* ((key (car sense))
(val (cadr sense))
(keyparts (string-split key ":")) ;; contour:ruletype:action:optional
(contour (car keyparts))
(len-key (length keyparts))
(ruletype (if (> len-key 1)(cadr keyparts) #f))
(action (if (> len-key 2)(caddr keyparts) #f))
(optional (if (> len-key 3)(cadddr keyparts) #f))
;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
(val-alist (common:val->alist val))
(runname (make-runname "" ""))
(runtrans (alist-ref 'runtrans val-alist))
;; these may or may not be defined and not all are used in each handler type in the case below
(run-name (alist-ref 'run-name val-alist))
(target (alist-ref 'target val-alist))
(crontab (alist-ref 'cron val-alist))
(areas (val-alist->areas val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
(dbdest (alist-ref 'dbdest val-alist))
(appendconf (alist-ref 'appendconf val-alist))
(file-globs (alist-ref 'glob val-alist))
(runstarts (find-pkts pdb '(runstart) `((c . ,contour)
(t . ,runkey))))
(rspkts (common:get-pkt-alists runstarts))
;; starttimes is for run start times and is used to know when the last run was launched
(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr starttimes))))
;; synctimes is for figuring out the last time a sync was done
(syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
(sspkts (common:get-pkt-alists syncstarts))
(synctimes (common:get-pkt-times sspkts))
(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr synctimes))))
)
(let ((delta (lambda (x)
(round (/ (- (current-seconds) x) 60)))))
(if (args:get-arg "-target")
(if (string= (args:get-arg "-target") runkey)
(begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))
(print "val-alist=" val-alist " runtrans=" runtrans))
(if #f (print "skipping: " runkey)))
(begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))
(print "val-alist=" val-alist " runtrans=" runtrans))
))
;; look in runstarts for matching runs by target and contour
;; 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))
;; Handle crontab like rules
;;
((scheduled)
(if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
(print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
(let* (
;; (action (alist-ref 'action val-alist))
(cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X"))
(runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
;; (print "last-run: " last-run " need-run: " need-run)
;; (if need-run
(case (string->symbol action)
((sync sync-prepend)
(if (common:extended-cron crontab #f last-sync)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":sync-" cron-safe-string))
(action . ,action)
(dbdest . ,dbdest)
(append . ,appendconf)
(areas . ,areas)))))
((run)
(if (common:extended-cron crontab #f last-run)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" cron-safe-string))
(runname . ,runname)
(runtrans . ,runtrans)
(action . ,action)
(areas . ,areas)
(target . ,target)))))
((remove)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" cron-safe-string))
(runname . ,runname)
(runtrans . ,runtrans)
(action . ,action)
(areas . ,areas)
(target . ,target))))
(else
(print "ERROR: action \"" action "\" has no scheduled handler")
)))))
;; script based sensors
;;
((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
(lambda (cmd)
(print "cmd: " cmd)
(let* ((script (car cmd))
(params (cdr cmd))
(cmd (conc script " " contour " " runkey " " std-runname " " action " " params))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(if (and res (not (null? res)))
(let* ((parts (string-split (car res))) ;;
(rem-lines (cdr res))
(num-parts (length parts))
(last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned
(new-target (if (> num-parts 1)
(cadr parts)
runkey))
(new-runname (if (> num-parts 2)
(caddr parts)
std-runname))
(message (if (null? rem-lines)
cmd
(string-intersperse rem-lines "-")))
(need-run (> last-change last-run)))
(print "last-run: " last-run " need-run: " need-run)
(if need-run
(let* ((key-msg `((message . ,(conc ruletype ":" message))
(runname . ,new-runname)
(runtrans . ,runtrans)
(action . ,action)
(areas . ,areas)
;;(target . ,(list new-target)) ;; overriding with result from runing the script
)))
(print "key-msg: " key-msg)
(push-run-spec torun contour
(if optional ;; we need to be able to differentiate same contour, different behavior.
(conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
runkey)
key-msg)))))))
val-alist)) ;; iterate over the param split by ;\s*
;; script based sensors
;;
((area-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
(lambda (cmd)
;;(print "cmd: " cmd)
;;(print "Areas: " all-areas)
(for-each
(lambda (area)
;;(print "Area: " area)
;;(print "Target: " runkey)
;;(print "OR: " (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" ))))
;;(print "Packets generated: " packets-generated)
;;(print "Comparison: " (< packets-generated 4))
;;(print "Full Comparison: "
;; (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000))
;; (if (args:get-arg "-target")
;; (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f)
;; (area-allowed? area "area-needs-to-be-run" runkey contour #f))))
;;(print "Area Allowed: " (area-allowed? area "area-needs-to-be-run" runkey contour #f))
;Add code to check whether area is valid
(if
;; This code checks whether the target has been passed in via argument, and only runs the specified target
(and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000))
(if (args:get-arg "-target")
(if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f)
(area-allowed? area "area-needs-to-be-run" runkey contour #f)))
(let* ((script (car cmd))
(params (cdr cmd))
(cmd (conc script " " contour " " area " " runkey " " std-runname " " action " " params))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines)))
(cval (or (configf:lookup mtconf "contours" contour) ""))
(cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
;;(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-alist))
(mode-tag (and selector (string-split-fields "/" selector #:infix)))
(mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
(tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))
)
(if (and res (not (null? res)))
(let* ((parts (string-split (car res))) ;;
(rem-lines (cdr res))
(num-parts (length parts))
(last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned
(new-target (if (> num-parts 1)
(cadr parts)
runkey))
(new-runname (if (> num-parts 2)
(caddr parts)
std-runname))
(area-pkts (find-pkts pdb '(runstart) `((c . ,contour)
(t . ,runkey)
(G . ,area ))))
(runstarts (filter (lambda (my-pkt)
;;(print my-pkt)
(not (contains (map
(lambda (c)
;;(print "C: " c "PKT: " my-pkt)
(let* ((ctype (car c))
(rx (cdr c))
;;(foo2 (print "Ctype: " ctype " RX: " rx))
(pkt (alist-ref 'pkt my-pkt))
(apkt (pkt->alist pkt))
(cdat (alist-ref ctype apkt)))
(if rx
(if (string-match "t" (symbol->string ctype) )
(begin (if #f (print "RX: " rx " CDAT: " (string-join (take (string-split cdat "/") 3) "/"))) (if cdat (string-match rx (string-join (take (string-split cdat "/") 3) "/")) #f))
(begin (if #f (print "RX: " rx " CDAT: " cdat)) (if cdat (string-match rx cdat) #f))) #f)
))
`((c . ,contour) (t . ,runkey) (G . ,area))) #f)))
area-pkts))
;;(test (pp runstarts))
(rspkts (common:get-pkt-alists runstarts))
;; starttimes is for run start times and is used to know when the last run was launched
(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr starttimes))))
;; (last-run 9) ;; I think we can do a more valid calculation for this based on the run started packets for this particular area and target
(reason "Area-script-triggered")
;;(mode-patt #f)
;;(tag-expr #f)
(sched #f)
(message (if (null? rem-lines)
cmd
(string-intersperse rem-lines "-")))
(need-run (> last-change last-run)))
(print "last-change: " last-change " last-run: " last-run " need-run: " need-run)
(if need-run
(let* ((key-msg `((message . ,(conc ruletype ":" message))
(runname . ,new-runname)
(runtrans . ,runtrans)
(action . ,action)
(areas . ,area)
;;(target . ,(list new-target)) ;; overriding with result from runing the script
))
(aval (or (configf:lookup mtconf "areas" area) ""))
(aval-alist (common:val->alist aval))
(targets (map-targets mtconf aval-alist runkey area contour)))
(pp targets)
(for-each (lambda (target)
(create-run-pkt mtconf action area runkey target new-runname mode-patt
tag-expr pktsdir reason contour sched dbdest append
runtrans)
(set! packets-generated (+ packets-generated 1))
) targets)
;; Add filter for targets
;;(create-run-pkt mtconf action area runkey target runname
;; pktsdir reason contour dbdest append
;; runtrans)
(print "key-msg: " key-msg)
;;(push-run-spec torun contour
;; (if optional ;; we need to be able to differentiate same contour, different behavior.
;; (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
;; runkey)
;; key-msg)
)))))
(if (>= packets-generated (string->number (configf:lookup mtconf "setup" "max_packets_per_run"))) (print "Skipping area: " area " and target: " runkey " due to packets-generated: " packets-generated " higher than " (configf:lookup mtconf "setup" "max_packets_per_run"))))
) (filter (lambda (x) (if (not (args:get-arg "-area")) #t (if (string= x (args:get-arg "-area")) #t #f))) all-areas))
) val-alist)) ;; iterate over the param split by ;\s*
;; fossil scm based triggers
;;
((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 --- for now, clone 'em all.
(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))
(runtrans . ,runtrans)
(areas . ,areas)
;; (target . ,runkey)
(action . ,action)
))
(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))
(runtrans . ,runtrans)
(areas . ,areas)
;; (target . ,runkey)
(action . ,action)
(branch . ,branch)
(url . ,url)
(clone . ,(conc fdir "/" fname))
))))
(print "Got datetime=" datetime " node=" node))))
val-alist))
;; sensor looking for one or more files newer than reference
;;
((file file-or) ;; one or more files must be newer than the reference
(let* ((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")
(action . ,action)
(runtrans . ,runtrans)
;; (target . ,runkey)
(areas . ,areas)
(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)
(if (> youngestmod last-run)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(action . ,action)
;; (target . ,runkey)
(runtrans . ,runtrans)
(areas . ,areas)
(runname . ,runname)
))))))
;; all globbed files must be newer than the reference
;;
((file-and) ;; all files must be newer than the reference
(let* ((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
`((message . "file:neverrun")
(runname . ,runname)
(runtrans . ,runtrans)
(areas . ,areas)
;; (target . ,runkey)
(action . ,action)))
;; NB// I think this is wrong. It should be looking at last-run only.
(if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
;; (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)
(runtrans . ,runtrans)
;; (target . ,runkey)
(areas . ,areas)
(action . ,action)
))))))
(else (print "ERROR: unrecognised rule \"" ruletype)))))
keydats))) ;; sense rules
(hash-table-keys rgconf))
;; now have to run populated
(for-each
(lambda (contour)
(let* ((cval (or (configf:lookup mtconf "contours" contour) ""))
(cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-alist))
(mode-tag (and selector (string-split-fields "/" selector #:infix)))
(mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
(tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
(print "contour: " contour " areas=" areas " cval=" cval)
(for-each
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(runkeydats (cadr runkeydatset))
)
(for-each
(lambda (runkeydat)
(for-each
(lambda (area)
(if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
(let* ((aval (or (configf:lookup mtconf "areas" area) ""))
(aval-alist (common:val->alist aval))
(runname (alist-ref 'runname runkeydat))
(runtrans (alist-ref 'runtrans runkeydat))
(reason (alist-ref 'message runkeydat))
(sched (alist-ref 'sched runkeydat))
(action (alist-ref 'action runkeydat))
(dbdest (alist-ref 'dbdest runkeydat))
(append (alist-ref 'append runkeydat))
(targets ;;(or (alist-ref 'target runkeydat)
(map-targets mtconf aval-alist runkey area contour))) ;; override with target if forced
;;(targets (or (alist-ref 'target runkeydat)
;; (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced
;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH ....
;;(print "Targets: " targets)
;;(print "alist: " (alist-ref 'target runkeydat))
(for-each
(lambda (target)
(print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt)
(if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action
((noaction) #f)
((run) (and runname reason))
((sync sync-prepend) (and reason dbdest))
(else #f))
;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
(create-run-pkt mtconf action area runkey target runname mode-patt
tag-expr pktsdir reason contour sched dbdest append
runtrans)
(print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
))
targets))
(print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas)))
all-areas))
runkeydats)))
(let ((res (configf:get-section torun contour))) ;; each contour / target
;; (print "res=" res)
res))))
(hash-table-keys torun)))))))
(define (pkt->cmdline pkta)
(let* ((param-mapping-alist (common:get-param-mapping flavor: 'switch-symbol))
(action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))
(action-param (case (string->symbol action)
((-set-state-status) (conc (alist-ref 'l pkta) " "))
(else ""))))
(fold (lambda (a res)
(let* ((key (car a)) ;; get the key name
(val (cdr a))
(par (or (lookup-param-by-key key) ;; need to check also if it is a switch
(lookup-param-by-key key inlst: *switch-keys*))))
(print "key: " key " val: " val " par: " par)
;;(if (and par (not (string= (symbol->string key) "G")))
(if (and par)
(conc res " " (alist-ref (string->symbol par) param-mapping-alist eq? par) " " val)
(if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
res
(begin
(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
res)))))
(conc "megatest " (if (not (member action '("sync")))
(conc action " " action-param)
""))
pkta)))
;; (use trace)(trace pkt->cmdline)
(define (write-pkt pktsdir uuid pkt)
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
(print "ERROR: cannot process commands without a pkts directory")))
(define (check-if-modepatt-defined pkta notification-hook pktfile)
(let* ((start-dir (alist-ref 'S pkta))
(target (or (alist-ref 'R pkta) (alist-ref 't pkta)))
(patt (alist-ref 'o pkta))
(uuid (alist-ref 'Z pkta))
(cmd (conc "megatest -show-runconfig -target " target " -start-dir " start-dir))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(let loop ((hed (car res))
(tail (cdr res)))
(if (string-contains hed patt)
#t
(if (null? tail)
(begin
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg INVALID_MODEPATT")))
(print "Running " notification-cmd)
(system notification-cmd)))
#f)
(loop (car tail) (cdr tail)))))))
(define (check-if-target-defined pkta notification-hook pktfile)
(let* ((start-dir (alist-ref 'S pkta))
(target (alist-ref 'R pkta))
(uuid (alist-ref 'Z pkta))
(cmd (conc "megatest -list-targets -start-dir " start-dir))
(res (handle-exceptions
exn
#f
(print "Running " cmd)
(with-input-from-pipe cmd read-lines))))
(if (member target res)
#t
(begin
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg INVALID_TARGET")))
(print "Running " notification-cmd)
(system notification-cmd)))
#f))))
(define (validate-cmd cmd pkta notification-hook pktfile)
(let ((ret #t))
(if (string-contains cmd "-reqtarg")
(if (check-if-target-defined pkta notification-hook pktfile)
(begin
(print "Target is valid")
(if (string-contains cmd "-modepatt")
(if (check-if-modepatt-defined pkta notification-hook pktfile)
(print "Modepatt is valid")
(set! ret #f))))
(set! ret #f))
(if (string-contains cmd "-modepatt")
(if (check-if-modepatt-defined pkta notification-hook pktfile)
(print "Modepatt is valid")
(set! ret #f))))
ret))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
(let ((logdir
(if (if (not (directory? "logs"))
(handle-exceptions
exn
#f
(create-directory "logs")
#t)
#t)
"logs"
"/tmp"))
(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
(maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
(configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
"1.1")))
(notification-hook (if (configf:lookup mtconf "setup" "notification-hook")
(configf:lookup mtconf "setup" "notification-hook")
#f)))
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
(rgconf (car rgconfdat))
(areas (configf:get-section mtconf "areas"))
(contours (configf:get-section mtconf "contours"))
(pkts (find-pkts pdb '(cmd) '()))
(torun (make-hash-table)) ;; target => ( ... info ... )
(rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
(sqlite3:set-busy-handler! (dbi:db-conn pdb) (sqlite3:make-busy-timeout 10000))
(for-each
(lambda (pktdat)
(let* ((pkta (alist-ref 'apkt pktdat))
(action (alist-ref 'A pkta))
(cmdline (pkt->cmdline pkta))
(uuid (alist-ref 'Z pkta))
(user (alist-ref 'U pkta))
(area (alist-ref 'G pkta))
(logf (conc logdir "/" uuid "-run.log"))
(pktfile (conc pktsdir "/" uuid ".pkt"))
(fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
(if (check-access user mtconf action area)
(if (and (> cpuload maxload)
(member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit
(begin
(print "WARNING: cpuload too high, skipping processing of " uuid " due to " cpuload " > " maxload)
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg HIGH_LOAD")))
(print "Running " notification-cmd)
(system notification-cmd))))
(begin
;; if modepatt used chek if it is defined for the target. If -reqtarg check if target exist.
(if (validate-cmd fullcmd pkta notification-hook pktfile)
(begin
(print "RUNNING: " fullcmd)
(system fullcmd) ;; replace with process ...
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T (case (string->symbol action)
((run) "runstart")
((sync) "syncstart") ;; example of translating run -> runstart
(else action))
'G (alist-ref 'G pkta)
'c (alist-ref 'c pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg RUN_LAUNCHED --contour " (caar contours) " --log_path " logf )))
(print "Running " notification-cmd)
(system notification-cmd))))
(begin
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T "invalid-input"
'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))))))
(begin ;; access denied! Mark as such
(mark-processed pdb (list (alist-ref 'id pktdat)))
(let-values (((ack-uuid ack-pkt)
(add-z-card
(construct-sdat 'P uuid
'T "access-denied"
'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c
't (alist-ref 't pkta)))))
(write-pkt pktsdir ack-uuid ack-pkt))
(if notification-hook
(let* ((notification-cmd (conc notification-hook " --pkt " pktfile " --msg ACCESS_DENIED")))
(print "Running " notification-cmd)
(system notification-cmd)))))))
pkts))))))
(define (check-access user mtconf action area)
;; NOTE: Need control over defaults. E.g. default might be no access
(let* ((access-ctrl (hash-table-exists? mtconf "access")) ;; if there is an access section the default is to REQUIRE enablement/access
(access-list (map (lambda (x)
(string-split x ":"))
(string-split (or (configf:lookup mtconf "access" area) ;; userid:rightstype userid2:rightstype2 ...
(if access-ctrl
"*:none" ;; nobody has access by default
"*:all")))))
(access-types-dat (configf:get-section mtconf "accesstypes")))
(debug:print 2 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area)
(if access-ctrl
(let* ((user-access (or (assoc user access-list)
(assoc "*" access-list)))
(access-type (if user-access
(cadr user-access)
#f))
(access-types (let ((res (alist-ref access-type access-types-dat equal?)))
(if res (car res) res)))
(allowed-actions (string-split (or access-types ""))))
(debug:print 2 *default-log-port* "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type)
(cond
((and access-types (member action allowed-actions))
;; (print "Access granted for " user " for " action)
#t)
(else
;; (print "Access denied for " user " for " action)
#f))))))
(define (open-logfile logpath)
(condition-case
(let* ((log-dir (or (pathname-directory logpath) ".")))
(if (not (directory-exists? log-dir))
(system (conc "mkdir -p " log-dir)))
(open-output-file logpath))
(exn ()
(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
(define *didsomething* #t)
(exit 1))))
(define (get-pkts-dir mtconf)
(let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)))
pktsdir))
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
(if (args:get-arg "-log") ;; redirect the log always when a server
(handle-exceptions
exn
(begin
(print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn))
)
(let* ((tl (args:get-arg "-log")) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
(logf (args:get-arg "-log")) ;; use -log unless we are a server, then craft a logfile name
(oup (open-logfile logf)))
;(if (not (args:get-arg "-log"))
; (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
(print *default-log-port* "Sending log output to " logf)
(set! *default-log-port* oup)
)))
(if *action*
(case (string->symbol *action*)
((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun lock unlock)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
(areasec (if area (configf:lookup mtconf "areas" area) #f))
(areadat (if areasec (common:val->alist areasec) #f))
(area-path (if areadat (alist-ref 'path areadat) #f))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(adjargs (hash-table-copy args:arg-hash))
(new-ss (args:get-arg "-new")))
;; check a few things
(cond
((and area (not area-path))
(print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
(exit 1))
((not area)
(print "ERROR: no area specified. Use -area <areaname>")
(exit 1))
(else
(let* ((usr-admin (check-access (current-user-name) mtconf "override" area))
(user (if (and usr-admin (args:get-arg "-override-user"))
(args:get-arg "-override-user")
(current-user-name))))
; (print "user 123 " usr-admin )
;(exit 1)
(if (and (not usr-admin) (args:get-arg "-override-user"))
(begin
(print user " does not have access to override user")
(exit 1)))
(if (check-access user mtconf *action* area);; check rights
(print "Access granted for " *action* " action by " user)
(begin
(print "Access denied for " *action* " action by " user)
(exit 1))))))
;; (for-each
;; (lambda (key)
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
(print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log"))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen process)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "scratchdat" "toppath")))
(case (string->symbol *action*)
((process) (begin
(common:load-pkts-to-db mtconf)
(generate-run-pkts mtconf toppath)
(common:load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)))
((import) (common:load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath)))))
;; misc
((show)
(if (> (length remargs) 0)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(sect-dat (configf:get-section mtconf (car remargs))))
(if sect-dat
(for-each
(lambda (entry)
(if (> (length entry) 1)
(print (car entry) " " (cadr entry))
(print (car entry))))
sect-dat)
(print "No section \"" (car remargs) "\" found")))
(print "ERROR: list requires section parameter; areas, setup or contours")))
((gendot)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat)))
(common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ...
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir conn)
;; pktspec display-fields
(make-report "out.dot" conn
'((cmd . ((parent . P)
(user . M)
(target . t)))
(runstart . ((parent . P)
(target . t)))
(runtype . ((parent . P)))) ;; pktspec
'(P U t) ;;
))))) ;; no ptypes listed (ptypes are strings of pkt types to read from db
((db)
(if (null? remargs)
(print "ERROR: missing sub command for db command")
(let ((subcmd (car remargs)))
(case (string->symbol subcmd)
((pgschema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-pg.sql")))
(if (common:file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((sqlite3schema)
(let* ((install-home (common:get-install-area))
(schema-file (conc install-home "/share/db/mt-sqlite3.sql")))
(if (common:file-exists? schema-file)
(system (conc "/bin/cat " schema-file)))))
((junk)
(rmt:get-keys))))))
((tsend)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(time-out (if (args:get-arg "-time-out")
(string->number (args:get-arg "-time-out"))
5))
(listeners (configf:get-section mtconf "listeners"))
(user-info (user-information (current-user-id)))
(prev-seen (make-hash-table))) ;; catch duplicates
(if user-info
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
(if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-close-nn host-port msg attrib timeout: time-out )))
listeners))
(begin
(debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
(exit 1))))))
((tquery)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(time-out (if (args:get-arg "-time-out")
(string->number (args:get-arg "-time-out"))
5))
(listeners (configf:get-section mtconf "listeners"))
(user-info (user-information (current-user-id)))
(prev-seen (make-hash-table))) ;; catch duplicates
(if user-info
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
(if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-receive-nn host-port msg attrib timeout: time-out )))
listeners))
(begin
(debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
(exit 1))))))
((tquerylisten)
(if (null? remargs)
(print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
(let ((portnum (string->number (car remargs))))
(if (not portnum)
(print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
(begin
(if (not (is-port-in-use portnum))
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(contact (configf:lookup mtconf "listener" "owner"))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages.")
(set-signal-handler! signal/int (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
(set-signal-handler! signal/term (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
;(set-signal-handler! signal/term special-signal-handler)
(let loop ((instr (nn-recv rep)))
;;(nn-send rep "3.9")
(with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1")
(lambda()
(let loop ((inl (read-line)))
(if (not (eof-object? inl))
(begin
;;(print "fdk73: " inl ":")
;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl))))
(nn-send rep inl)
(loop(read-line)))
))
)
)
;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout))
(let ((ctime (date->string (current-date))))
(if (equal? instr "time-to-die")
(begin
(debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
(let ((pid (current-process-id)))
(debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
(system (conc "kill " pid))))
(begin
(debug:print 0 *default-log-port* ctime " received " instr )
;(nn-send rep "ok")
(if (not (equal? instr "ping"))
(begin
(debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
;(system (conc script " '" instr "'"))
(process-run script (list instr ))
(debug:print 0 *default-log-port* ctime " done" ))
(begin
(if (not (equal? instr "load"))
(print "Checking load")
)
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((tlisten)
(if (null? remargs)
(print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
(let ((portnum (string->number (car remargs))))
(if (not portnum)
(print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
(begin
(if (not (is-port-in-use portnum))
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(contact (configf:lookup mtconf "listener" "owner"))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages.")
(set-signal-handler! signal/int (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
(set-signal-handler! signal/term (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
;(set-signal-handler! signal/term special-signal-handler)
(let loop ((instr (nn-recv rep)))
(nn-send rep "ok")
(let ((ctime (date->string (current-date))))
(if (equal? instr "time-to-die")
(begin
(debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
(let ((pid (current-process-id)))
(debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
(system (conc "kill " pid))))
(begin
(debug:print 0 *default-log-port* ctime " received " instr )
;(nn-send rep "ok")
(if (not (equal? instr "ping"))
(begin
(debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
(system (conc script " '" instr "' &"))
;(process-run script (list instr ))
(debug:print 0 *default-log-port* ctime " done" ))
(begin
(if (not (equal? instr "load"))
(print "Checking load")
)
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((gather) ;; gather all area db's into /tmp/$USER_megatest/alldbs
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(areas (get-area-names mtconf)))
(print "areas: " areas)))
(else
(let ((all-actions (sort (map conc (delete-duplicates (append *other-actions* (map car *action-keys*)))) string<=?)))
(print "unrecognised action: \"" *action* "\", try one of; \"" (string-intersperse all-actions "\", \"") "\"")))
)) ;; the end
;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;
(if (get-environment-variable "HTTP_HOST")
(begin
(stml:main #f)
(exit)))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtutil> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))))
#|
(define mtconf (car (simple-setup #f)))
(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#