Megatest

[settings]
target-dir   #{scheme (create-directory "/tmp/#{getenv USER}/target" #t)}
allowed-users matt mrwellan

[database]
location /tmp/#{getenv USER}

     "-runall"
     "run all tests"
     (lambda (target runname keys keyvals)
       (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
	   (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
			       "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
		 (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
			       "FAIL,INCOMPLETE,ABORT,CHECK")))
	     (hash-table-set! args:arg-hash "-preclean" #t)
	     (runs:operate-on 'set-state-status
			      target
			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			      "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			      state:  states
			      ;; status: statuses

	       (writeable (file-write-access? dbpath))
	       (dbexists  (file-exists? dbpath)))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 2 "ERROR: problem accessing db " dbpath
			  ((condition-property-accessor 'exn 'message) exn))
	     (exit 1))
	   (call-with-database
            dbpath
	    (lambda (db)
	      ;; (print "calling proc " proc " on db " db)
	      (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
	      (if (not dbexists)(spublish:initialize-db db))
	      (proc db)))))
	(print "ERROR: invalid path for storing database: " path))))

;; copy in file to dest, validation is done BEFORE calling this
;;
(define (spublish:cp configdat submitter source-path target-dir targ-file comment)
  (let ((targ-path (conc target-dir "/" targ-file)))
    (if (file-exists? targ-path)
	(begin
	  (print "ERROR: target file already exists, remove it before re-publishing")
	  (exit 1)))
    (spublish:db-do
     configdat
     (lambda (db)
       (spublish:register-action db "cp" submitter source-path comment)))
    (let* (;; (target-path (configf:lookup "settings" "target-path"))
	   (th1         (make-thread
			 (lambda ()
			   (file-copy source-path targ-path #t))
			 ;; (let ((pid (process-run "cp" (list source-path target-dir))))
			 ;;   (process-wait pid)))
			 "copy thread"))
	   (th2         (make-thread
			 (lambda ()
			   (let loop ()
			     (thread-sleep! 15)
			     (display ".")
			     (flush-output)
			     (loop)))
			 "action is happening thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1))
    (cons #t "Successfully saved data")))

;; remove copy of file in dest
;;
(define (spublish:rm configdat submitter target-dir targ-file comment)
  (let ((targ-path (conc target-dir "/" targ-file)))
    (if (not (file-exists? targ-path))
	(begin
	  (print "ERROR: target file " targ-path " not found, nothing to remove.")
	  (exit 1)))
    (spublish:db-do
     configdat
     (lambda (db)
       (spublish:register-action db "rm" submitter "" comment)))
    (let* ((th1         (make-thread
			 (lambda ()
			   (delete-file targ-path)
			   (print " ... file " targ-path " removed"))
			 "rm thread"))
	   (th2         (make-thread
			 (lambda ()
			   (let loop ()
			     (thread-sleep! 15)
			     (display ".")
			     (flush-output)
			     (loop)))
			 "action is happening thread")))
      (thread-start! th1)
      (thread-start! th2)
      (thread-join! th1))
    (cons #t "Successfully saved data")))

(define (spublish:backup-move path)
  (let* ((trashdir  (conc (pathname-directory path) "/.trash"))
	 (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path))))
    (create-directory trashdir #t)
    (if (directory? path)
	(system (conc "mv " path " " trashfile))

	  (print "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
	  (exit)))
    (if (not (member user allowed-users))
	(begin
	  (print "User \"" (current-user-name) "\" does not have access. Exiting")
	  (exit 1)))
    (case (string->symbol action)
      ((cp publish)
       (if (< (length args) 1)
	   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
       (let* ((remargs     (args:get-args args '("-m") '() args:arg-hash 0))
	      (src-path-in (car args))
	      (src-path    (with-input-from-pipe
			    (conc "readlink -f " src-path-in)
			    (lambda ()
			      (read-line))))
	      (msg         (or (args:get-arg "-m") ""))
	      (targ-file   (pathname-strip-directory src-path)))
	 (if (not (file-read-access? src-path))
	     (begin
	       (print "ERROR: source file not readable: " src-path)
	       (exit 1)))
	 (if (directory? src-path)
	     (begin
	       (print "ERROR: source file is a directory, this is not supported yet.")
	       (exit 1)))
	 (print "publishing " src-path-in " to " target-dir)
	 (spublish:cp configdat user src-path target-dir targ-file msg)))
      ((rm)
       (if (< (length args) 1)
	   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1)))
       (let* (;; (remargs     (args:get-args args '("-m") '() args:arg-hash 0))
	      (targ-file (car args))
	      ;; (src-path    (with-input-from-pipe
	      ;;   	    (conc "readlink -f " src-path-in)
	      ;;   	    (lambda ()
	      ;;   	      (read-line))))
	      (msg         (or (args:get-arg "-m") "")))
;;	      (targ-file   (pathname-strip-directory src-path)))
	 (print "attempting to remove " targ-file " from " target-dir)
	 (spublish:rm configdat user target-dir targ-file msg)))
      ((publish)
       (if (< (length args) 3)
	   (begin 
	     (print "ERROR: Missing arguments; " (string-intersperse args ", "))
	     (exit 1))
	   (let* ((srcpath  (list-ref args 0))
		  (areaname (list-ref args 1))

			    "~10a~10a~4a~27a~30a\n"
			    (vector-ref x 0)
			    (vector-ref x 1) 
			    (vector-ref x 2) 
			    (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"")
			    (conc "\"" (vector-ref x 4) "\""))
		    (print (vector-ref x 0))))
	      versions)))

      (else (print "Unrecognised command " action)))))
  
;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.spublishrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)