Megatest

; Copyright 2006-2017, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 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,
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;     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)

;;
(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 ")
			     
Actions:		     
   run                       : initiate runs
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
   remove                    : remove runs
   rerun                     : register action for processing
   set-ss                    : set state/status
   archive                   : compress and move test data to archive disk
   kill                      : stop tests or entire runs
   db                        : database utilities

Queries:
   areas, contours, setup    : show areas, contours or setup section from megatest.config
   gendot                    : generate a graphviz dot file from pkts.

Contour actions:
   process                   : runs import, rungen and dispatch 
			     
Trigger propagation actions:

  -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\"

Examples:

# Start a megatest run in the area \"mytests\"

    ("-status"          . s)
    ("-target"          . t)
    ("-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)
    ))
(define *switch-keys*
  '(
    ("-h"               . #f)
    ("-help"            . #f)
    ("--help"           . #f)
    ("-manual"          . #f)
    ("-version"         . #f)
    ;; misc	        
    ("-repl"            . #f)
    ("-immediate"       . I)
    ("-preclean"        . r)
    ("-rerun-all"       . u)
    ("-prepend-contour" . w)
    ("-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")
    (sync        . "")
    (archive     . "-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

	      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)

	(close-input-port timeline-port)
	(values  (common:date-time->seconds (conc date " " time)) node))))))

;;======================================================================
;; GLOBALS
;;======================================================================

;; process args
(define *action* (if (> (length (argv)) 1)
;; 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))

;;
;; 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
   (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 (current-user-name)
				 '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 (or pmeta smeta)                     ;; construct the switch/param pair.
           (if meta                     ;; construct the switch/param pair.
					(list meta value)
					'())))
          
				(filter cdr args-data)))))
    (print  "Alldat: " alldat
    (print  "Alldat: " alldat  ) ;;Do not removed. This is uesed by other applications to calculate z card 
	    " args-data: " args-data)
    ;(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

				  (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))))))
	  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 0 *default-log-port* "Checking access in " access-list " with access-ctrl " access-ctrl " for area " area)
    (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
	       (access-type     (cadr 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 ""))))
	  (print "Got " allowed-actions " for user " user " where access-types=" access-types " access-type=" access-type)
	  (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 (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill list)
      ((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 (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")
	   (let ((user (current-user-name)))
	     (if (check-access user mtconf *action* area);; check rights
									  (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)

														(set-signal-handler! signal/term special-signal-handler)

                            (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")))))))
		       (print "ERROR: Port " portnum " already in use. Try another port")))))))
      (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
;;