Changes In Branch 1.65-archive Through [81893b52af] Excluding Merge-Ins
This is equivalent to a diff from 0d4dd9a19f to 81893b52af
|
2020-09-21
| ||
| 15:37 | updates to archive internal path ==6.1/1.6/WARN/1201/mars== check-in: 51b810393e user: pjhatwal tags: 1.65-archive | |
|
2020-09-18
| ||
| 12:27 | cherry picked 2 fixes, changed version to 1.6569 ==/7.2/2.0/PASS/1201/mars/== check-in: d145d0eb02 user: mmgraham tags: v1.65 | |
|
2020-09-17
| ||
| 14:42 | Merged from v1.65-experimental check-in: 31090be521 user: mrwellan tags: v1.65-aside | |
|
2020-09-16
| ||
| 12:44 | updates to remov-keep for archiving check-in: 81893b52af user: pjhatwal tags: 1.65-archive | |
|
2020-09-08
| ||
| 10:12 | Added testplan section to manual. NOTE: Passes ext-tests without any re-runs, seems like a sweet spot. ==24.9/2.2/1201/WARN/mars== check-in: 0d4dd9a19f user: mrwellan tags: v1.65 | |
|
2020-09-05
| ||
| 11:17 | Merged cleanup branch back to v1.65 ==9.4/2.2/1201/WARN/mars== check-in: 0cbf1a0b26 user: matt tags: v1.65 | |
Modified archive.scm from [f391351322] to [b4fac7cd8e].
| ︙ | ︙ | |||
222 223 224 225 226 227 228 | (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 | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | (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 |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | "-n" (conc (common:get-testsuite-name) "-" run-id) (conc "--strip-path=" test-base) ;; 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 | | | > > > > | | > > > > | | > > > > | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
"-n" (conc (common:get-testsuite-name) "-" run-id)
(conc "--strip-path=" test-base) ;; 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))
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
(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
| | | > > > > | | > > > > | | > > > > > | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
(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 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)
(let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
|
| ︙ | ︙ |
Modified megatest.scm from [0e58f17e0f] to [4d7c8579ec].
| ︙ | ︙ | |||
1971 1972 1973 1974 1975 1976 1977 |
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicacte-db")
(begin
;; check if source
;; check if megatest.db exist
| > | > | 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 |
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicacte-db")
(begin
;; check if source
;; check if megatest.db exist
(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"))
(begin
(debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
|
| ︙ | ︙ |
Modified runs.scm from [030b929939] to [ca48301598].
| ︙ | ︙ | |||
2200 2201 2202 2203 2204 2205 2206 | ;; 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))) | | > > > > > > | > > | | | | | | | | | | | | | | | | | < < | < < | < < | > | 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 |
;; 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
|
| ︙ | ︙ |
Modified sauth-common.scm from [28ffd8e69e] to [5771575e2e].
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
(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))
;; 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))
| > > > > > > > > > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
(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))
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
base-path
(conc base-path "/" (string-join (cdr resolved-path) "/")))))
(if (and (not (equal? restricted-areas "" ))
(string-match (regexp restrictions) target-path))
(begin
| | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
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)))
|
| ︙ | ︙ |
Modified spublish.scm from [0af43ce4a9] to [d0bcfc709c].
| ︙ | ︙ | |||
389 390 391 392 393 394 395 396 397 398 399 400 401 402 |
(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 (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)
| > > > > | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
(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)
|
| ︙ | ︙ |
Modified sretrieve.scm from [e7efdf8d00] to [15a6ca2860].
| ︙ | ︙ | |||
636 637 638 639 640 641 642 643 644 645 646 647 648 649 |
(last-dir-name (if (pathname-extension target-path)
(conc(pathname-file target-path) "." (pathname-extension target-path))
(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))))
(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
; (sretrieve:do-as-calling-user
; (lambda ()
| > | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
(last-dir-name (if (pathname-extension target-path)
(conc(pathname-file target-path) "." (pathname-extension target-path))
(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
; (sretrieve:do-as-calling-user
; (lambda ()
|
| ︙ | ︙ |