Megatest

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6404)

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;; args and pkt key specs
;;
(define *arg-keys*
  '(
    ("-area"            . G) ;; maps to group
    ("-contour"         . c)
    ("-append-config"   . d)
    ("-state"           . e)
    ("-item-patt"       . i)
    ("-sync-to"         . k)
    ("-run-name"        . n)
    ("-mode-patt"       . o)
    ("-test-patt"       . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-status"          . s)
    ("-target"          . t)
    ("-tag-expr"        . x)



    ;; misc



    ("-debug"           . #f)  ;; for *verbosity* > 2
    ("-load"            . #f)  ;; load and exectute a scheme file
    ("-log"             . #f)
    ("-msg"             . M)
    ("-start-dir"       . S)
    ("-set-vars"        . v)
    ))
(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)
    ))

;; alist to map actions to old megatest commands
(define *action-keys*
  '((run         . "-run")
    (sync        . "")
    (archive     . "-archive")

				       (print " message: " ((condition-property-accessor 'exn 'message) exn))
				       runkey)
				   ((hash-table-ref *target-mappers* xlatr-key)
				    runkey new-runname area area-path reason contour mode-patt)))
			       (begin
				 (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
				 runkey)))
			 runkey))
	 (actual-action  (if action
			     (if (equal? action "sync-prepend")
				 "sync"
				 action)
			     "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
    ;; some hacks to remove switches not needed in certain cases
    (case (string->symbol (or action "run"))
      ((sync sync-prepend)
       (set! new-target #f)
       (set! runame     #f)))
    (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
    (let-values (((uuid pkt)
		  (command-line->pkt
		   actual-action
		   (append 
		    `(("-start-dir"  . ,area-path)
		      ("-msg"        . ,reason)
		      ("-contour"    . ,contour))
		    (if (good-val new-runname) `(("-run-name"      . ,new-runname)) '())
		    (if (good-val new-target)  `(("-target"        . ,new-target))  '())
		    (if (good-val mode-patt)   `(("-mode-patt"     . ,mode-patt))   '())
		    (if (good-val tag-expr)    `(("-tag-expr"      . ,tag-expr))    '())
		    (if (good-val dbdest)      `(("-sync-to"       . ,dbdest))      '())
		    (if (good-val append-conf) `(("-append-config" . ,append-conf)) '())
		    (if (equal? action "sync-prepend") '(("-prepend-contour" . " "))   '())
		    (if (not (or mode-patt tag-expr))
			`(("-testpatt"  . "%"))
			'())
		    (if (or (not action)
			    (equal? action "run"))
			`(("-preclean"  . " ")
			  ("-rerun-all" . " "))      ;; if run we *always* want preclean set, use single space as placeholder

				 (crontab  (alist-ref 'cron     val-alist))
				 ;; (action   (alist-ref 'action   val-alist))
				 (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
				 (runname  std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
			    ;; (print "last-run: " last-run " need-run: " need-run)
			    ;; (if need-run
			    (case (string->symbol action)
			      ((sync sync-prepend)
			       (if (common:extended-cron crontab #f last-sync)
				   (push-run-spec torun contour runkey
						  `((message . ,(conc ruletype ":sync-" cron-safe-string))
						    (action  . ,action)
						    (dbdest  . ,(alist-ref 'dbdest val-alist))
						    (append  . ,(alist-ref 'appendconf val-alist))))))
			      ((run)

			       (dbdest  (alist-ref 'dbdest  runkeydat))
			       (append  (alist-ref 'append  runkeydat))
			       (target  (or (alist-ref 'target  runkeydat) runkey))) ;; override with target if forced
			   (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
			   (if (case (or (and action (string->symbol action)) 'noaction)  ;; ensure we have the needed data to run this action
				 ((noaction) #f)
				 ((run)      (and runname reason))
				 ((sync sync-prepend)     (and reason dbdest))
				 (else       #f))
			       ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
			       (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) 
			       (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area  " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
			       )))
		       all-areas))
		    runkeydats)))

# To get emacs font highlighing in the various megatest configs do this:
#
# Install emacs-goodies-el:
#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
all:scheduled:sync          cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
quick:scheduled:sync        cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config

[scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

# tip will be replaced with hashkey?

# [%/%/%] doesn't work

(use json fmt posix)

;; abstract out the alist-ref a bit and re-order the params
;;
(define-inline (aref dat key)
  (alist-ref key dat equal?))

;; convert silly vectors in json data to nice clean alist
;;
(define (to-alist inlst)
  (handle-exceptions
      exn
      (begin
	(print-call-chain)
	(print inlst))
    (cond
     ((proper-list? inlst) (map to-alist inlst))
     ((or (list? inlst) ;; it is a pair
	  (pair? inlst))   (cons (car inlst) (to-alist (cdr inlst))))
     ((vector? inlst)      (to-alist (vector->list inlst)))
     (else                 inlst))))

;; columnar line printer
;;
(define (print-rows inlist)
  (define (print-line x)
    (cat (car x)
	 (space-to 10)(pad/left 3 (cadr x))
	 (space-to 25)(pad/left 3 (caddr x))
	 ))
  (fmt #t (pad-char #\  (fmt-join/suffix print-line inlist nl))))

;; from the command line pull branch, start-tag, end-tag
;;
(define (extract-history branch start-tag end-tag)
  (let* ((data       (to-alist  ;; get all the data
		      (with-input-from-pipe
			  "fossil json timeline checkin -n 0"
			json-read)))
	 (timeline   (aref (aref data "payload") "timeline")) ;; extract the timeline alists
	 (start-flag #f)
	 (end-flag   #f))
    ;; now we have all needed data as a list of alists in time order, extract the
    ;; messages for given branch starting at start-tag and ending at end-tag
    (reverse ;; return results oldest to newest
     (filter
      (lambda (x) x)
      (map
       (lambda (entry)
	 (let ((tags (aref entry "tags")))
	   (if (or (not tags) ;; eh?
		   (not (list? tags)))
	       (begin
		 ;; (with-output-to-port (current-error-port)
		 ;;   (lambda ()
		 ;;     (print "ERROR: bad entry. tags: " tags)))
		 #f)
	       (let* ((btag (car tags))  ;; first tag is the primary branch
		      (tags (cdr tags))  ;; remainder are actual tags
		      (cmt  (aref entry "comment"))
		      (usr  (aref entry "user"))
		      (tms  (aref entry "timestamp")))
		 ;; (print "btag: " btag " tags: " tags " usr: " usr)
		 (if (equal? btag branch) ;; we are on the branch
		     (begin
		       (if (member start-tag tags)(set! start-flag #t))
		       (let ((res (if (and start-flag
					   (not end-flag))
				      `(,usr
					,(time->string (seconds->local-time tms) "WW%U.%w %H:%M")
					,cmt)
				      #f)))
			 (if (member end-tag tags)(set! end-flag #t))
			 res))
		     #f)))))
       (reverse timeline))))))

(define (process-fossil branch start-tag end-tag)
  (print-rows
   (extract-history branch start-tag end-tag)))

;; process command line args and dispatch the call to fossil processing
;;
(if (and (> (length (argv)) 3)
	 (< (length (argv)) 5))
    (apply process-fossil (cdr (argv)))
    (begin ;; no inputs, exit with message
      (print "Usage: fslrept branch start-tag end-tag")
      ))