;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;;======================================================================
;; Cpumod:
;;
;; Put things here don't fit anywhere else
;;======================================================================
(declare (unit archivemod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses fsmod))
(declare (uses processmod))
(declare (uses mtmod))
(declare (uses dbmod))
(declare (uses dbfile))
(use srfi-69)
(module archivemod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
data-structures
extras
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
debugprint
(prefix mtargs args:)
)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
system-information
debugprint
)))
(import debugprint
commonmod
configfmod
fsmod
rmtmod
processmod
mtmod
dbmod
dbfile
(prefix mtargs args:)
regex
regex-case
sparse-vectors
srfi-1
srfi-13
srfi-18
srfi-69
typed-records
z3
)
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
;;
;;======================================================================
;; ;; NOT CURRENTLY USED
;; ;;
;; (define (archive:main linktree target runname testname itempath options)
;; (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt))
;; (flavor 'plain) ;; type of machine to run jobs on
;; (maxload 1.5) ;; max allowed load for this work
;; (adisks (archive:get-archive-disks)))
;; ;; get testdir size
;; ;; - hand off du to job mgr
;; (if (and (common:file-exists? testdir)
;; (file-is-writable? testdir))
;; (let* ((dused (jobrunner:run-job
;; flavor ;; machine type
;; maxload ;; max allowed load
;; '() ;; prevars - environment vars to set for the job
;; common:get-disk-space-used ;; if a proc call it, if a string it is a unix command
;; (list testdir)))
;; (apath (archive:get-archive testname itempath dused)))
;; (jobrunner:run-job
;; flavor
;; maxload
;; '()
;; archive:run-bup
;; (list testdir apath))))))
;; Get archive disks from megatest.config
;;
(define (archive:get-archive-disks)
(let ((section (configf:get-section *configdat* "archive-disks")))
(if section
section
'())))
;; look for the best candidate archive area, else create new
;; area
;;
(define (archive:get-archive testname itempath dused)
;; look up in archive_allocations if there is a pre-used archive
;; with adequate diskspace
;;
(let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused))
(candidate-disks (map (lambda (block)
(list
(vector-ref block 1) ;; archive-area-name
(vector-ref block 2))) ;; disk-path
existing-blocks)))
(or (common:get-disk-with-most-free-space candidate-disks dused)
(archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
;; allocate a new archive area
;;
(define (archive:allocate-new-archive-block blockid-cache run-area-home testsuite-name dneeded target run-name test-name)
(let ((key (conc testsuite-name "/" target "/" run-name "/" test-name)))
(if (hash-table-exists? blockid-cache key)
(hash-table-ref blockid-cache key)
(let* ((pscript (configf:lookup *configdat* "archive" "pathscript"))
(pscript-cmd (conc pscript " " testsuite-name " " target " " run-name " " test-name))
(apath (if pscript
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "ERROR: script \"" pscript-cmd "\" failed to run properly. exn=" exn)
(exit 1))
(with-input-from-pipe
pscript-cmd
read-line))
#f)) ;; this is the user-calculated archive path
(adisks (archive:get-archive-disks))
(best-disk (common:get-disk-with-most-free-space adisks dneeded)))
(if best-disk
(let* ((bdisk-name (car best-disk))
(bdisk-path (cdr best-disk))
(area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5))
(bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path)))
(archive-name (if apath
apath
(let ((sec (current-seconds)))
(conc (time->string (seconds->local-time sec) "%Y")
"_q" (seconds->quarter sec) "/"
testsuite-name "_" area-key))))
(archive-path (conc bdisk-path "/" archive-name))
(block-id (rmt:archive-register-block-name bdisk-id archive-path)))
;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key)))
(if block-id ;; (and block-id allocation-id)
(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
(define (archive:megatest-db target-patt run-patt)
(let* ((blockid-cache (make-hash-table))
(tsname (common:get-testsuite-name))
(min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
(bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(compress (or (configf:lookup *configdat* "archive" "compress") "9"))
(archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
(if s (string->symbol s) 'bup)))
(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 #f) ;; FIXME! (server:choose-server *toppath* 'homehost))
(archive-time (seconds->std-time-str (current-seconds)))
(archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
(tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/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) ;; (db:setup-db *dbstruct-dbs* *toppath* #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 (archive:ls->list bup-exe archive-dir internal-path)
(let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort"))
(res '()))
(debug:print-info 0 *default-log-port* cmd)
(handle-exceptions
exn
#f ;; anything goes wrong - assume the process in NOT running.
(with-input-from-pipe
cmd
(lambda ()
(let* ((inl (read-lines)))
(reverse inl)))))))
(define (time-string->seconds tstr ds-flag)
(let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S")))
(vector-set! atime 8 ds-flag)
(local-time->seconds atime)))
(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
(if (and (not (null? tail)) (equal? hed "latest"))
(loop (car tail) (cdr tail))
(let* ((archive-seconds (time-string->seconds hed ds-flag)))
(if (< (abs (- archive-seconds test-last-update)) archive-update-delay)
(let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
(if (> (length test-list) 0)
hed
(if (not (null? tail))
(loop (car tail) (cdr tail))
#f)))
(if (null? tail)
#f
(loop (car tail) (cdr tail))))))))))
(define (common:get-youngest-test tests)
(if (null? tests)
#f
(let ((res #f))
(for-each
(lambda (test-dat)
(let ((event-time (db:test-get-event_time test-dat)))
(if (or (not res)
(> event-time (db:test-get-event_time res)))
(set! res test-dat))))
tests)
res)))
;; from an archive get a specific path - works ONLY with bup for now
;;
(define (archive:bup-get-data archive-command run-id-in run-name-in tests rp-mutex bup-mutex)
(if (null? tests)
(debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
(let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
;; (test-dat (common:get-youngest-test tests))
(destpath (args:get-arg "-dest")))
(cond
((null? tests)
(debug:print-error 0 *default-log-port*
"No test matching provided target, runname pattern and test pattern found."))
((file-exists? destpath)
(debug:print-error 0 *default-log-port*
"Destination path alread exists! Please remove it before running get."))
(else
(let loop ((rem-tests tests))
(let* ((test-dat (common:get-youngest-test rem-tests))
(item-path (db:test-get-item-path test-dat))
(test-name (db:test-get-testname test-dat))
(test-id (db:test-get-id test-dat))
(run-id (db:test-get-run_id test-dat))
(run-name (rmt:get-run-name-from-id run-id))
(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 target "/" 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))
(archive-block-id (db:test-get-archived 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)
#f))
(archive-internal-path (conc (common:get-testsuite-name) "-" run-id
"/latest/" 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 (and archive-path ;; no point in proceeding if there is no actual archive
(not toplevel/children))
(begin
(let* ((bup-restore-params (append (list "-d" archive-path "restore" "-C" (or destpath "data"))
;; " " ;; What is the empty string for?
(if include-paths
(map (lambda (p)
(conc archive-internal-path "/" p))
(string-split include-paths ","))
(list archive-internal-path)))))
(debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data")
" from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: #t)))
(let ((new-rem-tests (filter (lambda (tdat)
(or (not (eq? (db:test-get-id tdat) test-id))
(not (eq? (db:test-get-run_id tdat) run-id))))
rem-tests) ))
(debug:print-info 0 *default-log-port*
"No archive path in the record for run-id=" run-id
" test-id=" test-id ", skipping.")
(if (null? new-rem-tests)
(begin
(debug:print-info 0 *default-log-port* "No archives found for " target "/" run-name "...")
#f)
(loop new-rem-tests)))))))))))
)