[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
From: |
Mathieu Othacehe |
Date: |
Fri, 8 Sep 2017 15:14:24 -0400 (EDT) |
branch: master
commit e550cb6a9a9c8b42f9be88cc49d7b72232097045
Author: Mathieu Othacehe <address@hidden>
Date: Mon Jul 31 19:25:28 2017 +0200
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.
---
bin/evaluate.in | 17 +++++-
doc/cuirass.texi | 52 ++++++++++++++--
src/cuirass/base.scm | 43 ++++++++++----
src/cuirass/database.scm | 151 +++++++++++++++++++++++++++++++++++++++--------
src/schema.sql | 17 +++++-
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:address@hidden@} --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:address@hidden@} --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 address@hidden
+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.
+
address@hidden system
+This text field holds the system name of the derivation.
+
address@hidden nix_name
+This text field holds the name of the derivation ---e.g.,
address@hidden
+
@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
address@hidden 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.
address@hidden output
-This text field holds the absolute directory name of the build output or
address@hidden if the build failed.
address@hidden status
+This integer field holds the build status of the derivation.
+
address@hidden timestamp
+This integer field holds a timestamp taken at build creation time.
+
address@hidden starttime
+This integer field holds a timestamp taken at build start time.
+Currently, it has the same value as the @code{timestamp} above.
+
address@hidden stoptime
+This integer field holds a timestamp taken at build stop time.
+Currently, it has the same value as the @code{timestamp} above.
+
address@hidden table
+
address@hidden Outputs
address@hidden 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.
+
address@hidden @code
address@hidden build
+This field holds the @code{id} of a build from the
address@hidden table.
+
address@hidden name
+This text field holds the name of the output.
+
address@hidden path
+This text field holds the path of the output.
+
address@hidden 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 <address@hidden>
+;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;;
;;; 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)
);