* src/cuirass/database.scm (db-get-builds): Inline output selection.
---
src/cuirass/database.scm | 87 +++++++++++++++++++++++++++++++++++++++++++++---
1 file changed, 83 insertions(+), 4 deletions(-)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 5a4631f..f19ee03 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -379,6 +379,85 @@ FILTERS is an assoc list which possible keys are 'project
| 'jobset | 'job |
((xkey xvalue) (if (eq? key xkey)
xvalue
(assqx-ref (cdr filters) key))))))
+
+ (define (format-output name path)
+ `(,name . ((#:path . ,path))))
+
+ (define (cons-output name path rest)
+ "If NAME and PATH are both not #f, cons them to REST.
+Otherwise return REST unchanged."
+ (if (and (not name) (not path))
+ rest
+ (cons (format-output name path) rest)))
+
+ (define (collect-outputs repeated-builds-id repeated-row outputs rows)
+ "Given rows somewhat like
+1 'a 'b 2 'x
+^ 'c 'd 2 'x
+| ^^^^^ ^^^^
+| group ++++- group headers
+| detail
++------------ group id
+
+return rows somewhat like
+
+1 2 'x '((a b) (c d))
+
+.
+
+As a special case, if the group detail is #f #f, ignore it.
+This is made specifically to support LEFT JOINs.
+
+Assumes that iff group id stays the same the group headers stay the same."
+ (define (finish-group)
+ (match repeated-row
+ (#(timestamp starttime stoptime log status derivation job-name system
+ nix-name repo-name branch)
+ `((#:id . ,repeated-builds-id)
+ (#:timestamp . ,timestamp)
+ (#:starttime . ,starttime)
+ (#:stoptime . ,stoptime)
+ (#:log . ,log)
+ (#:status . ,status)
+ (#:derivation . ,derivation)
+ (#:job-name . ,job-name)
+ (#:system . ,system)
+ (#:nix-name . ,nix-name)
+ (#:repo-name . ,repo-name)
+ (#:outputs . ,outputs)
+ (#:branch . ,branch)))))
+
+ (define (same-group? builds-id)
+ (= builds-id repeated-builds-id))
+
+ (match rows
+ (() (list (finish-group)))
+ ((#((? same-group? x-builds-id) x-output-name x-output-path ...) . rest)
+ ;; Accumulate group members of current group.
+ (let ((outputs (cons-output x-output-name x-output-path outputs)))
+ (collect-outputs repeated-builds-id repeated-row outputs rest)))
+ ((#(x-builds-id x-output-name x-output-path timestamp starttime stoptime
log
+ status derivation job-name system nix-name repo-name branch) . rest)
+ (cons ;; Finish current group.
+ (finish-group)
+ ;; Start new group.
+ (let ((outputs (cons-output x-output-name x-output-path '())))
+ (let ((x-repeated-row (vector timestamp starttime stoptime
+ log status derivation job-name
system
+ nix-name repo-name branch)))
+ (collect-outputs x-builds-id x-repeated-row outputs rest)))))))
+
+ (define (group-outputs rows)
+ (match rows
+ (() '())
+ ((#(x-builds-id x-output-name x-output-path timestamp starttime stoptime
+ log status derivation job-name system
+ nix-name repo-name branch) . rest)
+ (let ((x-repeated-row (vector timestamp starttime stoptime
+ log status derivation job-name system
+ nix-name repo-name branch)))
+ (collect-outputs x-builds-id x-repeated-row '() rows)))))
+
(let* ((order (if (eq? (assqx-ref filters 'order) 'build-id)
"ASC"
"DESC"))
@@ -391,20 +470,21 @@ FILTERS is an assoc list which possible keys are 'project
| 'jobset | 'job |
(('order 'submission-time) "Builds.timestamp")
(_ "Builds.id")))
(stmt-text (format #f "\
-SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime,
Builds.log, Builds.status, Builds.derivation,\
+SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp,
Builds.starttime, Builds.stoptime, Builds.log, Builds.status,
Builds.derivation,\
Derivations.job_name, Derivations.system, Derivations.nix_name,\
Specifications.repo_name, Specifications.branch \
FROM Builds \
INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND
Builds.evaluation = Derivations.evaluation \
INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
INNER JOIN Specifications ON Evaluations.specification =
Specifications.repo_name \
+LEFT JOIN Outputs ON Outputs.build = Builds.id \
WHERE (:id IS NULL OR (:id = Builds.id)) \
OR (:project IS NULL OR (:project = Specifications.repo_name)) \
OR (:jobset IS NULL OR (:jobset = Specifications.branch)) \
OR (:job IS NULL OR (:job = Derivations.job_name)) \
OR (:system IS NULL OR (:system = Derivations.system)) \
OR (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status =
'pending' AND Builds.status < 0)) \
-ORDER BY ~a ~a LIMIT :nr;" order-column-name order))
+ORDER BY ~a ~a, Builds.id ASC LIMIT :nr;" order-column-name order))
(stmt (sqlite-prepare db stmt-text #:cache? #t)))
(sqlite-bind-arguments stmt #:id (assqx-ref filters 'id)
#:project (assqx-ref filters 'project)
@@ -416,8 +496,7 @@ ORDER BY ~a ~a LIMIT :nr;" order-column-name order))
#:nr (match (assqx-ref filters 'nr)
(#f -1)
(x x)))
- (map (cut db-format-build db <>)
- (sqlite-fold-right cons '() stmt))))
+ (group-outputs (sqlite-fold-right cons '() stmt))))
(define (db-get-build db id)
"Retrieve a build in database DB which corresponds to ID."
