Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -14,5 +14,74 @@ (declare (unit archive)) (declare (uses db)) (declare (uses common)) +;;====================================================================== +;; +;;====================================================================== + +(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 (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* "archivedisks"))) + (if section + (map cdr 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 testname itempath)))) + +;; allocate a new archive area +;; +(define (archvie:allocate-new-archive-block testname itempath dneeded) + (let* ((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)) + (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path))) + (archive-name (time->string (seconds->local-time (current-seconds)) "ww%W.%u")) + (archive-path (conc bdisk-path "/" archive-name)) + (block-id (rmt:archive-register-block-name bdisk-id archive-path)) + (allocation-id (rmt:archive-allocate-test-to-block block-id testname itempath))) + (if (and block-id allocation-id) + archive-path + #f))))) + + Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -443,24 +443,10 @@ (define (nice-path dir) (normalize-pathname (if (absolute-pathname? dir) dir (conc (current-directory) "/" dir)))) -(define (get-df path) - (let* ((df-results (cmd-run->list (conc "df " path))) - (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) - (freespc #f)) - ;; (write df-results) - (for-each (lambda (l) - (let ((match (string-search space-rx l))) - (if match - (let ((newval (string->number (cadr match)))) - (if (number? newval) - (set! freespc newval)))))) - (car df-results)) - freespc)) - (define (get-cpu-load) (car (common:get-cpu-load))) ;; (let* ((load-res (cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) ;; (cpu-load #f)) @@ -513,10 +499,67 @@ (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) + +;;====================================================================== +;; D I S K S P A C E +;;====================================================================== + +(define (common:get-disk-space-used fpath) + (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) + +(define (get-df path) + (let* ((df-results (cmd-run->list (conc "df " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freespc #f)) + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freespc newval)))))) + (car df-results)) + freespc)) + +;; paths is list of lists ((name path) ... ) +;; +(define (common:get-disk-with-most-free-space disks minspace) + (let ((best #f) + (bestsize 0)) + (for-each + (lambda (disk-num) + (let* ((dirpath (cadr (assoc disk-num disks))) + (freespc (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 50 "disks not a dir " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 50 "disks not writeable " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 50 "disks not a proper path " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) + -1) + (else + (get-df dirpath))))) + (if (> freespc bestsize) + (begin + (set! best (cons disk-num dirpath)) + (set! bestsize freespc))))) + (map car disks)) + (if (and best (> bestsize minsize)) + best + #f))) ;; #f means no disk candidate found + +;;====================================================================== +;; E N V I R O N M E N T V A R S +;;====================================================================== (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF"))) (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -810,12 +810,35 @@ target TEXT DEFAULT '', name TEXT DEFAULT '', testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, - creation_time TIMESTAMP, + creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") + ;; archive disk areas, cached info from [archivedisks] + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + id INTEGER PRIMARY KEY, + archive_area_name TEXT, + disk_path TEXT, + last_df INTEGER DEFAULT -1, + last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), + creation_time TIMESTAMP DEFAULT (strftime('%','now')));") + ;; individual bup (or tar) data chunks + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + id INTEGER PRIMARY KEY, + archive_disk_id INTEGER, + disk_path TEXT, + last_du INTEGER DEFAULT -1, + last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), + creation_time TIMESTAMP DEFAULT (strftime('%','now')));") + ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + id INTEGER PRIMARY KEY, + archive_block_id INTEGER, + testname TEXT, + item_path TEXT, + creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; move this clean up call somewhere else (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") @@ -897,12 +920,57 @@ test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);"))) + run_duration INTEGER DEFAULT 0);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + 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);"))) db) + +;;====================================================================== +;; A R C H I V E S +;;====================================================================== + +;; dneeded is minimum space needed, scan for existing archives that +;; are on disks with adequate space and already have this test/itempath +;; archived +;; +(define (db:archive-get-allocations dbstruct testname itempath dneeded) + (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db + (db (db:dbdat-get-db dbdat)) + (res '()) + (blocks '())) ;; a block is an archive chunck that can be added too if there is space + (sqlite3:for-each-row + (lambda (id archive-disk-id disk-path last-du last-du-time) + (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) + db + "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b + INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id + WHERE a.testname=? AND a.item_path=?;" + testname itempath) + ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space + (if (null? res) + '() + (sqlite3:for-each-row + (lambda (id archive-area-name disk-path last-df last-df-time) + (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks))) + db + (conc + "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d + INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id + WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND + last_df > ?;") + dneeded)) + blocks)) + ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -537,45 +537,22 @@ (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") (configf:write-alist *configdat* tmpfile) (system (conc "ln -sf " tmpfile " " targfile)) ))))))) - (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) - (best #f) - (bestsize 0)) + (minspace (let ((m (configf:lookup "setup" "minspace"))) + (string->number (or m "10000"))))) (if disks - (for-each - (lambda (disk-num) - (let* ((dirpath (cadr (assoc disk-num disks))) - (freespc (cond - ((not (directory? dirpath)) - (if (common:low-noise-print 50 "disks not a dir " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) - -1) - ((not (file-write-access? dirpath)) - (if (common:low-noise-print 50 "disks not writeable " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) - -1) - ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 50 "disks not a proper path " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) - -1) - (else - (get-df dirpath))))) - (if (> freespc bestsize) - (begin - (set! best dirpath) - (set! bestsize freespc))))) - (map car disks))) - (if (and best (> bestsize 0)) - best - (begin - (if (common:low-noise-print 20 "no valid disks") - (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!")) - (exit 1))))) + (let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb + (if res + (cdr res) + (begin + (if (common:low-noise-print 20 "no valid disks") + (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!")) + (exit 1))))))) ;; Desired directory structure: ;; ;; - - -. ;; | Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -626,5 +626,12 @@ (define (rmt:tasks-add action owner target runname testpatt params) (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) + +;;====================================================================== +;; A R C H I V E S +;;====================================================================== + +(define (rmt:archive-get-allocations testname itempath dneeded) + (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))