From mboxrd@z Thu Jan 1 00:00:00 1970 From: Danny Milosavljevic Subject: [PATCH] database: db-get-builds: Inline output selection. Date: Mon, 19 Feb 2018 18:52:12 +0100 Message-ID: <20180219175212.23677-1-dannym@scratchpost.org> References: <20180219163506.2037e56e@scratchpost.org> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:36940) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1enpc6-0007mP-Tp for guix-devel@gnu.org; Mon, 19 Feb 2018 12:52:32 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1enpc3-0004KO-Ig for guix-devel@gnu.org; Mon, 19 Feb 2018 12:52:31 -0500 Received: from dd26836.kasserver.com ([85.13.145.193]:53620) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1enpc3-0004Jf-6l for guix-devel@gnu.org; Mon, 19 Feb 2018 12:52:27 -0500 In-Reply-To: <20180219163506.2037e56e@scratchpost.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.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."