Megatest

		    (let ((res (cons block-id archive-path)))
		      (hash-table-set! blockid-cache key res)
		      res)
		    (begin
		      (debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name ",  archive-path=" archive-path)
		      #f)))
	      (begin
		(debug:print 0 *default-log-port* "WARNING: no disk found for " target ", " run-name ", " test-name )
		#f)))))) ;; no best disk found

;; archive - run bup
;;
;; 1. create the bup dir if not exists
;; 2. start the du of each directory
;; 3. gen index

	  (toplevel/children
	   (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id
			" as it is a toplevel test with children"))
	  ((not (common:file-exists? test-path))
	   (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path
			" as path " test-path " does not exist"))
	  (else
	   (debug:print 2 *default-log-port*
			"From test-dat=" test-dat " derived the following:\n"
			"test-partial-path  = " test-partial-path "\n"
			"test-path          = " test-path "\n"
			"test-physical-path = " test-physical-path "\n"
			"partial-path-index = " partial-path-index "\n"
			"test-base          = " test-base)
	   (hash-table-set! disk-groups test-base

	       (create-directory archive-dir #t))
	   (case archiver
	     ((bup) ;; Archive using bup
	      (let* ((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" ;; (conc "--strip-path=" linktree)
						     (conc "-" compress) ;; or (conc "--compress=" compress)
						     "-n" (conc (common:get-testsuite-name) "-"(string-substitute "/" "-" target " "))
						     (conc "--strip-path=" (conc test-base target "/" )) ;; if we push to the directory do we need this?
						     )
					       test-paths)))
		(if (not (common:file-exists? (conc archive-dir "/HEAD")))
		    (begin
		      ;; replace this with jobrunner stuff enventually
		      (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
		      ;; (mutex-lock! bup-mutex)
		      (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
                        (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
                              (exit 1))))
		      ;; (mutex-unlock! bup-mutex)
		      ))
		(debug:print-info 2 *default-log-port* "Indexing data to be archived")
		;; (mutex-lock! bup-mutex)
		(let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
                   (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
                              (exit 1))))
		(debug:print-info 2 *default-log-port* "Archiving data with bup")
		(let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
                     (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an archiving data with bup. Archive failed.")
                              (exit 1))))))
	     ((7z tar)
	      (for-each
	       (lambda (test-dat)
		 (let* ((test-id           (db:test-get-id        test-dat))
			(test-name         (db:test-get-testname  test-dat))
			(item-path         (db:test-get-item-path test-dat))
			(test-full-name    (db:test-make-full-name test-name item-path))

        (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))   
        (print-prefix      "Running: ") 
        (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
	(archive-dir  (if archive-info (cdr archive-info) #f))
	(archive-id   (if archive-info (car archive-info) -1))
        (home-host (common:get-homehost))
        (archive-time (seconds->std-time-str (current-seconds)))
        (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
        (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
        (dbfile             (conc  archive-staging-db "/megatest.db"))) 
        (create-directory archive-staging-db #t)
        (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
            (if (eq? exit-code 0)   
              (case archiver
	        ((bup) ;; Archive using bup
	          (let* ((bup-init-params  (list "-d" archive-dir "init"))
		         (bup-index-params (list "-d" archive-dir "index" archive-staging-db))
		         (bup-save-params  (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
						     (conc "-" compress) ;; or (conc "--compress=" compress)
						     "-n" (conc tsname "-megatest-db" )
						     (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this?
						     dbfile)))
                    (if (not (common:file-exists? (conc archive-dir "/HEAD")))
		      (begin
		        ;; replace this with jobrunner stuff enventually
		        (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
		         (let-values (((pid-val exit-status exit-code)(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
                          (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an error initializing bup. Archive failed.")
                              (exit 1))))))
		     (debug:print-info 2 *default-log-port* "Indexing data to be archived")
		     (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)))
                        (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an error Indexing bup. Archive failed.")
                              (exit 1))))
		     (debug:print-info 2 *default-log-port* "Archiving data with bup")
		     (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
                         (if (not (eq? exit-code 0))
                              (begin    
                              (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.")
                              (exit 1))
                             (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp <ts>. Current timestamp: " (seconds->std-time-str (current-seconds))))))) 
               (else
                   (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
               (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))

(define (archive:restore-db archive-path ts)
   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
      (sleep 2)
      (db:multi-db-sync 
       (db:setup #f)
       'killservers
       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)

    (let* ((linktree       (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
	  (src-archive-linktree (rmt:get-var "src-archive-linktree")))
        (if (not (equal? src-archive-linktree linktree))
           (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
              (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")   
       (rmt:create-all-triggers)
))  

(define (seconds->std-time-str sec)
  (time->string 
   (seconds->local-time sec)
   "%Y-%m-%d-%H%M%S"))
 

(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update)
    (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update)) 
    (let* ((internal-path (conc testsuite-name "-" target))
           (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" )))  
           (ts-list (archive:ls->list  bup-exe archive-dir internal-path))
           (ds-flag (vector-ref (seconds->local-time) 8)))
           (let loop ((hed (car ts-list))
                       (tail (cdr ts-list)))
                   (if (and (null? tail) (equal? hed "latest"))
                        #f

	      (test-id           (db:test-get-id        test-dat))
	      (run-id            (db:test-get-run_id    test-dat))
	      (keyvals           (rmt:get-key-val-pairs run-id))
	      (target            (string-intersperse (map cadr keyvals) "/"))
	      
	      (toplevel/children (and (db:test-get-is-toplevel test-dat)
				      (> (rmt:test-toplevel-num-items run-id test-name) 0)))
	      (test-partial-path (conc  run-name "/" (db:test-make-full-name test-name item-path)))
	      ;; note the trailing slash to get the dir inspite of it being a link
	      (test-path         (conc linktree "/" test-partial-path))
	      ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory
	      (mutex-lock! rp-mutex)
	      (prev-test-physical-path (if (common:file-exists? test-path)
					   ;; (read-symbolic-link test-path #t)
					   (common:real-path test-path)
					   #f))
	      (mutex-unlock! rp-mutex)
	      (new-test-physical-path  (conc best-disk "/" test-partial-path))
	      (archive-block-id        (db:test-get-archived test-dat))
              (test-last-update        (db:test-get-last_update test-dat))
	      (archive-block-info      (rmt:test-get-archive-block-info archive-block-id))
	      (archive-path            (if (vector? archive-block-info)
					   (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
					   #f)) ;; no archive found?
              (archive-timestamp-dir   (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) (string-substitute "/" "-" target " ") test-partial-path test-last-update) #f))  
	      (archive-internal-path   (conc (common:get-testsuite-name) "-" (string-substitute "/" "-" target " ") "/" archive-timestamp-dir "/" test-partial-path))
	      (include-paths           (args:get-arg "-include"))
	      (exclude-pattern         (args:get-arg "-exclude-rx"))
	      (exclude-file            (args:get-arg "-exclude-rx-from")))
	 (if (not archive-timestamp-dir)
               (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
         (begin    
	 ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children

                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,
                              state        TEXT DEFAULT 'new',
                              status       TEXT DEFAULT 'n/a',
                              archive_type TEXT DEFAULT 'bup',
                              du           INTEGER,
                              archive_path TEXT);")))
         (print "creating triggers from init") 
        (db:create-triggers db)    
     db)) ;; )

;;======================================================================
;; A R C H I V E S
;;======================================================================

         "-list-disks"
         "-list-targets"
         "-show-runconfig"
         ;;"-list-db-targets"
         "-show-runconfig"
         "-show-config"
         "-show-cmdinfo"
	 "-cleanup-db"
            ))
       (no-watchdog-argvals (list '("-archive" . "replicate-db")))
       (start-watchdog-specail-arg-val (let loop ((hed  (car no-watchdog-argvals))
                                                  (tail (cdr   no-watchdog-argvals)))
                                             (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed)  " eql" (equal? (args:get-arg (car hed)) (cdr hed)))  
                                             (if (equal? (args:get-arg (car hed)) (cdr hed))
                                               #f
                                               (if (null? tail)
                                                 #t
                                                 (loop (car tail) (cdr tail))))))      
       (no-watchdog-args-vals (filter (lambda (x) x)
                                      (map args:get-arg no-watchdog-args)))
       (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
       ;(print  "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) 
  (if start-watchdog
      (thread-start! *watchdog*)))


;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
  (condition-case

			 (print path))
		       paths))))))

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicate-db")
    (begin
          ;; check if source
          ;; check if megatest.db exist
         (launch:setup)
         (if (not (args:get-arg "-source"))
             (begin 
             (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
             (exit 1)))
         (if (common:file-exists? (conc  *toppath* "/megatest.db"))
             (begin  
               (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")

                  (begin 
                  (archive:restore-db src ts)
            (set! *didsomething* #t))
       (begin
         (debug:print-error 1 *default-log-port* "Path " source " not found")
         (exit 1))))))   
    ;; else do a general-run-call
   (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) 
    (begin
      ;; for the archive get we need to preserve the starting dir as part of the target path
      (if (and (args:get-arg "-dest")
	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
	    (hash-table-set! args:arg-hash "-dest" newpath)))

;; delete redundant runs within a target - N is the input
;; delete redundant runs within a target IFF older than given date/time AND keep at least N
;; 
(define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print)))
  (let* ((runs-ht  (runs:get-hash-by-target target-patts runpatt))
	 (age      (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f))
	 (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400)))
	 (precmd   (or (args:get-arg "-precmd") ""))
         (action-chk (member (string->symbol "remove-runs") actions)))
     ;; check the sequence of actions  archive must comme before remove-runs
     (if  (and action-chk (member (string->symbol "archive") action-chk))
          (begin
          (debug:print-error 0 *default-log-port* "action remove-runs must come after archive")
          (exit 1))) 
    (print "Actions: " actions " age: " age)
    (for-each
     (lambda (action)
        (for-each
         (lambda (target)
            (let* ((runs      (hash-table-ref runs-ht target))
	           (sorted    (sort runs (lambda (a b)(< (simple-run-event_time a)(simple-run-event_time b)))))
	           (to-remove (let* ((len      (length sorted))
                                     (trim-amt (- len num-to-keep)))
                                 (if (> trim-amt 0)
                                    (take sorted trim-amt)
                                    '()))))
	   (hash-table-set! runs-ht target to-remove)
           (print target ":")
           (for-each
            (lambda (run)
              (let ((remove (member run to-remove (lambda (a b)
                                                    (eq? (simple-run-id a)
                                                         (simple-run-id b))))))
  	        (if (and age (> (simple-run-event_time run) age-mark))
		     (print "Skipping handling of " target "/" (simple-run-runname run) " as it is younger than " (args:get-arg "-age"))


		     (case action
		       ((print)
			(print " " (simple-run-runname run)
			       " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S")
			       " " (if remove "REMOVE" "")))
		       ((remove-runs)
			(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"
						 (if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0
						     " -kill-wait 0"
						     "")))))
		       ((archive)
			(if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
		       ((kill-runs)
			(if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))))))


            sorted)))


         (hash-table-keys runs-ht)))
      actions)
    runs-ht))

(define (remove-last-path-directory path-in)
  (let* ((dparts  (string-split path-in "/"))
    (path-out (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))
    )
    path-out

    (sauthorize:db-do  (lambda (db)
        (let* ((data-row (query fetch (sql db (conc "SELECT  code, exe_name,  id, basepath  FROM  areas where areas.code = '" code "'")))))
         (set!  obj data-row))))
;(print obj)
obj))


(define (sauth-common:src-size path)
  (let ((output (with-input-from-pipe (conc "/usr/bin/du -s " path  "  | awk '{print $1}'")  
                 (lambda()
                  (read-line)))))
      (string->number output)))  

(define (sauth-common:space-left-at-dest path)
   (let* ((output  (run/string (pipe (df ,path ) (tail -1))))
         (size (caddr (cdr (string-split output " ")))))
  (string->number size)))

;; function to validate the users input for target path and resolve the path
;; TODO: Check for restriction in subpath 
(define (sauth-common:resolve-path  new current allowed-sheets)
   (let* ((target-path (append  current (string-split new "/")))
          (target-path-string (string-join target-path "/"))
          (normal-path (normalize-pathname target-path-string))

                                     base-path 
                                     (conc base-path "/" (string-join (cdr resolved-path) "/")))))
                    
	              
                           (if (and (not (equal? restricted-areas "" ))
                             (string-match (regexp  restrictions) target-path)) 
                           (begin
                              (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
                              ;(exit 1)   
                            #f)
                             target-path)
                            
))
             #f)))

(define (spublish:shell-cp src-path target-path)  
  (cond
   ((not (file-exists? target-path))
	(sauth:print-error (conc " target Directory " target-path " does not exist!!")))
   ((not (file-exists? src-path))
    (sauth:print-error (conc "Source path " src-path " does not exist!!" )))
   (else
     (if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
          (begin 
             (sauth:print-error "Destination does not have enough disk space.")
             (exit 1)))    
     (if (is_directory src-path) 
        (begin
            (let* ((parent-dir src-path)
                   (start-dir target-path))
                 (run (pipe
                   (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
                   (begin (change-directory start-dir)