From: Danny Milosavljevic <dannym@scratchpost.org>
To: guix-devel@gnu.org
Subject: [PATCH] database: db-get-builds: Inline output selection.
Date: Mon, 19 Feb 2018 18:52:12 +0100 [thread overview]
Message-ID: <20180219175212.23677-1-dannym@scratchpost.org> (raw)
In-Reply-To: <20180219163506.2037e56e@scratchpost.org>
* 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."
next prev parent reply other threads:[~2018-02-19 17:52 UTC|newest]
Thread overview: 42+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-01-24 22:12 Cuirass news Ludovic Courtès
2018-01-25 10:55 ` Mathieu Othacehe
2018-01-25 10:59 ` Mathieu Othacehe
2018-01-25 13:09 ` Ludovic Courtès
2018-01-26 14:30 ` Danny Milosavljevic
2018-01-27 16:01 ` Ludovic Courtès
2018-01-27 17:18 ` Danny Milosavljevic
2018-01-27 19:12 ` Danny Milosavljevic
2018-01-28 21:47 ` Ludovic Courtès
2018-01-28 22:23 ` Danny Milosavljevic
2018-01-29 9:57 ` Andy Wingo
2018-02-08 13:37 ` Ludovic Courtès
2018-02-08 16:29 ` Danny Milosavljevic
2018-02-08 22:21 ` Ludovic Courtès
2018-02-08 23:05 ` Danny Milosavljevic
2018-02-09 6:17 ` Gábor Boskovits
2018-02-09 9:41 ` Ludovic Courtès
2018-02-09 11:29 ` Danny Milosavljevic
2018-02-09 16:53 ` Ludovic Courtès
2018-02-09 17:06 ` Danny Milosavljevic
2018-02-10 11:18 ` Ludovic Courtès
2018-02-13 9:12 ` Danny Milosavljevic
2018-02-14 13:43 ` Ludovic Courtès
2018-02-14 23:17 ` Ludovic Courtès
2018-02-19 15:35 ` Danny Milosavljevic
2018-02-19 15:35 ` [PATCH] database: Simplify 'db-get-builds' Danny Milosavljevic
2018-02-19 17:52 ` Danny Milosavljevic [this message]
2018-02-19 22:08 ` Cuirass news Danny Milosavljevic
2018-03-02 13:21 ` Ludovic Courtès
2018-03-02 22:06 ` Ludovic Courtès
2018-03-02 23:29 ` Danny Milosavljevic
2018-02-14 23:21 ` Ludovic Courtès
2018-01-25 21:06 ` Ricardo Wurmus
2018-01-26 11:12 ` Ludovic Courtès
2018-01-25 22:28 ` Danny Milosavljevic
2018-01-26 10:47 ` Ludovic Courtès
2018-01-28 12:33 ` Cuirass frontend Danny Milosavljevic
2018-01-29 17:42 ` Ludovic Courtès
2018-01-26 0:46 ` Cuirass news Danny Milosavljevic
2018-01-27 17:27 ` Danny Milosavljevic
2018-01-28 21:48 ` Ludovic Courtès
2018-01-26 17:55 ` Jan Nieuwenhuizen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180219175212.23677-1-dannym@scratchpost.org \
--to=dannym@scratchpost.org \
--cc=guix-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).