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

View File

@ -5,6 +5,7 @@
# Copyright © 2018 Ludovic Courtès <ludo@gnu.org> # Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2018 Clément Lassieur <clement@lassieur.org> # Copyright © 2018 Clément Lassieur <clement@lassieur.org>
# Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com> # Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
# Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
# #
# This file is part of Cuirass. # This file is part of Cuirass.
# #
@ -71,7 +72,8 @@ dist_sql_DATA = \
src/sql/upgrade-3.sql \ src/sql/upgrade-3.sql \
src/sql/upgrade-4.sql \ src/sql/upgrade-4.sql \
src/sql/upgrade-5.sql \ src/sql/upgrade-5.sql \
src/sql/upgrade-6.sql src/sql/upgrade-6.sql \
src/sql/upgrade-7.sql
dist_css_DATA = \ dist_css_DATA = \
src/static/css/cuirass.css \ src/static/css/cuirass.css \

View File

@ -11,7 +11,7 @@ This manual is for Cuirass version @value{VERSION}, a build automation
server. server.
Copyright @copyright{} 2016, 2017 Mathieu Lirzin@* 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 Ludovic Courtès@*
Copyright @copyright{} 2018 Clément Lassieur Copyright @copyright{} 2018 Clément Lassieur
@ -137,7 +137,12 @@ a specification might look like:
(#:url . "git://my-custom-packages.git") (#:url . "git://my-custom-packages.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#: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 @end lisp
In this specification the keys are Scheme keywords which have the nice 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{#:load-path-inputs}, @code{#:package-path-inputs} and
@code{#:proc-input} refer to these inputs by their name. @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 @quotation Note
@c This refers to @c This refers to
@c <https://github.com/libgit2/libgit2sharp/issues/1094#issuecomment-112306072>. @c <https://github.com/libgit2/libgit2sharp/issues/1094#issuecomment-112306072>.

View File

@ -1,6 +1,7 @@
;;; guix-jobs.scm -- job specification test for Guix ;;; guix-jobs.scm -- job specification test for Guix
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -34,7 +35,8 @@
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git") (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:no-compile? . #t)))))) (#:no-compile? . #t))))
(#:build-outputs . ())))
(define guix-master (define guix-master
(job-base #:branch "master")) (job-base #:branch "master"))

View File

@ -2,6 +2,7 @@
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -43,4 +44,5 @@
(#:url . ,(string-append "file://" top-srcdir)) (#:url . ,(string-append "file://" top-srcdir))
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:no-compile? . #t))))))) (#:no-compile? . #t))))
(#:build-outputs . ()))))

View File

@ -1,6 +1,7 @@
;;; hello-singleton.scm -- job specification test for hello in master ;;; hello-singleton.scm -- job specification test for hello in master
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -34,6 +35,7 @@
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git") (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:no-compile? . #t)))))) (#:no-compile? . #t))))
(#:build-outputs . ())))
(list hello-master) (list hello-master)

View File

@ -1,6 +1,7 @@
;;; hello-subset.scm -- job specification test for hello subset ;;; hello-subset.scm -- job specification test for hello subset
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -34,7 +35,8 @@
(#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git") (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:no-compile? . #t)))))) (#:no-compile? . #t))))
(#:build-outputs . ())))
(define guix-master (define guix-master
(job-base #:branch "master")) (job-base #:branch "master"))

View File

@ -1,6 +1,7 @@
;;; random.scm -- Job specification that creates random build jobs ;;; random.scm -- Job specification that creates random build jobs
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -31,4 +32,5 @@
(#:url . ,(string-append "file://" top-srcdir)) (#:url . ,(string-append "file://" top-srcdir))
(#:load-path . ".") (#:load-path . ".")
(#:branch . "master") (#:branch . "master")
(#:no-compile? . #t))))))) (#:no-compile? . #t))))
(#:build-outputs . ()))))

View File

@ -1,7 +1,7 @@
;;; base.scm -- Cuirass base module ;;; base.scm -- Cuirass base module
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@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 © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; ;;;
@ -41,6 +41,7 @@
#:use-module (ice-9 popen) #:use-module (ice-9 popen)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 atomic) #:use-module (ice-9 atomic)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 threads) #:use-module (ice-9 threads)
@ -638,7 +639,42 @@ started)."
(spawn-builds store valid) (spawn-builds store valid)
(log-message "done with restarted builds")))) (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." "Build JOBS and return a list of Build results."
(define (register job) (define (register job)
(let* ((name (assq-ref job #:job-name)) (let* ((name (assq-ref job #:job-name))
@ -692,6 +728,8 @@ started)."
outputs)) outputs))
outputs)) outputs))
(fail (- (length derivations) success))) (fail (- (length derivations) success)))
(create-build-outputs results (assq-ref spec #:build-outputs))
(log-message "outputs:\n~a" (string-join outs "\n")) (log-message "outputs:\n~a" (string-join outs "\n"))
(log-message "success: ~a, fail: ~a" success fail) (log-message "success: ~a, fail: ~a" success fail)
results)) results))
@ -777,7 +815,7 @@ started)."
(let ((jobs (evaluate store spec eval-id checkouts))) (let ((jobs (evaluate store spec eval-id checkouts)))
(log-message "building ~a jobs for '~a'" (log-message "building ~a jobs for '~a'"
(length jobs) name) (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. ;; 'spawn-fiber' returns zero values but we need one.
*unspecified*)))) *unspecified*))))

View File

@ -1,6 +1,6 @@
;;; database.scm -- store evaluation and build results ;;; database.scm -- store evaluation and build results
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@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 © 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com> ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
@ -48,6 +48,7 @@
db-get-pending-derivations db-get-pending-derivations
build-status build-status
db-add-build db-add-build
db-add-build-product
db-update-build-status! db-update-build-status!
db-get-output db-get-output
db-get-inputs db-get-inputs
@ -66,6 +67,8 @@
db-get-evaluations-id-min db-get-evaluations-id-min
db-get-evaluations-id-max db-get-evaluations-id-max
db-get-evaluation-specification db-get-evaluation-specification
db-get-build-product-path
db-get-build-products
db-get-evaluation-summary db-get-evaluation-summary
db-get-checkouts db-get-checkouts
read-sql-file read-sql-file
@ -342,7 +345,8 @@ table."
(with-db-worker-thread db (with-db-worker-thread db
(sqlite-exec db "\ (sqlite-exec db "\
INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \ 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 (" VALUES ("
(assq-ref spec #:name) ", " (assq-ref spec #:name) ", "
(assq-ref spec #:load-path-inputs) ", " (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-input) ", "
(assq-ref spec #:proc-file) ", " (assq-ref spec #:proc-file) ", "
(symbol->string (assq-ref spec #:proc)) ", " (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))) (let ((spec-id (last-insert-rowid db)))
(for-each (lambda (input) (for-each (lambda (input)
(db-add-input (assq-ref spec #:name) input)) (db-add-input (assq-ref spec #:name) input))
@ -394,7 +399,7 @@ DELETE FROM Specifications WHERE name=" name ";")
(match rows (match rows
(() specs) (() specs)
((#(name load-path-inputs package-path-inputs proc-input proc-file proc ((#(name load-path-inputs package-path-inputs proc-input proc-file proc
proc-args) proc-args build-outputs)
. rest) . rest)
(loop rest (loop rest
(cons `((#:name . ,name) (cons `((#:name . ,name)
@ -406,7 +411,9 @@ DELETE FROM Specifications WHERE name=" name ";")
(#:proc-file . ,proc-file) (#:proc-file . ,proc-file)
(#:proc . ,(with-input-from-string proc read)) (#:proc . ,(with-input-from-string proc read))
(#:proc-args . ,(with-input-from-string proc-args 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))))))) specs)))))))
(define (db-add-evaluation spec-name checkouts) (define (db-add-evaluation spec-name checkouts)
@ -546,6 +553,19 @@ VALUES ("
=> =>
(sqlite-exec db "ROLLBACK;") #f)))) (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) (define* (db-update-build-status! drv status #:key log-file)
"Update the database so that DRV's status is STATUS. This also updates the "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 '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 SELECT specification FROM Evaluations
WHERE id = " eval))) WHERE id = " eval)))
(and=> (expect-one-row rows) (cut vector-ref <> 0))))) (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)))))))

View File

@ -1,6 +1,6 @@
;;;; http.scm -- HTTP API ;;;; http.scm -- HTTP API
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; 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, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com> ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
@ -246,17 +246,29 @@ Hydra format."
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
(sxml->xml body port)))) (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) (define (respond-static-file path)
;; PATH is a list of path components ;; PATH is a list of path components
(let ((file-name (string-join path "/")) (let ((file-name (string-join path "/"))
(file-path (string-join (cons* (%static-directory) 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) (file-exists? file-path)
(not (file-is-directory? file-path))) (not (file-is-directory? file-path)))
(respond `((content-type . ,(assoc-ref %file-mime-types (respond-file file-path)
(file-extension file-path)))) (respond-not-found file-name))))
#:body (call-with-input-file file-path get-bytevector-all))
(respond-not-found file-name))))
(define (respond-gzipped-file file) (define (respond-gzipped-file file)
;; Return FILE with 'gzip' content-encoding. ;; Return FILE with 'gzip' content-encoding.
@ -318,7 +330,8 @@ Hydra format."
(#:url . "https://git.savannah.gnu.org/git/guix.git") (#:url . "https://git.savannah.gnu.org/git/guix.git")
(#:load-path . ".") (#:load-path . ".")
(#:branch . ,name) (#:branch . ,name)
(#:no-compile? . #t))))) (#:no-compile? . #t)))
(#:build-outputs . ())))
(respond (build-response #:code 302 (respond (build-response #:code 302
#:headers `((location . ,(string->uri-reference #:headers `((location . ,(string->uri-reference
"/admin/specifications")))) "/admin/specifications"))))
@ -352,11 +365,12 @@ Hydra format."
(respond-json (object->json-string hydra-build)) (respond-json (object->json-string hydra-build))
(respond-build-not-found id)))) (respond-build-not-found id))))
(('GET "build" build-id "details") (('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 (if build
(respond-html (respond-html
(html-page (string-append "Build " build-id) (html-page (string-append "Build " build-id)
(build-details build) (build-details build products)
`(((#:name . ,(assq-ref build #:specification)) `(((#:name . ,(assq-ref build #:specification))
(#:link . ,(string-append "/jobset/" (assq-ref build #:specification))))))) (#:link . ,(string-append "/jobset/" (assq-ref build #:specification)))))))
(respond-build-not-found build-id)))) (respond-build-not-found build-id))))
@ -505,6 +519,10 @@ Hydra format."
query)) query))
(respond-json-with-error 500 "Query parameter not provided!")))) (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 ...) (('GET "static" path ...)
(respond-static-file path)) (respond-static-file path))
(_ (_

View File

@ -2,6 +2,7 @@
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com> ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -27,6 +28,7 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (web uri) #:use-module (web uri)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix progress)
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix utils) #:select (string-replace-substring)) #:use-module ((guix utils) #:select (string-replace-substring))
#:use-module ((cuirass database) #:select (build-status)) #:use-module ((cuirass database) #:select (build-status))
@ -212,7 +214,7 @@ system whose names start with " (code "guile-") ":" (br)
"Add"))))) "Add")))))
'())))) '()))))
(define (build-details build) (define (build-details build products)
"Return HTML showing details for the BUILD." "Return HTML showing details for the BUILD."
(define status (assq-ref build #:status)) (define status (assq-ref build #:status))
(define blocking-outputs (define blocking-outputs
@ -282,7 +284,38 @@ system whose names start with " (code "guile-") ":" (br)
(tr (th "Outputs") (tr (th "Outputs")
(td ,(map (match-lambda ((out (#:path . path)) (td ,(map (match-lambda ((out (#:path . path))
`(pre ,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) (define (pagination first-link prev-link next-link last-link)
"Return html page navigation buttons with LINKS." "Return html page navigation buttons with LINKS."

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_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_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 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 ( CREATE TABLE Inputs (
@ -65,6 +66,16 @@ CREATE TABLE Builds (
FOREIGN KEY (evaluation) REFERENCES Evaluations (id) 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 ( CREATE TABLE Events (
id INTEGER PRIMARY KEY, id INTEGER PRIMARY KEY,
type TEXT NOT NULL, 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;

View File

@ -3,6 +3,7 @@
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
;;; ;;;
@ -45,7 +46,8 @@
(#:branch . "master") (#:branch . "master")
(#:tag . #f) (#:tag . #f)
(#:commit . #f) (#:commit . #f)
(#:no-compile? . #f)))))) (#:no-compile? . #f))))
(#:build-outputs . ())))
(define (make-dummy-checkouts fakesha1 fakesha2) (define (make-dummy-checkouts fakesha1 fakesha2)
`(((#:commit . ,fakesha1) `(((#:commit . ,fakesha1)

View File

@ -1,7 +1,7 @@
;;; http.scm -- tests for (cuirass http) module ;;; http.scm -- tests for (cuirass http) module
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@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> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; ;;;
;;; This file is part of Cuirass. ;;; This file is part of Cuirass.
@ -170,7 +170,8 @@
(#:branch . "master") (#:branch . "master")
(#:tag . #f) (#:tag . #f)
(#:commit . #f) (#:commit . #f)
(#:no-compile? . #f)))))) (#:no-compile? . #f))))
(#:build-outputs . ())))
(checkouts1 (checkouts1
'(((#:commit . "fakesha1") '(((#:commit . "fakesha1")
(#:input . "savannah") (#:input . "savannah")