Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -48,10 +48,11 @@ get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs + simple-get-runs get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt @@ -264,10 +265,11 @@ ((set-run-status) (apply db:set-run-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) + ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2114,10 +2114,48 @@ qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) + +(define-record simple-run target id runname state status owner event_time) +(define-record-printer (simple-run x out) + (fprintf out "#,(simple-run ~S ~S ~S ~S)" + (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) + +;; simple get-runs +;; +(define (db:simple-get-runs dbstruct runpatt count offset target) + (let* ((res '()) + (keys (db:get-keys dbstruct)) + (runpattstr (db:patt->like "runname" runpatt)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (targstr (string-intersperse keys "||'/'||")) + (keystr (conc targstr " AS target," + (string-intersperse remfields ","))) + (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " + ;; Generate: " AND x LIKE 'keypatt' ..." + " AND target LIKE '" target "'" + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) + (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (target id runname state status owner event_time) + (set! res (cons (make-simple-run target id runname state status owner event_time) res))) + db + qrystr + ))) + (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + res)) + ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -147,10 +147,16 @@ (define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) (define-inline (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) (define-inline (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) (define-inline (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) (define-inline (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; S I M P L E R U N +;;====================================================================== + +;; (defstruct id "runname" "state" "status" "owner" "event_time" ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (make-db:test-data)(make-vector 10)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -708,10 +708,13 @@ (rmt:send-receive 'delete-old-deleted-test-records #f '())) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) +(define (rmt:simple-get-runs runpatt count offset target) + (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target))) + (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) (rmt:send-receive 'get-prev-run-ids #f (list run-id))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1754,10 +1754,46 @@ (runs:recursive-delete-with-error-msg fullname))) (+ 1 x)) 0 real-dir) ;; then the entire directory (runs:recursive-delete-with-error-msg real-dir)) + +;; cleanup often needs to remove all but the last N runs per target +;; +;; target-patts a1/b1/c1,a2/b2/c2 ... +;; +;; This will fail if called with empty target or a bad target (i.e. missing or extra fields) +;; +(define (runs:get-hash-by-target target-patts runpatt) + (let* ((targets (string-split target-patts ",")) + (keys (rmt:get-keys)) + (res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... ) + (for-each + (lambda (target-patt) + (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt))) + (for-each + (lambda (run) + (let ((target (simple-run-target run))) + (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '()))))) + runs))) + targets) + res-ht)) + +(define (runs:get-all-but-most-recent-n-per-target target-patts runpatt num-to-keep) + (let ((runs-ht (runs:get-hash-by-target target-patts runpatt))) + (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 (if (> (length sorted) num-to-keep) + (take sorted (- (length sorted) num-to-keep)) + '()))) + (hash-table-set! runs-ht target to-remove) + (print "Sorted: " (map simple-run-event_time sorted)) + (print "Remove: " (map simple-run-event_time to-remove)))) + (hash-table-keys runs-ht)) + runs-ht)) ;; Remove runs ;; fields are passing in through ;; action: ;; 'remove-runs