Megatest

;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
;; 3. gen index
;; 4. save
;;
(define (archive:run-bup archive-dir run-id run-name tests)
  (let* ((bup-exe    (or (configf:lookup *configdat* "archive" "bup") "bup"))
	 (linktree   (configf:lookup *configdat* "setup" "linktree"))
	 (test-paths (filter
		      string?
		      (map (lambda (test-dat)
			     (let* ((item-path         (db:test-get-item-path test-dat))
				    (test-name         (db:test-get-testname  test-dat))
				    (run-id            (db:test-get-run_id    test-dat))
				    (target            (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
				    
				    (toplevel/children (and (db:test-get-is-toplevel test-dat)
							    (> (rmt:test-toplevel-num-items run-id test-name) 0)))
				    ;; note the trailing slash to get the dir inspite of it being a link
				    (test-path         (conc linktree "/" target "/" run-name "/" (runs:make-full-test-name test-name item-path) "/")))
			       (if (or toplevel/children
				       (not (file-exists? test-path)))
				   #f

				   test-path)))
			   tests)))
	 ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")
	 (bup-init-params  (list "-d" archive-dir "init"))
	 (bup-index-params (append (list "-d" archive-dir "index") test-paths))
	 (bup-save-params  (append (list "-d" archive-dir "save" "--strip-path" linktree "-n" 
					 (conc (common:get-testsuite-name) "-" run-id))
				   test-paths)))
    (if (not (file-exists? archive-dir))
	(create-directory archive-dir #t))
    (if (not (file-exists? (conc archive-dir "/HEAD")))
	(begin
	  ;; replace this with jobrunner stuff enventually
	  (debug:print-info 0 "Init bup in " archive-dir)
	  (run-n-wait bup-exe params: bup-init-params)))
    (debug:print-info 0 "Indexing data to be archived")
    (run-n-wait bup-exe params: bup-index-params)
    (debug:print-info 0 "Archiving data with bup")
    (run-n-wait bup-exe params: bup-save-params)
    #t))

;;  PURPOSE.

(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

;; (use nanomsg)

(declare (unit nmsg-transport))

(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

		    (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   ((archive)
		    (debug:print 1 "Archiving data for run: " runkey " " (db:get-value-by-header run header "runname"))
		    (set! worker-thread (make-thread (lambda ()
						       (archive:run-bup (args:get-arg "-archive") run-id run-name tests))
						     "archive-bup-thread"))
		    (thread-start! worker-thread))
		   (else
		    (debug:print-info 0 "action not recognised " action)))
		 
		 ;; actions that operate on one test at a time can be handled below
		 ;;

				      (loop (car new-tests)(cdr new-tests)))))
			       ((archive)
				(if (not toplevel-with-children)
				    (begin
				      (debug:print-info 0 "Estimating disk space usage for " test-fulln)
				      (debug:print-info 0 "   " (common:get-disk-space-used run-dir)))))
			       )))
		       )
		     (if worker-thread (thread-join! worker-thread))))))
	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t)))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))

# Server is required - slower but more resistant to Sqlite issues.
required yes

# Start server when average query takes longer than this
# server-query-threshold 55500
server-query-threshold 100
timeout 0.01

# daemonize yes
# hostname #{scheme (get-host-name)}

## disks are:
## name host:/path/to/area
## -or-