guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Add support for build products downloading. 

* src/sql/upgrade-7.sql: New file.
* Makefile.am: Add it.
* src/cuirass/base.scm (create-build-outputs): New procedure,
(build-packages): call it,
(process-spec): add the new spec argument and pass it to create-build-outputs.
* src/cuirass/database.scm (db-add-build-product, db-get-build-product-path,
db-get-build-products): New exported procedures.
* src/cuirass/http.scm (respond-static-file): Move file sending to ...
(respond-file): ... this new procedure,
(url-handler): add a new "download/<id>" route, serving the requested file
with the new respond-file procedure. Also gather build products and pass them
to "build-details" for "build/<id>/details" route.
* src/cuirass/templates.scm (build-details): Honor the new "products" argument
to display all the build products associated to the given build.
* src/schema.sql (BuildProducts): New table,
(Specifications)[build_outputs]: new field.
* tests/database.scm: Add empty build-outputs spec.
* tests/http.scm: Ditto.
* examples/guix-jobs.scm: Ditto.
* examples/hello-git.scm: Ditto.
* examples/hello-singleton.scm: Ditto.
* examples/hello-subset.scm: Ditto.
* examples/random.scm: Ditto.
* doc/cuirass.texi (overview): Document it.
This commit is contained in:
Mathieu Othacehe 2020-06-10 15:58:11 +02:00
parent 78986d9623
commit f44618fc79
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
15 changed files with 218 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile.am
View File

@ -5,6 +5,7 @@
# 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-3.sql \
src/sql/upgrade-4.sql \
src/sql/upgrade-5.sql \
src/sql/upgrade-6.sql
src/sql/upgrade-6.sql \
src/sql/upgrade-7.sql
dist_css_DATA = \
src/static/css/cuirass.css \

14
doc/cuirass.texi
View File

@ -11,7 +11,7 @@ This manual is for Cuirass version @value{VERSION}, a build automation
server.
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")
(#:load-path . ".")
(#:branch . "master")
(#:no-compile? . #t)))))
(#:no-compile? . #t))))
(#:build-outputs .
(((#:job . "hello*")
(#:type . "license")
(#:output . "out")
(#:path . "share/doc/hello-2.10/COPYING")))))
@end lisp
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.
@quotation Note
@c This refers to
@c <https://github.com/libgit2/libgit2sharp/issues/1094#issuecomment-112306072>.

4
examples/guix-jobs.scm
View File

@ -1,6 +1,7 @@
;;; 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.
;;;
@ -34,7 +35,8 @@
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
(#:load-path . ".")
(#:branch . "master")
(#:no-compile? . #t))))))
(#:no-compile? . #t))))
(#:build-outputs . ())))
(define guix-master
(job-base #:branch "master"))

4
examples/hello-git.scm
View File

@ -2,6 +2,7 @@
;;; 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.
;;;
@ -43,4 +44,5 @@
(#:url . ,(string-append "file://" top-srcdir))
(#:load-path . ".")
(#:branch . "master")
(#:no-compile? . #t)))))))
(#:no-compile? . #t))))
(#:build-outputs . ()))))

4
examples/hello-singleton.scm
View File

@ -1,6 +1,7 @@
;;; 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.
;;;
@ -34,6 +35,7 @@
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
(#:load-path . ".")
(#:branch . "master")
(#:no-compile? . #t))))))
(#:no-compile? . #t))))
(#:build-outputs . ())))
(list hello-master)

4
examples/hello-subset.scm
View File

@ -1,6 +1,7 @@
;;; 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.
;;;
@ -34,7 +35,8 @@
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
(#:load-path . ".")
(#:branch . "master")
(#:no-compile? . #t))))))
(#:no-compile? . #t))))
(#:build-outputs . ())))
(define guix-master
(job-base #:branch "master"))

4
examples/random.scm
View File

@ -1,6 +1,7 @@
;;; 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.
;;;
@ -31,4 +32,5 @@
(#:url . ,(string-append "file://" top-srcdir))
(#:load-path . ".")
(#:branch . "master")
(#:no-compile? . #t)))))))
(#:no-compile? . #t))))
(#:build-outputs . ()))))

44
src/cuirass/base.scm
View File

@ -1,7 +1,7 @@
;;; 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>
;;;
@ -41,6 +41,7 @@
#: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 ftw)
#: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
by PRODUCT-SPECS."
(define (find-build job-regex)
(find (lambda (build)
(let ((job-name (assq-ref build #:job-name)))
(string-match job-regex job-name)))
builds))
(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))))
(and root
(if (string=? path "")
root
(string-append root "/" path)))))
(define (file-size file)
(stat:size (stat file)))
(for-each (lambda (spec)
(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))
;; TODO: Implement it.
(#:checksum . "")
(#:path . ,product))))))
product-specs))
(define (build-packages store spec jobs eval-id)
"Build JOBS and return a list of Build results."
(define (register job)
(let* ((name (assq-ref job #:job-name))
@ -692,6 +728,8 @@ started)."
outputs))
outputs))
(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)
results))
@ -777,7 +815,7 @@ started)."
(let ((jobs (evaluate store spec eval-id checkouts)))
(log-message "building ~a jobs for '~a'"
(length jobs) name)
(build-packages store jobs eval-id))))))
(build-packages store spec jobs eval-id))))))
;; 'spawn-fiber' returns zero values but we need one.
*unspecified*))))

57
src/cuirass/database.scm
View File

@ -1,6 +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>
;;; 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>
@ -48,6 +48,7 @@
db-get-pending-derivations
build-status
db-add-build
db-add-build-product
db-update-build-status!
db-get-output
db-get-inputs
@ -66,6 +67,8 @@
db-get-evaluations-id-min
db-get-evaluations-id-max
db-get-evaluation-specification
db-get-build-product-path
db-get-build-products
db-get-evaluation-summary
db-get-checkouts
read-sql-file
@ -342,7 +345,8 @@ table."
(with-db-worker-thread db
(sqlite-exec 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, \
build_outputs) \
VALUES ("
(assq-ref spec #:name) ", "
(assq-ref spec #:load-path-inputs) ", "
@ -350,7 +354,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))
@ -394,7 +399,7 @@ DELETE FROM Specifications WHERE name=" name ";")
(match rows
(() specs)
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
proc-args)
proc-args build-outputs)
. rest)
(loop rest
(cons `((#:name . ,name)
@ -406,7 +411,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))
(#:build-outputs .
,(with-input-from-string build-outputs read)))
specs)))))))
(define (db-add-evaluation spec-name checkouts)
@ -546,6 +553,19 @@ VALUES ("
=>
(sqlite-exec db "ROLLBACK;") #f))))
(define (db-add-build-product product)
"Insert PRODUCT into BuildProducts table."
(with-db-worker-thread db
(sqlite-exec db "\
INSERT INTO BuildProducts (build, type, file_size, checksum,
path) VALUES ("
(assq-ref product #:build) ", "
(assq-ref product #:type) ", "
(assq-ref product #:file-size) ", "
(assq-ref product #:checksum) ", "
(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
@ -1098,3 +1118,30 @@ AND (" status " IS NULL OR (" status " = 'pending'
SELECT specification FROM Evaluations
WHERE id = " eval)))
(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
WHERE rowid = " id)))
(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, checksum, path from BuildProducts
WHERE build = " build-id))
(products '()))
(match rows
(() (reverse products))
((#(id type file-size checksum path)
. rest)
(loop rest
(cons `((#:id . ,id)
(#:type . ,type)
(#:file-size . ,file-size)
(#:checksum . ,checksum)
(#:path . ,path))
products)))))))

36
src/cuirass/http.scm
View File

@ -1,6 +1,6 @@
;;;; 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")
(sxml->xml body port))))
(define* (respond-file file
#:key name)
(let ((content-type (or (assoc-ref %file-mime-types
(file-extension file))
'(application/octet-stream))))
(respond `((content-type . ,content-type)
,@(if name
`((content-disposition
. (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)
(file-exists? file-path)
(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")
(#:load-path . ".")
(#:branch . ,name)
(#:no-compile? . #t)))))
(#: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)))
(if build
(respond-html
(html-page (string-append "Build " build-id)
(build-details build)
(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."
query))
(respond-json-with-error 500 "Query parameter not provided!"))))
(('GET "download" id)
(let ((path (db-get-build-product-path id)))
(respond-file path #:name (basename path))))
(('GET "static" path ...)
(respond-static-file path))
(_

37
src/cuirass/templates.scm
View File

@ -2,6 +2,7 @@
;;; 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.
;;;
@ -27,6 +28,7 @@
#:use-module (srfi srfi-26)
#:use-module (web uri)
#: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)
"Add")))))
'()))))
(define (build-details build)
(define (build-details build products)
"Return HTML showing details for the BUILD."
(define status (assq-ref build #:status))
(define blocking-outputs
@ -282,7 +284,38 @@ system whose names start with " (code "guile-") ":" (br)
(tr (th "Outputs")
(td ,(map (match-lambda ((out (#:path . path))
`(pre ,path)))
(assq-ref build #:outputs))))))))
(assq-ref build #:outputs))))
,@(if (null? products)
'()
(let ((product-items
(map
(lambda (product)
(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)))
`(a (@ (href ,href))
(li (@ (class "list-group-item"))
(div
(@ (class "container"))
(div
(@ (class "row"))
(div
(@ (class "col-md-auto"))
(span
(@ (class "oi oi-data-transfer-download")
(title "Download")
(aria-hidden "true"))))
(div (@ (class "col-md-auto"))
,path)
(div (@ (class "col-md-auto"))
"(" ,(byte-count->string size) ")")))))))
products)))
`((tr (th "Build outputs")
(td
(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."

13
src/schema.sql
View File

@ -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
);
CREATE TABLE Inputs (
@ -65,6 +66,16 @@ CREATE TABLE Builds (
FOREIGN KEY (evaluation) REFERENCES Evaluations (id)
);
CREATE TABLE BuildProducts (
build INTEGER NOT NULL,
type TEXT NOT NULL,
file_size BIGINT NOT NULL,
checksum TEXT NOT NULL,
path TEXT NOT NULL,
PRIMARY KEY (build, path)
FOREIGN KEY (build) REFERENCES Builds (id) ON DELETE CASCADE
);
CREATE TABLE Events (
id INTEGER PRIMARY KEY,
type TEXT NOT NULL,

15
src/sql/upgrade-7.sql Normal file
View File

@ -0,0 +1,15 @@
BEGIN TRANSACTION;
CREATE TABLE BuildProducts (
build INTEGER NOT NULL,
type TEXT NOT NULL,
file_size BIGINT NOT NULL,
checksum TEXT NOT NULL,
path 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 "()";
COMMIT;

4
tests/database.scm
View File

@ -3,6 +3,7 @@
;;; 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.
;;;
@ -45,7 +46,8 @@
(#:branch . "master")
(#:tag . #f)
(#:commit . #f)
(#:no-compile? . #f))))))
(#:no-compile? . #f))))
(#:build-outputs . ())))
(define (make-dummy-checkouts fakesha1 fakesha2)
`(((#:commit . ,fakesha1)

5
tests/http.scm
View File

@ -1,7 +1,7 @@
;;; 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.
@ -170,7 +170,8 @@
(#:branch . "master")
(#:tag . #f)
(#:commit . #f)
(#:no-compile? . #f))))))
(#:no-compile? . #f))))
(#:build-outputs . ())))
(checkouts1
'(((#:commit . "fakesha1")
(#:input . "savannah")