Toggle diff (618 lines)
diff --git a/Makefile.am b/Makefile.am
index 65c9a29..f4a3663 100644
# Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2018 Clément Lassieur <clement@lassieur.org>
# Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
+# Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
# This file is part of Cuirass.
@@ -71,7 +72,8 @@ dist_sql_DATA = \
+ src/sql/upgrade-6.sql \
src/static/css/cuirass.css \
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index e652e8d..c6f64c9 100644
@@ -11,7 +11,7 @@ This manual is for Cuirass version @value{VERSION}, a build automation
Copyright @copyright{} 2016, 2017 Mathieu Lirzin@*
-Copyright @copyright{} 2017 Mathieu Othacehe@*
+Copyright @copyright{} 2017, 2020 Mathieu Othacehe@*
Copyright @copyright{} 2018 Ludovic Courtès@*
Copyright @copyright{} 2018 Clément Lassieur
@@ -137,7 +137,12 @@ a specification might look like:
(#:url . "git://my-custom-packages.git")
- (#:no-compile? . #t)))))
+ (#:no-compile? . #t))))
+ (#:path . "share/doc/hello-2.10/COPYING")))))
In this specification the keys are Scheme keywords which have the nice
@@ -150,6 +155,11 @@ containing the custom packages (see @code{GUIX_PACKAGE_PATH}).
@code{#:load-path-inputs}, @code{#:package-path-inputs} and
@code{#:proc-input} refer to these inputs by their name.
+The @code{#:build-outputs} list specifies the files that will be made
+available for download, through the Web interface. Here, the
+@code{COPYING} file, in the @code{"out"} output, for all jobs whose name
+matches @code{"hello*"} regex.
@c <https://github.com/libgit2/libgit2sharp/issues/1094#issuecomment-112306072>.
diff --git a/examples/guix-jobs.scm b/examples/guix-jobs.scm
index 963c7ff..2f1f1a2 100644
--- a/examples/guix-jobs.scm
+++ b/examples/guix-jobs.scm
;;; guix-jobs.scm -- job specification test for Guix
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
- (#:no-compile? . #t))))))
+ (#:no-compile? . #t))))
+ (#:build-outputs . ())))
(job-base #:branch "master"))
diff --git a/examples/hello-git.scm b/examples/hello-git.scm
index 6468452..c5e2ca2 100644
--- a/examples/hello-git.scm
+++ b/examples/hello-git.scm
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
(#:url . ,(string-append "file://" top-srcdir))
- (#:no-compile? . #t)))))))
+ (#:no-compile? . #t))))
+ (#:build-outputs . ()))))
diff --git a/examples/hello-singleton.scm b/examples/hello-singleton.scm
index a39191f..2d2d746 100644
--- a/examples/hello-singleton.scm
+++ b/examples/hello-singleton.scm
;;; hello-singleton.scm -- job specification test for hello in master
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
- (#:no-compile? . #t))))))
+ (#:no-compile? . #t))))
+ (#:build-outputs . ())))
diff --git a/examples/hello-subset.scm b/examples/hello-subset.scm
index 8c0d990..e86668e 100644
--- a/examples/hello-subset.scm
+++ b/examples/hello-subset.scm
;;; hello-subset.scm -- job specification test for hello subset
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
- (#:no-compile? . #t))))))
+ (#:no-compile? . #t))))
+ (#:build-outputs . ())))
(job-base #:branch "master"))
diff --git a/examples/random.scm b/examples/random.scm
index 37b97a2..f15e158 100644
--- a/examples/random.scm
+++ b/examples/random.scm
;;; random.scm -- Job specification that creates random build jobs
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
(#:url . ,(string-append "file://" top-srcdir))
- (#:no-compile? . #t)))))))
+ (#:no-compile? . #t))))
+ (#:build-outputs . ()))))
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 2b18dc6..b745058 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
;;; base.scm -- Cuirass base module
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
+ #:use-module (ice-9 regex)
#:use-module (ice-9 atomic)
#:use-module (ice-9 threads)
@@ -638,7 +639,42 @@ started)."
(spawn-builds store valid)
(log-message "done with restarted builds"))))
-(define (build-packages store jobs eval-id)
+(define (create-build-outputs builds product-specs)
+ "Given BUILDS a list of built derivations, save the build products described
+ (define (find-build job-regex)
+ (let ((job-name (assq-ref build #:job-name)))
+ (string-match job-regex job-name)))
+ (define* (find-product build spec)
+ (let* ((outputs (assq-ref build #:outputs))
+ (output (assq-ref spec #:output))
+ (path (assq-ref spec #:path))
+ (root (and=> (assoc-ref outputs output)
+ (cut assq-ref <> #:path))))
+ (string-append root "/" path)))))
+ (define (file-size file)
+ (stat:size (stat file)))
+ (let* ((build (find-build (assq-ref spec #:job)))
+ (product (find-product build spec)))
+ (when (and product (file-exists? product))
+ (db-add-build-product `((#:build . ,(assq-ref build #:id))
+ (#:type . (assq-ref spec #:type))
+ (#:file-size . ,(file-size product))
+ (#:path . ,product))))))
+(define (build-packages store spec jobs eval-id)
"Build JOBS and return a list of Build results."
(let* ((name (assq-ref job #:job-name))
@@ -692,6 +728,8 @@ started)."
(fail (- (length derivations) success)))
+ (create-build-outputs results (assq-ref spec #:build-outputs))
(log-message "outputs:\n~a" (string-join outs "\n"))
(log-message "success: ~a, fail: ~a" success fail)
@@ -777,7 +815,7 @@ started)."
(let ((jobs (evaluate store spec eval-id checkouts)))
(log-message "building ~a jobs for '~a'"
- (build-packages store jobs eval-id))))))
+ (build-packages store spec jobs eval-id))))))
;; 'spawn-fiber' returns zero values but we need one.
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index f80585e..0ed0720 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
;;; database.scm -- store evaluation and build results
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
db-get-pending-derivations
db-get-evaluations-id-min
db-get-evaluations-id-max
db-get-evaluation-specification
+ db-get-build-product-path
db-get-evaluation-summary
@@ -334,7 +337,8 @@ table."
(with-db-worker-thread db
INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \
-package_path_inputs, proc_input, proc_file, proc, proc_args) \
+package_path_inputs, proc_input, proc_file, proc, proc_args, \
(assq-ref spec #:name) ", "
(assq-ref spec #:load-path-inputs) ", "
@@ -342,7 +346,8 @@ package_path_inputs, proc_input, proc_file, proc, proc_args) \
(assq-ref spec #:proc-input) ", "
(assq-ref spec #:proc-file) ", "
(symbol->string (assq-ref spec #:proc)) ", "
- (assq-ref spec #:proc-args) ");")
+ (assq-ref spec #:proc-args) ", "
+ (assq-ref spec #:build-outputs) ");")
(let ((spec-id (last-insert-rowid db)))
(for-each (lambda (input)
(db-add-input (assq-ref spec #:name) input))
@@ -386,7 +391,7 @@ DELETE FROM Specifications WHERE name=" name ";")
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
+ proc-args build-outputs)
@@ -398,7 +403,9 @@ DELETE FROM Specifications WHERE name=" name ";")
(#:proc-file . ,proc-file)
(#:proc . ,(with-input-from-string proc read))
(#:proc-args . ,(with-input-from-string proc-args read))
- (#:inputs . ,(db-get-inputs name)))
+ (#:inputs . ,(db-get-inputs name))
+ ,(with-input-from-string build-outputs read)))
(define (db-add-evaluation spec-name checkouts)
@@ -538,6 +545,19 @@ VALUES ("
(sqlite-exec db "ROLLBACK;") #f))))
+(define (db-add-build-product product)
+ "Insert PRODUCT into BuildProducts table."
+ (with-db-worker-thread db
+INSERT INTO BuildProducts (build, type, file_size, sha256_hash,
+ (assq-ref product #:build) ", "
+ (assq-ref product #:type) ", "
+ (assq-ref product #:file-size) ", "
+ (assq-ref product #:sha256-hash) ", "
+ (assq-ref product #:path) ");")
+ (last-insert-rowid db)))
(define* (db-update-build-status! drv status #:key log-file)
"Update the database so that DRV's status is STATUS. This also updates the
'starttime' or 'stoptime' fields. If LOG-FILE is true, record it as the build
@@ -1066,3 +1086,30 @@ AND (" status " IS NULL OR (" status " = 'pending'
SELECT specification FROM Evaluations
(and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+(define (db-get-build-product-path id)
+ "Return the build product with the given ID."
+ (with-db-worker-thread db
+ (let ((rows (sqlite-exec db "
+SELECT path FROM BuildProducts
+ (and=> (expect-one-row rows) (cut vector-ref <> 0)))))
+(define (db-get-build-products build-id)
+ "Return the build products associated to the given BUILD-ID."
+ (with-db-worker-thread db
+ (let loop ((rows (sqlite-exec db "
+SELECT rowid, type, file_size, sha256_hash, path from BuildProducts
+WHERE build = " build-id))
+ (() (reverse products))
+ ((#(id type file-size sha256-hash path)
+ (#:file-size . ,file-size)
+ (#:sha256-hash . ,sha256-hash)
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index c5901f0..79fa246 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
;;;; http.scm -- HTTP API
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
@@ -246,17 +246,29 @@ Hydra format."
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
+ (define* (respond-file file
+ (let ((content-type (or (assoc-ref %file-mime-types
+ '(application/octet-stream))))
+ (respond `((content-type . ,content-type)
+ . (form-data (filename . ,name))))
+ ;; FIXME: FILE is potentially big so it'd be better to not load
+ ;; it in memory and instead 'sendfile' it.
+ #:body (call-with-input-file file get-bytevector-all))))
(define (respond-static-file path)
;; PATH is a list of path components
(let ((file-name (string-join path "/"))
(file-path (string-join (cons* (%static-directory) path) "/")))
- (if (and (member file-name %file-white-list)
+ (if (and (member file-name %file-white-list)
(not (file-is-directory? file-path)))
- (respond `((content-type . ,(assoc-ref %file-mime-types
- (file-extension file-path))))
- #:body (call-with-input-file file-path get-bytevector-all))
- (respond-not-found file-name))))
+ (respond-file file-path)
+ (respond-not-found file-name))))
(define (respond-gzipped-file file)
;; Return FILE with 'gzip' content-encoding.
@@ -318,7 +330,8 @@ Hydra format."
(#:url . "https://git.savannah.gnu.org/git/guix.git")
- (#:no-compile? . #t)))))
+ (#:build-outputs . ())))
(respond (build-response #:code 302
#:headers `((location . ,(string->uri-reference
"/admin/specifications"))))
@@ -352,11 +365,12 @@ Hydra format."
(respond-json (object->json-string hydra-build))
(respond-build-not-found id))))
(('GET "build" build-id "details")
- (let ((build (db-get-build (string->number build-id))))
+ (let ((build (db-get-build (string->number build-id)))
+ (products (db-get-build-products build-id)))
(html-page (string-append "Build " build-id)
+ (build-details build products)
`(((#:name . ,(assq-ref build #:specification))
(#:link . ,(string-append "/jobset/" (assq-ref build #:specification)))))))
(respond-build-not-found build-id))))
@@ -505,6 +519,10 @@ Hydra format."
(respond-json-with-error 500 "Query parameter not provided!"))))
+ (let ((path (db-get-build-product-path id)))
+ (respond-file path #:name (basename path))))
(('GET "static" path ...)
(respond-static-file path))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 4104c7b..600d9d8 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
#:use-module (srfi srfi-26)
#:use-module (guix derivations)
+ #:use-module (guix progress)
#:use-module (guix store)
#:use-module ((guix utils) #:select (string-replace-substring))
#:use-module ((cuirass database) #:select (build-status))
@@ -212,7 +214,7 @@ system whose names start with " (code "guile-") ":" (br)
-(define (build-details build)
+(define (build-details build products)
"Return HTML showing details for the BUILD."
(define status (assq-ref build #:status))
@@ -282,7 +284,38 @@ system whose names start with " (code "guile-") ":" (br)
(td ,(map (match-lambda ((out (#:path . path))
- (assq-ref build #:outputs))))))))
+ (assq-ref build #:outputs))))
+ (let* ((id (assq-ref product #:id))
+ (size (assq-ref product #:file-size))
+ (type (assq-ref product #:type))
+ (path (assq-ref product #:path))
+ (href (format #f "/download/~a" id)))
+ (li (@ (class "list-group-item"))
+ (@ (class "container"))
+ (@ (class "col-md-auto"))
+ (@ (class "oi oi-data-transfer-download")
+ (aria-hidden "true"))))
+ (div (@ (class "col-md-auto"))
+ (div (@ (class "col-md-auto"))
+ "(" ,(byte-count->string size) ")")))))))
+ `((tr (th "Build outputs")
+ (ul (@ (class "list-group d-flex flex-row"))
+ ,product-items))))))))))
(define (pagination first-link prev-link next-link last-link)
"Return html page navigation buttons with LINKS."
diff --git a/src/schema.sql b/src/schema.sql
index 1104551..3838f75 100644
@@ -7,7 +7,8 @@ CREATE TABLE Specifications (
proc_input TEXT NOT NULL, -- name of the input containing the proc that does the evaluation
proc_file TEXT NOT NULL, -- file containing the procedure that does the evaluation, relative to proc_input
proc TEXT NOT NULL, -- defined in proc_file
- proc_args TEXT NOT NULL -- passed to proc
+ proc_args TEXT NOT NULL, -- passed to proc
+ build_outputs TEXT NOT NULL --specify what build outputs should be made available for download
@@ -65,6 +66,16 @@ CREATE TABLE Builds (
FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
+CREATE TABLE BuildProducts (
+ build INTEGER NOT NULL,
+ file_size BIGINT NOT NULL,
+ sha256_hash TEXT NOT NULL,
+ PRIMARY KEY (build, path)
+ FOREIGN KEY (build) REFERENCES Builds (id) ON DELETE CASCADE
diff --git a/src/sql/upgrade-7.sql b/src/sql/upgrade-7.sql
+++ b/src/sql/upgrade-7.sql
+CREATE TABLE BuildProducts (
+ build INTEGER NOT NULL,
+ file_size BIGINT NOT NULL,
+ sha256_hash TEXT NOT NULL,
+ PRIMARY KEY (build, path)
+ FOREIGN KEY (build) REFERENCES Builds (id) ON DELETE CASCADE
+ALTER TABLE Specifications ADD build_outputs TEXT NOT NULL DEFAULT "()";
diff --git a/tests/database.scm b/tests/database.scm
index 6098465..98b5012 100644
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; This file is part of Cuirass.
- (#:no-compile? . #f))))))
+ (#:no-compile? . #f))))
+ (#:build-outputs . ())))
(define (make-dummy-checkouts fakesha1 fakesha2)
`(((#:commit . ,fakesha1)
diff --git a/tests/http.scm b/tests/http.scm
index d20a3c3..d69c25c 100644
;;; http.scm -- tests for (cuirass http) module
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; This file is part of Cuirass.
- (#:no-compile? . #f))))))
+ (#:no-compile? . #f))))
+ (#:build-outputs . ())))
'(((#:commit . "fakesha1")