Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -224,11 +224,11 @@
" 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 0 *default-log-port*
+ (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"
@@ -275,20 +275,32 @@
)
test-paths)))
(if (not (common:file-exists? (conc archive-dir "/HEAD")))
(begin
;; replace this with jobrunner stuff enventually
- (debug:print-info 0 *default-log-port* "Init bup in " archive-dir)
+ (debug:print-info 2 *default-log-port* "Init bup in " archive-dir)
;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)
+ (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 0 *default-log-port* "Indexing data to be archived")
+ (debug:print-info 2 *default-log-port* "Indexing data to be archived")
;; (mutex-lock! bup-mutex)
- (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
- (debug:print-info 0 *default-log-port* "Archiving data with bup")
- (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (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))
@@ -354,16 +366,29 @@
(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 0 *default-log-port* "Init bup in " archive-dir)
- (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
- (debug:print-info 0 *default-log-port* "Indexing data to be archived")
- (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
- (debug:print-info 0 *default-log-port* "Archiving data with bup")
- (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (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 2 *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)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1973,11 +1973,13 @@
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicacte-db")
(begin
;; check if source
;; check if megatest.db exist
- (launch:setup)
+ (print "launch:setup")
+ (launch:setup)
+ (print "done 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"))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -2202,32 +2202,38 @@
;;
(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") "")))
- (print "Actions: " actions)
- (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"))
- (for-each
- (lambda (action)
+ (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" "")))
@@ -2237,17 +2243,14 @@
" -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 %"))))
- ))
- actions))))
- sorted)))
- ;; (print "Sorted: " (map simple-run-event_time sorted))
- ;; (print "Remove: " (map simple-run-event_time to-remove))))
- (hash-table-keys runs-ht))
+ (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)) "/")))
Index: sauth-common.scm
==================================================================
--- sauth-common.scm
+++ sauth-common.scm
@@ -240,11 +240,20 @@
(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 "/")))
@@ -279,11 +288,11 @@
(if (and (not (equal? restricted-areas "" ))
(string-match (regexp restrictions) target-path))
(begin
- (sauth:print-error "Access denied to " (string-join resolved-path "/"))
+ (sauth:print-error (conc "Access denied to " (string-join resolved-path "/")))
;(exit 1)
#f)
target-path)
))
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -391,10 +391,14 @@
((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
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -638,10 +638,11 @@
(pathname-file target-path)))
(curr-dir (current-directory))
(start-dir (conc (current-directory) "/" last-dir-name))
(execlude (make-exclude-pattern (string-split restrictions ",")))
(tmpfile (conc "/tmp/" (current-user-name) "/my-pipe-" (current-process-id))))
+ (sauth:print-error start-dir)
(if (file-exists? start-dir)
(begin
(sauth:print-error (conclast-dir-name " already exist in your work dir."))
(sauth:print-error "Nothing has been retrieved!! "))
(begin