Megatest

;; 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.

(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-18 extras format pkts regex regex-case
     (prefix dbi dbi:)
     nanomsg)

(declare (uses mtcommon))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses mtconfigf))
(declare (uses mtdb)) ;; WARNING: This is NOT the db from megatest/db.scm, is it src/db.scm

(include "megatest-fossil-hash.scm")

(require-library stml)

(import (prefix mtdb db:))
(import (prefix mtcommon common:))
(import (prefix mtconfigf configf:))

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

;; helpers for mappers/checkers

;;
;;   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 (file-exists? "megatest.config")
    (if (file-exists? ".mtutil.so")
	(load ".mtutil.so")
	(if (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

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

;; 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)(log-port (current-error-port)))
  (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 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)

    ;(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 (configf: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"

;;
;; 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   (configf: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

	  (print pkt))))))

;; (use trace)(trace create-run-pkt)

;; 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"))
	(setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
    (common:with-queue-db
     pktsdir-str
     setup-pdbpath
     (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"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering

	 (print "rgentargs: " rgentargs)

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

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

	  (print pkt)))
      (print "ERROR: cannot process commands without a pkts directory")))

;; 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 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"))
	(setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
    (common:with-queue-db
     pktsdir-str
     setup-pdbpath
     (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"))
	      (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

(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*
    (case (string->symbol *action*)
      ((run remove rerun rerun-clean rerun-all set-ss archive kill list)
       (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 (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))
	      (adjargs   (hash-table-copy args:arg-hash))
	      (new-ss    (args:get-arg "-new")))
	 ;; check a few things
	 (cond

	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
	   (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")))
	      (setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (common:load-pkts-to-db pktsdir-str setup-pdbpath)
			 (generate-run-pkts mtconf toppath)
			 (common:load-pkts-to-db pktsdir-str setup-pdbpath)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (common:load-pkts-to-db pktsdir-str setup-pdbpath)) ;; 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))
	      (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 ...
	 (common:with-queue-db
	  pktsdir-str
	  setup-pdbpath
	  (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 (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 (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))

                         
                         (let loop ((instr (nn-recv rep)))
                           (print "received " instr ", running \"" script " " instr "\"")
                           (system (conc script " '" instr "'"))
                           (nn-send rep "ok")
                           (loop (nn-recv rep))))
		       (print "ERROR: Port " portnum " already in use. Try another port")))))))
      ((gatherdb) ;; 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))
              (areas     (configf:section->val-alist mtconf "areas")))
         (for-each
          (lambda (area)
            (let* ((area-name (car area))
                   (area-info (cdr area))
                   (area-path (alist-ref 'path area-info)))
              (print "Area: " area)
              (print "   path: " area-path)))
          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