diff options
| -rw-r--r-- | src/cuirass/base.scm | 25 | ||||
| -rw-r--r-- | src/cuirass/database.scm | 33 | ||||
| -rw-r--r-- | src/schema.sql | 4 | ||||
| -rw-r--r-- | src/sql/upgrade-9.sql | 9 | ||||
| -rw-r--r-- | tests/database.scm | 9 |
5 files changed, 65 insertions, 15 deletions
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 7a566d3..9b81b3c 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -198,6 +198,10 @@ read-only directory." branch (string-append "origin/" branch))) + (define (commit-timestamp directory commit) + (with-repository directory repository + (commit-time (commit-lookup repository (string->oid commit))))) + (let ((name (assq-ref input #:name)) (url (assq-ref input #:url)) (branch (and=> (assq-ref input #:branch) @@ -209,10 +213,15 @@ read-only directory." (tag (and=> (assq-ref input #:tag) (lambda (t) `(tag . ,t))))) - (let-values (((directory commit) - (latest-repository-commit store url - #:cache-directory (%package-cachedir) - #:ref (or branch commit tag)))) + (let*-values (((directory commit) + (latest-repository-commit store url + #:cache-directory + (%package-cachedir) + #:ref (or branch commit tag))) + ((timestamp) + (commit-timestamp + (url-cache-directory url (%package-cachedir)) + commit))) ;; TODO: When WRITABLE-COPY? is true, we could directly copy the ;; checkout directly in a writable location instead of copying it to the ;; store first. @@ -224,6 +233,7 @@ read-only directory." `((#:input . ,name) (#:directory . ,directory) (#:commit . ,commit) + (#:timestamp . ,timestamp) (#:load-path . ,(assq-ref input #:load-path)) (#:no-compile? . ,(assq-ref input #:no-compile?))))))) @@ -809,8 +819,12 @@ by PRODUCT-SPECS." (define (process spec) (with-store store (let* ((name (assoc-ref spec #:name)) + (timestamp (time-second (current-time time-utc))) (checkouts (fetch-inputs spec)) - (eval-id (db-add-evaluation name checkouts))) + (checkouttime (time-second (current-time time-utc))) + (eval-id (db-add-evaluation name checkouts + #:timestamp timestamp + #:checkouttime checkouttime))) (when eval-id (compile-checkouts spec (filter compile? checkouts)) (spawn-fiber @@ -824,6 +838,7 @@ by PRODUCT-SPECS." (log-message "evaluating spec '~a'" name) (with-store store (let ((jobs (evaluate store spec eval-id checkouts))) + (db-set-evaluation-time eval-id) (log-message "building ~a jobs for '~a'" (length jobs) name) (build-packages store jobs eval-id)))))) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 7bb5bd2..fb22bcd 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -47,6 +47,7 @@ db-add-evaluation db-set-evaluations-done db-set-evaluation-done + db-set-evaluation-time db-get-pending-derivations build-status db-add-build @@ -336,12 +337,13 @@ the same revision already exists for SPEC-NAME, return #f." (catch-sqlite-error (sqlite-exec db "\ INSERT INTO Checkouts (specification, revision, evaluation, input, -directory) VALUES (" +directory, timestamp) VALUES (" spec-name ", " (assq-ref checkout #:commit) ", " eval-id ", " (assq-ref checkout #:input) ", " - (assq-ref checkout #:directory) ");") + (assq-ref checkout #:directory) ", " + (or (assq-ref checkout #:timestamp) 0) ");") (last-insert-rowid db) ;; If we get a unique-constraint-failed error, that means we have @@ -436,13 +438,21 @@ SELECT * FROM Specifications ORDER BY name DESC;"))) ,(with-input-from-string build-outputs read))) specs))))))) -(define (db-add-evaluation spec-name checkouts) +(define* (db-add-evaluation spec-name checkouts + #:key + (checkouttime 0) + (evaltime 0) + timestamp) "Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new. Otherwise, return #f." + (define now + (or timestamp (time-second (current-time time-utc)))) + (with-db-worker-thread db (sqlite-exec db "BEGIN TRANSACTION;") - (sqlite-exec db "INSERT INTO Evaluations (specification, in_progress) -VALUES (" spec-name ", true);") + (sqlite-exec db "INSERT INTO Evaluations (specification, in_progress, +timestamp, checkouttime, evaltime) +VALUES (" spec-name ", true, " now "," checkouttime "," evaltime ");") (let* ((eval-id (last-insert-rowid db)) (new-checkouts (filter-map (cut db-add-checkout spec-name eval-id <>) @@ -471,6 +481,15 @@ WHERE id = " eval-id ";") `((#:evaluation . ,eval-id) (#:in_progress . #f))))) +(define (db-set-evaluation-time eval-id) + (define now + (time-second (current-time time-utc))) + + (with-db-worker-thread + db + (sqlite-exec db "UPDATE Evaluations SET evaltime = " now + "WHERE id = " eval-id ";"))) + (define-syntax-rule (with-database body ...) "Run BODY with %DB-CHANNEL being dynamically bound to a channel providing a worker thread that allows database operations to run without intefering with @@ -772,11 +791,11 @@ FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset | (('order . 'finish-time) "stoptime DESC") (('order . 'finish-time+build-id) "stoptime DESC, Builds.id DESC") (('order . 'start-time) "starttime DESC") - (('order . 'submission-time) "timestamp DESC") + (('order . 'submission-time) "Builds.timestamp DESC") ;; With this order, builds in 'running' state (-1) appear ;; before those in 'scheduled' state (-2). (('order . 'status+submission-time) - "status DESC, timestamp DESC, Builds.id ASC") + "status DESC, Builds.timestamp DESC, Builds.id ASC") (_ "Builds.id DESC"))) (define (where-conditions filters) diff --git a/src/schema.sql b/src/schema.sql index 5ea1ff7..d1b38ae 100644 --- a/src/schema.sql +++ b/src/schema.sql @@ -31,6 +31,7 @@ CREATE TABLE Checkouts ( evaluation INTEGER NOT NULL, input TEXT NOT NULL, directory TEXT NOT NULL, + timestamp INTEGER NOT NULL, PRIMARY KEY (specification, revision), FOREIGN KEY (evaluation) REFERENCES Evaluations (id), FOREIGN KEY (specification) REFERENCES Specifications (name), @@ -41,6 +42,9 @@ CREATE TABLE Evaluations ( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, specification TEXT NOT NULL, in_progress INTEGER NOT NULL, + timestamp INTEGER NOT NULL, + checkouttime INTEGER NOT NULL, + evaltime INTEGER NOT NULL, FOREIGN KEY (specification) REFERENCES Specifications (name) ); diff --git a/src/sql/upgrade-9.sql b/src/sql/upgrade-9.sql new file mode 100644 index 0000000..4de411a --- /dev/null +++ b/src/sql/upgrade-9.sql @@ -0,0 +1,9 @@ +BEGIN TRANSACTION; + +ALTER TABLE Evaluations ADD timestamp INTEGER NOT NULL DEFAULT 0; +ALTER TABLE Evaluations ADD checkouttime INTEGER NOT NULL DEFAULT 0; +ALTER TABLE Evaluations ADD evaltime INTEGER NOT NULL DEFAULT 0; + +ALTER TABLE Checkouts ADD timestamp INTEGER NOT NULL DEFAULT 0; + +COMMIT; diff --git a/tests/database.scm b/tests/database.scm index 944e4bf..8fd663d 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -97,11 +97,14 @@ (test-assert "sqlite-exec" (begin (sqlite-exec (%db) "\ -INSERT INTO Evaluations (specification, in_progress) VALUES (1, false);") +INSERT INTO Evaluations (specification, in_progress, +timestamp, checkouttime, evaltime) VALUES (1, false, 0, 0, 0);") (sqlite-exec (%db) "\ -INSERT INTO Evaluations (specification, in_progress) VALUES (2, false);") +INSERT INTO Evaluations (specification, in_progress, +timestamp, checkouttime, evaltime) VALUES (2, false, 0, 0, 0);") (sqlite-exec (%db) "\ -INSERT INTO Evaluations (specification, in_progress) VALUES (3, false);") +INSERT INTO Evaluations (specification, in_progress, +timestamp, checkouttime, evaltime) VALUES (3, false, 0, 0, 0);") (sqlite-exec (%db) "SELECT * FROM Evaluations;"))) (test-equal "db-add-specification" |