cuirass: Store new information in database to prepare new HTTP API

integration.

* bin/evaluate.in (fill-job): New procedure.
(main): Use it to fill informations (nix-name, system) that will later be
added to database.
* doc/cuirass.texi (Database)[Derivation]: Add system and nix_name fields.
(Database)[Builds]: Add id, status, timestamp, starttime and stoptime
fields. Remove output field.
(Database)[Outputs]: New table describing the build outputs.
* src/cuirass/base.scm (build-packages): Add new fields to build object before
adding it to database.
* src/cuirass/database.scm (db-get-build, db-get-builds): New procedures to get
a build by id from database and a list of builds using filter parameters
respectively.
* src/schema.sql (Outputs) : New table.
(Derivations): Add system and nix_name columns.
(Builds): Remove output column and add id, status, timestamp, starttime and
stoptime columns.

5 files changed, 235 insertions, 45 deletions

diff --git a/bin/evaluate.in b/bin/evaluate.in
index d1d0767..37ba493 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -28,9 +28,21 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 (use-modules (cuirass)
              (ice-9 match)
              (ice-9 pretty-print)
+             (srfi srfi-26)
              (guix build utils)
+             (guix derivations)
              (guix store))
 
+(define (fill-job job eval-id)
+  "Augment the JOB alist with EVAL-ID and additional information
+  gathered from JOB’s #:derivation."
+  (let ((drv (read-derivation-from-file
+              (assq-ref job #:derivation))))
+    `((#:eval-id . ,eval-id)
+      (#:nix-name . ,(derivation-name drv))
+      (#:system . ,(derivation-system drv))
+      ,@job)))
+
 (define* (main #:optional (args (command-line)))
   (match args
     ((command load-path guix-package-path cachedir specstr database)
@@ -73,8 +85,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (pretty-print
               (map (lambda (thunk)
                      (let* ((job  (call-with-time-display thunk))
-                            ;; Keep track of SPEC id in the returned jobs.
-                            (job* (acons #:eval-id eval-id job)))
+                            ;; Fill job with informations that will later be
+                            ;; added to database.
+                            (job* (fill-job job eval-id)))
                        (db-add-derivation db job*)
                        job*))
                    thunks)
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 2899ffb..add13e0 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -10,7 +10,8 @@
 This manual is for Cuirass version @value{VERSION}, a build automation
 server.
 
-Copyright @copyright{} 2016, 2017 Mathieu Lirzin
+Copyright @copyright{} 2016, 2017 Mathieu Lirzin@*
+Copyright @copyright{} 2017 Mathieu Othacehe
 
 @quotation
 Permission is granted to copy, distribute and/or modify this document
@@ -312,6 +313,14 @@ This field holds the @code{id} of an evaluation from the
 
 @item job_name
 This text field holds the name of the job.
+
+@item system
+This text field holds the system name of the derivation.
+
+@item nix_name
+This text field holds the name of the derivation ---e.g.,
+@code{coreutils-8.24}.
+
 @end table
 
 @section Builds
@@ -322,6 +331,9 @@ that builds are not in a one to one relationship with derivations in
 order to keep track of non-deterministic compilations.
 
 @table @code
+@item id
+This is an automatically incrementing numeric identifier.
+
 @item derivation
 This text field holds the absolute name of the derivation file that
 resulted in this build.
@@ -334,9 +346,41 @@ belongs.
 @item log
 This text field holds the absolute file name of the build log file.
 
-@item output
-This text field holds the absolute directory name of the build output or
-@code{NULL} if the build failed.
+@item status
+This integer field holds the build status of the derivation.
+
+@item timestamp
+This integer field holds a timestamp taken at build creation time.
+
+@item starttime
+This integer field holds a timestamp taken at build start time.
+Currently, it has the same value as the @code{timestamp} above.
+
+@item stoptime
+This integer field holds a timestamp taken at build stop time.
+Currently, it has the same value as the @code{timestamp} above.
+
+@end table
+
+@section Outputs
+@cindex outputs, database
+
+This table keep tracks for every eventual build outputs. Each build
+stored in @code{Builds} table may have zero (if it has failed), one or
+multiple outputs.
+
+@table @code
+@item build
+This field holds the @code{id} of a build from the
+@code{Builds} table.
+
+@item name
+This text field holds the name of the output.
+
+@item path
+This text field holds the path of the output.
+
+@end table
 @end table
 
 
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 00b58f6..02e587a 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -33,6 +33,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -182,25 +183,41 @@ directory and the sha1 of the top level commit in this directory."
 
 (define (build-packages store db jobs)
   "Build JOBS and return a list of Build results."
+
+  (define hydra-build-status
+    ;; Build status as expected by hydra compatible API's.
+    '((succeeded         . 0)
+      (failed            . 1)
+      (failed-dependency . 2)
+      (failed-other      . 3)
+      (cancelled         . 4)))
+
   (define (register job)
     (let* ((name     (assq-ref job #:job-name))
            (drv      (assq-ref job #:derivation))
            (eval-id  (assq-ref job #:eval-id))
            ;; XXX: How to keep logs from several attempts?
            (log      (log-file store drv))
-           (outputs  (match (derivation-path->output-paths drv)
-                       (((names . items) ...)
-                        (filter (lambda (item)
-                                  (valid-path? store item))
-                                items)))))
-      (for-each (lambda (output)
-                  (let ((build `((#:derivation . ,drv)
-                                 (#:eval-id . ,eval-id)
-                                 (#:log . ,log)
-                                 (#:output . ,output))))
-                    (db-add-build db build)))
-                outputs)
-      (format #t "~{~A ~}\n" outputs)
+           (outputs  (filter-map (lambda (res)
+                                   (match res
+                                     ((name . path)
+                                      (and (valid-path? store path)
+                                           `(,name . ,path)))))
+                                 (derivation-path->output-paths drv)))
+           (cur-time (time-second (current-time time-utc))))
+      (let ((build `((#:derivation . ,drv)
+                     (#:eval-id . ,eval-id)
+                     (#:log . ,log)
+                     (#:status .
+                      ,(match (length outputs)
+                         (0 (assq-ref hydra-build-status 'failed))
+                         (_ (assq-ref hydra-build-status 'succeeded))))
+                     (#:outputs . ,outputs)
+                     ;;; XXX: For now, we do not know start/stop build time.
+                     (#:timestamp . ,cur-time)
+                     (#:starttime . ,cur-time)
+                     (#:stoptime . ,cur-time))))
+        (db-add-build db build))
       build))
 
   ;; Pass all the jobs at once so we benefit from as much parallelism as
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 31f78b1..37d126c 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -1,5 +1,6 @@
 ;;; database.scm -- store evaluation and build results
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -21,6 +22,7 @@
   #:use-module (cuirass utils)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
   #:use-module (sqlite3)
   #:export (;; Procedures.
             assq-refs
@@ -35,6 +37,8 @@
             db-add-derivation
             db-get-derivation
             db-add-build
+            db-get-build
+            db-get-builds
             read-sql-file
             read-quoted-string
             sqlite-exec
@@ -147,10 +151,12 @@ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
 (define (db-add-derivation db job)
   "Store a derivation result in database DB and return its ID."
   (sqlite-exec db "\
-INSERT OR IGNORE INTO Derivations (derivation, job_name, evaluation)\
-  VALUES ('~A', '~A', '~A');"
+INSERT OR IGNORE INTO Derivations (derivation, job_name, system, nix_name, evaluation)\
+  VALUES ('~A', '~A', '~A', '~A', '~A');"
                (assq-ref job #:derivation)
                (assq-ref job #:job-name)
+               (assq-ref job #:system)
+               (assq-ref job #:nix-name)
                (assq-ref job #:eval-id)))
 
 (define (db-get-derivation db id)
@@ -188,29 +194,126 @@ string."
   (logior SQLITE_CONSTRAINT (ash 6 8)))
 
 (define (db-add-build db build)
-  "Store BUILD in database DB.  This is idempotent."
-  (let ((derivation (assq-ref build #:derivation))
-        (eval-id    (assq-ref build #:eval-id))
-        (log        (assq-ref build #:log))
-        (output     (assq-ref build #:output)))
-   (catch 'sqlite-error
-     (lambda ()
-       (sqlite-exec db "\
-INSERT INTO Builds (derivation, evaluation, log, output)\
-  VALUES ('~A', '~A', '~A', '~A');"
-                    derivation eval-id log output))
-     (lambda (key who code message . rest)
-       ;; If we get a primary-key-constraint-violated error, that means we have
-       ;; already inserted the same (derivation,eval-id,log) tuple, which we
-       ;; can safely ignore.
-       (unless (= code SQLITE_CONSTRAINT_PRIMARYKEY)
-         (format (current-error-port)
-                 "error: failed to add build (~s, ~s, ~s, ~s) to database: ~a~%"
-                 derivation eval-id log output
-                 message)
-         (apply throw key who code rest)))))
+  "Store BUILD in database DB. BUILD eventual outputs are stored
+in the OUTPUTS table."
+  (let* ((build-exec
+          (sqlite-exec db "\
+INSERT INTO Builds (derivation, evaluation, log, status, timestamp, starttime, stoptime)\
+  VALUES ('~A', '~A', '~A', '~A', '~A', '~A', '~A');"
+                       (assq-ref build #:derivation)
+                       (assq-ref build #:eval-id)
+                       (assq-ref build #:log)
+                       (assq-ref build #:status)
+                       (assq-ref build #:timestamp)
+                       (assq-ref build #:starttime)
+                       (assq-ref build #:stoptime)))
+         (build-id (last-insert-rowid db)))
+    (for-each (lambda (output)
+                (match output
+                  ((name . path)
+                   (sqlite-exec db "\
+INSERT INTO Outputs (build, name, path) VALUES ('~A', '~A', '~A');"
+                                build-id name path))))
+              (assq-ref build #:outputs))
+    build-id))
 
-  (last-insert-rowid db))
+(define (db-get-outputs db build-id)
+  "Retrieve the OUTPUTS of the build identified by BUILD-ID in DB database."
+  (let loop ((rows
+              (sqlite-exec db "SELECT name, path FROM Outputs WHERE build='~A';"
+                           build-id))
+             (outputs '()))
+    (match rows
+      (() outputs)
+      ((#(name path)
+        . rest)
+       (loop rest
+             (cons `(,name . ((#:path . ,path)))
+                   outputs))))))
+
+(define db-build-request "\
+SELECT Builds.id, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status,\
+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 job-name system
+          nix-name repo-name branch)
+       `((#:id        . ,id)
+         (#:timestamp . ,timestamp)
+         (#:starttime . ,starttime)
+         (#:stoptime  . ,stoptime)
+         (#:log       . ,log)
+         (#:status    . ,status)
+         (#:job-name  . ,job-name)
+         (#:system    . ,system)
+         (#:nix-name  . ,nix-name)
+         (#:repo-name . ,repo-name)
+         (#: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='~A';") 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."
+
+  (define (format-where-clause filters)
+    (let ((where-clause
+           (filter-map
+            (lambda (param)
+              (match param
+                (('project project)
+                 (format #f "Specifications.repo_name='~A'" project))
+                (('jobset jobset)
+                 (format #f "Specifications.branch='~A'" jobset))
+                (('job job)
+                 (format #f "Derivations.job_name='~A'" job))
+                (('system system)
+                 (format #f "Derivations.system='~A'" system))
+                (_ #f)))
+            filters)))
+      (if (> (length where-clause) 0)
+          (string-append
+           "WHERE "
+           (string-join where-clause " AND "))
+          "")))
+
+  (define (format-order-clause filters)
+    (any
+     (lambda (param)
+       (match param
+         (('nr number)
+          (format #f "ORDER BY Builds.id DESC LIMIT '~A';" number))
+         (_ #f)))
+     filters))
+
+  (let loop ((rows
+              (sqlite-exec db (string-append
+                               db-build-request
+                               " "
+                               (format-where-clause filters)
+                               " "
+                               (format-order-clause filters))))
+             (outputs '()))
+    (match rows
+      (() outputs)
+      ((row . rest)
+       (loop rest
+             (cons (db-format-build db row) outputs))))))
 
 (define (db-get-stamp db spec)
   "Return a stamp corresponding to specification SPEC in database DB."
diff --git a/src/schema.sql b/src/schema.sql
index 329d89d..0ee428c 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -31,18 +31,31 @@ CREATE TABLE Derivations (
   derivation    TEXT NOT NULL,
   evaluation    INTEGER NOT NULL,
   job_name      TEXT NOT NULL,
+  system        TEXT NOT NULL,
+  nix_name      TEXT NOT NULL,
   PRIMARY KEY (derivation, evaluation),
   FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
 );
 
+CREATE TABLE Outputs (
+  build INTEGER NOT NULL,
+  name TEXT NOT NULL,
+  path TEXT NOT NULL,
+  PRIMARY KEY (build, name),
+  FOREIGN KEY (build) REFERENCES Builds (id)
+);
+
 -- Builds are not in a one to one relationship with derivations in order to
 -- keep track of non deterministic compilations.
 CREATE TABLE Builds (
+  id            INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
   derivation    TEXT NOT NULL,
   evaluation    INTEGER NOT NULL,
   log           TEXT NOT NULL,
-  output        TEXT,		-- NULL if build failed
-  PRIMARY KEY (derivation, evaluation, output),
+  status        INTEGER NOT NULL,
+  timestamp     INTEGER NOT NULL,
+  starttime     INTEGER NOT NULL,
+  stoptime      INTEGER NOT NULL,
   FOREIGN KEY (derivation) REFERENCES Derivations (derivation),
   FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
 );