Megatest

(define (common:args-get-testpatt rconf)
  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
         ;; (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
     ((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
				(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 
			   (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
                     (begin
                       (if message

  (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
	 (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)