Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -431,11 +431,14 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run db run-id testpatt itempatt states statuses #!key (not-in #t)) +(define (db:get-tests-for-run db run-id testpatt itempatt states statuses + #!key (not-in #t) + (sort-by #f) ;; 'rundir 'event_time + ) (let* ((res '()) ;; if states or statuses are null then assume match all when not-in is false (states-str (conc " state in ('" (string-intersperse states "','") "')")) (statuses-str (conc " status in ('" (string-intersperse statuses "','") "')")) (state-status-qry (if (or (not (null? states)) @@ -443,12 +446,14 @@ (conc " AND " (if not-in "NOT" "") " (" states-str " AND " statuses-str ") ") "")) (qry (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " state-status-qry - ;; " ORDER BY id DESC;" - " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id? + (case sort-by + ((rundir) " ORDER BY length(rundir) DESC;") + ((event_time) " ORDER BY event_time ASC;") + (else ";")) ))) (debug:print 8 "INFO: db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -516,11 +516,16 @@ (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) (dirs-to-remove (make-hash-table))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (tests (if (not (equal? run-state "locked")) - (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt states statuses not-in: #f) + (rdb:get-tests-for-run db (db:get-value-by-header run header "id") + testpatt itempatt states statuses + not-in: #f + sort-by: (case action + ((remove-runs) 'rundir) + (else 'event_time))) '())) (lasttpath "/does/not/exist/I/hope")) (if (not (null? tests)) (begin @@ -534,55 +539,38 @@ (for-each (lambda (test) (let* ((item-path (db:test-get-item-path test)) (test-name (db:test-get-testname test)) (run-dir (db:test-get-rundir test))) - (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path) + (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) (case action ((remove-runs) (rdb:delete-test-records db (db:test-get-id test)) - (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc. - (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test)))) - (set! lasttpath fullpath) - (hash-table-set! dirs-to-remove fullpath #t) - ;; The following was the safe delete code but it was not being exectuted. - ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/")))) - ;; (dir-to-rem (get-dir-up-n fullpath dirs-count)) - ;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath)) - ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd ))) - ;; (if (file-exists? fullpath) - ;; (begin - ;; (debug:print 1 cmd) - ;; (system cmd))) - ;; )) - ))) + (debug:print 1 "INFO: Attempting to remove dir " run-dir) + (if (and (> (string-length run-dir) 5) + (file-exists? run-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (let* ((realpath (resolve-pathname run-dir))) + (debug:print 1 "INFO: Real path of is " realpath) + (if (file-exists? realpath) + (if (> (system (conc "rm -rf " realpath)) 0) + (debug:print 0 "ERROR: There was a problem removing " realpath " with rm -f")) + (debug:print 0 "WARNING: test run dir " realpath " appears to not exist")) + (if (file-exists? run-dir) ;; the link + (if (symbolic-link? run-dir) + (delete-file run-dir) + (if (directory? run-dir) + (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) + (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (delete-directory run-dir)) ;; it should be empty by here BUG BUG, add error catch + (debug:print 0 "ERROR: refusing to remove " run-dir " as it is neither a symlink nor a directory") + )))) + (debug:print 0 "WARNING: directory already removed " run-dir))) ((set-state-status) - (debug:print 4 "INFO: new state " (car state-status) ", new status " (cadr state-status)) + (debug:print 2 "INFO: new state " (car state-status) ", new status " (cadr state-status)) (db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) tests))) - - ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records - ;; for each test in case we get killed. That should minimize the detritus left on disk - ;; process the dirs from longest string length to shortest - (if (eq? action 'remove-runs) - (for-each - (lambda (dir-to-remove) - (if (file-exists? dir-to-remove) - (let ((dir-in-db '())) - (sqlite3:for-each-row - (lambda (dir) - (set! dir-in-db (cons dir dir-in-db))) - db "SELECT rundir FROM tests WHERE rundir LIKE ?;" - (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db - (if (null? dir-in-db) - (begin - (debug:print 2 "Removing directory with zero db references: " dir-to-remove) - (system (conc "rm -rf " dir-to-remove)) - (hash-table-delete! dirs-to-remove dir-to-remove)) - (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database"))))) - (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))) - + ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '()))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -64,11 +64,11 @@ make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi -for f in readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking; do +for f in readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils directory-utils; do chicken-install $PROX $f done cd $BUILDHOME