diff options
| -rw-r--r-- | bin/evaluate.in | 17 | ||||
| -rw-r--r-- | doc/cuirass.texi | 52 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 43 | ||||
| -rw-r--r-- | src/cuirass/database.scm | 151 | ||||
| -rw-r--r-- | 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:-@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) ); |