[no subject]

[Clément Lassieur]

branch: master
commit b4d058fc8d279a92208aa46b2f8a43e35feb5369
Author: Clément Lassieur <address@hidden>
Date:   Sat Aug 4 15:25:55 2018 +0200

    database: Fix the builds limit issue.
    
    Fixes <https://bugs.gnu.org/32300>.
    
    * src/cuirass/database.scm (filters->order): New procedure.
    (db-get-builds): Remove FORMAT-OUTPUT, CONS-OUTPUT, COLLECT-OUTPUTS,
    FINISH-GROUP, SAME-GROUP?, GROUP-OUTPUTS procedures.  Remove the 'LEFT JOIN
    Outputs' clause.  Use DB-GET-OUTPUTS for each build that was fetched.
---
 src/cuirass/database.scm | 126 ++++++++++++++---------------------------------
 1 file changed, 37 insertions(+), 89 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index e772f3d..e73b648 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -443,104 +443,33 @@ log file for DRV."
              (cons `(,name . ((#:path . ,path)))
                    outputs))))))
 
+(define (filters->order filters)
+  (match (assq 'order filters)
+    (('order . 'build-id) "id ASC")
+    (('order . 'decreasing-build-id) "id DESC")
+    (('order . 'finish-time) "stoptime DESC")
+    (('order . 'finish-time+build-id) "stoptime DESC, id DESC")
+    (('order . 'start-time) "starttime DESC")
+    (('order . 'submission-time) "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")
+    (_ "id DESC")))
+
 (define (db-get-builds db filters)
   "Retrieve all builds in database DB which are matched by given FILTERS.
 FILTERS is an assoc list whose possible keys are 'id | 'jobset | 'job |
 'system | 'nr | 'order | 'status | 'evaluation."
-
-  (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 if 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 specification)
-         `((#: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)
-           (#:specification . ,specification)
-           (#:outputs    . ,outputs)))))
-
-    (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 other-cells 
...) . 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 other-cells ...) . rest)
-       (cons (finish-group)                       ;finish current group
-
-             ;; Start new group.
-             (let* ((outputs (cons-output x-output-name x-output-path '()))
-                    (x-repeated-row (list->vector other-cells)))
-               (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 other-cells ...) . rest)
-       (let ((x-repeated-row (list->vector other-cells)))
-         (collect-outputs x-builds-id x-repeated-row '() rows)))))
-
-  (let* ((order (match (assq 'order filters)
-                  (('order . 'build-id) "id ASC")
-                  (('order . 'decreasing-build-id) "id DESC")
-                  (('order . 'finish-time) "stoptime DESC")
-                  (('order . 'finish-time+build-id) "stoptime DESC, id DESC")
-                  (('order . 'start-time) "starttime DESC")
-                  (('order . 'submission-time) "timestamp DESC")
-                  (('order . 'status+submission-time)
-                   ;; With this order, builds in 'running' state (-1) appear
-                   ;; before those in 'scheduled' state (-2).
-                   "status DESC, timestamp DESC")
-                  (_ "id DESC")))
+  (let* ((order (filters->order filters))
          (stmt-text (format #f "SELECT * FROM (
-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.name
+SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime,
+Builds.log, Builds.status, Builds.derivation, Derivations.job_name,
+Derivations.system, Derivations.nix_name, Specifications.name
 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.name
-LEFT JOIN Outputs ON Outputs.build = Builds.id
 WHERE (:id IS NULL OR (:id = Builds.id))
 AND (:jobset IS NULL OR (:jobset = Specifications.name))
 AND (:job IS NULL OR (:job = Derivations.job_name))
@@ -580,7 +509,26 @@ ORDER BY ~a, id ASC;" order))
             (#f -1)
             (x x)))
     (sqlite-reset stmt)
-    (group-outputs (sqlite-fold-right cons '() stmt))))
+    (let loop ((rows (sqlite-fold-right cons '() stmt))
+               (builds '()))
+      (match rows
+        (() (reverse builds))
+        ((#(id timestamp starttime stoptime log status derivation job-name
+               system nix-name specification) . rest)
+         (loop rest
+               (cons `((#:id . ,id)
+                       (#:timestamp . ,timestamp)
+                       (#:starttime . ,starttime)
+                       (#:stoptime . ,stoptime)
+                       (#:log . ,log)
+                       (#:status . ,status)
+                       (#:derivation . ,derivation)
+                       (#:job-name . ,job-name)
+                       (#:system . ,system)
+                       (#:nix-name . ,nix-name)
+                       (#:specification . ,specification)
+                       (#:outputs . ,(db-get-outputs db id)))
+                     builds)))))))
 
 (define (db-get-build db id)
   "Retrieve a build in database DB which corresponds to ID."