From mboxrd@z Thu Jan 1 00:00:00 1970 From: Danny Milosavljevic Subject: [PATCH] database: Simplify 'db-get-builds'. Date: Mon, 19 Feb 2018 16:35:46 +0100 Message-ID: <20180219153546.16173-1-dannym@scratchpost.org> References: <20180219163506.2037e56e@scratchpost.org> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:56027) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ennU1-0001vy-Th for guix-devel@gnu.org; Mon, 19 Feb 2018 10:36:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ennTy-0002bt-N2 for guix-devel@gnu.org; Mon, 19 Feb 2018 10:36:01 -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, ludo@gnu.org * src/cuirass/database.scm (db-get-builds): Modify. (db-get-build): Modify. --- src/cuirass/database.scm | 165 ++++++++++++++++------------------------------- 1 file changed, 55 insertions(+), 110 deletions(-) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index dd3e5a2..5a4631f 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -26,6 +26,7 @@ #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (sqlite3) #:export (;; Procedures. db-init @@ -347,15 +348,6 @@ log file for DRV." (cons `(,name . ((#:path . ,path))) outputs)))))) -(define db-build-request "\ -SELECT Builds.id, 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") - (define (db-format-build db build) (match build (#(id timestamp starttime stoptime log status derivation job-name system @@ -374,112 +366,65 @@ INNER JOIN Specifications ON Evaluations.specification = Specifications.repo_nam (#:outputs . ,(db-get-outputs db id)) (#:branch . ,branch))))) -(define (db-get-build db id) - "Retrieve a build in database DB which corresponds to ID." - (let ((res (sqlite-exec db (string-append db-build-request - " WHERE Builds.id=") - id ";"))) - (match res - ((build) - (db-format-build db build)) - (() #f)))) - (define (db-get-builds db filters) "Retrieve all builds in database DB which are matched by given FILTERS. FILTERS is an assoc list which possible keys are 'project | 'jobset | 'job | 'system | 'nr | 'order | 'status." - (define (clauses->query+arguments clauses) - ;; Given CLAUSES, return two values: a SQL query string, and a list of - ;; arguments to bind. Each element of CLAUSES must be either a string, or - ;; a (SQL ARGUMENT) tuple, where SQL is a query fragment and ARGUMENT is - ;; the argument to be bound for that fragment. - (let loop ((clauses clauses) - (query '()) - (arguments '())) - (match clauses - (() - (values (string-concatenate-reverse query) - (reverse arguments))) - (((? string? clause) . rest) - (loop rest - (cons clause query) - arguments)) - ((((? string? clause) argument) . rest) - (loop rest - (cons clause query) - (cons argument arguments)))))) - - (define (where-clauses filters) - (match (filter-map (match-lambda - (('project project) - (list "Specifications.repo_name=?" project)) - (('jobset jobset) - (list "Specifications.branch=?" jobset)) - (('job job) - (list "Derivations.job_name=?" job)) - (('system system) - (list "Derivations.system=?" system)) - (('status 'done) - "Builds.status >= 0") - (('status 'pending) - "Builds.status < 0") - (_ #f)) - filters) - (() - '("")) - ((clause) - (list "WHERE " clause)) - ((clause0 rest ...) - (cons* "WHERE " clause0 - (fold-right (lambda (clause result) - `(" AND " ,clause ,@result)) - '() - rest))))) - - (define (order-clause filters) - (or (any (match-lambda - (('order 'build-id) - "ORDER BY Builds.id ASC") - (('order 'decreasing-build-id) - "ORDER BY Builds.id DESC") - (('order 'finish-time) - "ORDER BY Builds.stoptime DESC") - (('order 'start-time) - "ORDER BY Builds.start DESC") - (('order 'submission-time) - "ORDER BY Builds.timestamp DESC") - (('order 'status+submission-time) - ;; With this order, builds in 'running' state (-1) appear - ;; before those in 'scheduled' state (-2). - "ORDER BY Builds.status DESC, Builds.timestamp DESC") - (_ #f)) - filters) - "ORDER BY Builds.id DESC")) ;default order - - (define (limit-clause filters) - (or (any (match-lambda - (('nr number) - (list "LIMIT ?" number)) - (_ #f)) - filters) - "")) - - (call-with-values - (lambda () - (clauses->query+arguments (append (list db-build-request " ") - (where-clauses filters) '(" ") - (list (order-clause filters) " ") - (list (limit-clause filters) " ")))) - (lambda (sql arguments) - (let loop ((rows (apply %sqlite-exec db sql arguments)) - (outputs '())) - (match rows - (() - (reverse outputs)) - ((row . rest) - (loop rest - (cons (db-format-build db row) outputs)))))))) + ;; XXX Change caller and remove + (define (assqx-ref filters key) + (if (null? filters) + #f + (match (car filters) + ((xkey xvalue) (if (eq? key xkey) + xvalue + (assqx-ref (cdr filters) key)))))) + (let* ((order (if (eq? (assqx-ref filters 'order) 'build-id) + "ASC" + "DESC")) + (order-column-name + (match (assqx-ref filters 'order) + (('order 'build-id) "Builds.id") + (('order 'decreasing-build-id) "Builds.id") + (('order 'finish-time) "Builds.stoptime") + (('order 'start-time) "Builds.starttime") + (('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,\ +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 \ +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)) + (stmt (sqlite-prepare db stmt-text #:cache? #t))) + (sqlite-bind-arguments stmt #:id (assqx-ref filters 'id) + #:project (assqx-ref filters 'project) + #:jobset (assqx-ref filters 'jobset) + #:job (assqx-ref filters 'job) + #:system (assqx-ref filters 'system) + #:status (and=> (assqx-ref filters 'status) + object->string) + #:nr (match (assqx-ref filters 'nr) + (#f -1) + (x x))) + (map (cut db-format-build db <>) + (sqlite-fold-right cons '() stmt)))) + +(define (db-get-build db id) + "Retrieve a build in database DB which corresponds to ID." + (match (db-get-builds db '(('id id))) + ((build) + build) + (() #f))) (define (db-get-stamp db spec) "Return a stamp corresponding to specification SPEC in database DB."