@@ -19,10 +19,11 @@ ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) +(define *default-log-port* (current-error-port)) (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-18 extras format pkts regex regex-case (prefix dbi dbi:) nanomsg) @@ -459,11 +460,11 @@ (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)) " "))) + (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) @@ -580,11 +581,11 @@ (list 'S area-path) ;; the area-path is mapped to the start-dir '()) (if (list? extra-dat) extra-dat (begin - (debug-print 0 log-port "ERROR: command-line->pkt received bad extra-dat " extra-dat) + (common:debug-print 0 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 @@ -741,15 +742,16 @@ ;; 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"))) - (pktsdir-str (configf:lookup mtconf "scratchdat" "toppath")) + (pktsdir (get-pkts-dir mtconf toppath)) (setup-pdbpath (configf:lookup mtconf "setup" "pdbpath"))) (common:with-queue-db - pktsdir-str + pktsdir setup-pdbpath + toppath (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (configf: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")) @@ -1102,10 +1104,16 @@ (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt))) (print "ERROR: cannot process commands without a pkts directory"))) +(define (get-pkts-dir mtconf toppath-in) + (let* ((toppath (or toppath-in (configf:lookup mtconf "scratchdat" "toppath"))) + (pktsdirs (or (configf:lookup mtconf "setup" "pktsdirs") + toppath))) + (common:get-pkts-dirs #t toppath: toppath pktsdirs: pktsdirs))) + ;; 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 @@ -1120,15 +1128,16 @@ "/tmp")) (cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load logdir #f))) (maxload (string->number (or (configf:lookup mtconf "setup" "maxload") (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls "1.1"))) - (pktsdir-str (configf:lookup mtconf "scratchdat" "toppath")) + (pktsdir (get-pkts-dir mtconf toppath)) ;; (configf:lookup mtconf "scratchdat" "toppath")) (setup-pdbpath (configf:lookup mtconf "setup" "pdbpath"))) (common:with-queue-db - pktsdir-str + pktsdir setup-pdbpath + toppath (lambda (pktsdirs pktsdir pdb) (let* ((rgconfdat (configf:find-and-read-config (conc toppath "/runconfigs.config"))) (rgconf (car rgconfdat)) (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) @@ -1183,34 +1192,29 @@ (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) + (common: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) + (common: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 (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 (file-exists? debugcontrolf) (load debugcontrolf))) (if *action* @@ -1220,12 +1224,11 @@ (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 (configf: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)) + (pktsdir (get-pkts-dir mtconf #f)) (adjargs (hash-table-copy args:arg-hash)) (new-ss (args:get-arg "-new"))) ;; check a few things (cond ((and area (not area-path)) @@ -1237,17 +1240,17 @@ (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 "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)))))) @@ -1261,19 +1264,19 @@ (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")) - (pktsdir-str (or (configf:lookup mtconf "scratchdat" "toppath")(configf:lookup mtconf "setup" "pktsdir"))) + (pktsdir (get-pkts-dir mtconf #f)) (setup-pdbpath (configf:lookup mtconf "setup" "pdbpath"))) (case (string->symbol *action*) ((process) (begin - (common:load-pkts-to-db pktsdir-str setup-pdbpath) + (common:load-pkts-to-db pktsdir setup-pdbpath toppath) (generate-run-pkts mtconf toppath) - (common:load-pkts-to-db pktsdir-str setup-pdbpath) + (common:load-pkts-to-db pktsdir setup-pdbpath toppath) (dispatch-commands mtconf toppath))) - ((import) (common:load-pkts-to-db pktsdir-str setup-pdbpath)) ;; import pkts + ((import) (common:load-pkts-to-db pktsdir setup-pdbpath toppath)) ;; import pkts ((rungen) (generate-run-pkts mtconf toppath)) ((dispatch) (dispatch-commands mtconf toppath))))) ;; misc ((show) (if (> (length remargs) 0) @@ -1290,16 +1293,18 @@ (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)) - (pktsdir-str (configf:lookup mtconf "scratchdat" "toppath")) - (setup-pdbpath (configf:lookup mtconf "setup" "pdbpath"))) - (common:load-pkts-to-db pktsdir-str setup-pdbpath use-lt: #t) ;; need to NOT do this by default ... + (pktsdir (get-pkts-dir mtconf #f)) + (setup-pdbpath (configf:lookup mtconf "setup" "pdbpath")) + (toppath (configf:lookup mtconfig "scratchdat" "toppath"))) + (common:load-pkts-to-db pktsdir setup-pdbpath toppath use-lt: #t) ;; need to NOT do this by default ... (common:with-queue-db - pktsdir-str + pktsdir setup-pdbpath + toppath (lambda (pktsdirs pktsdir conn) ;; pktspec display-fields (make-report "out.dot" conn '((cmd . ((parent . P) (user . M)