Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1217,21 +1217,27 @@ ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond - ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig + ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf - (runconfigs-get rconf testpatt-key) - #f)) ;; We do NOT fall back to "%" + (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key))) + (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) + patts-from-mode-patt) + (begin + (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) + #f))) ;; We do NOT fall back to "%" ;; (tags-testpatt ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) ;; tags-testpatt) ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) - (else args-testpatt)))) + (else + (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) + args-testpatt)))) (define (common:false-on-exception thunk #!key (message #f)) (handle-exceptions exn Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -1336,28 +1336,93 @@ (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) + 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")))) + "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)) @@ -1373,39 +1438,65 @@ (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 - (print "WARNING: cpuload too high, skipping processing of " uuid " due to " cpuload " > " maxload) + (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 - (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 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)))))) + (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