Megatest

;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  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))
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))

     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(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)





			       '()))
		(lasttpath "/does/not/exist/I/hope"))

	   (if (not (null? tests))
	       (begin
		 (case action
		   ((remove-runs)
		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   (else
		    (print "INFO: action not recognised " action)))
		 (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)
		      (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)))
			       ;;   ))



			       )))

			((set-state-status)
			 (debug:print 4 "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 "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))