From patchwork Fri May 1 08:54:56 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mathieu Othacehe X-Patchwork-Id: 21783 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 6F04D27BBE4; Fri, 1 May 2020 09:56:14 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI,T_DKIM_INVALID, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [IPv6:2001:470:142::17]) by mira.cbaines.net (Postfix) with ESMTP id 181D227BBE1 for ; Fri, 1 May 2020 09:56:13 +0100 (BST) Received: from localhost ([::1]:55378 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jURSu-0003W9-MC for patchwork@mira.cbaines.net; Fri, 01 May 2020 04:56:12 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:37232) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jURSm-0003Vn-J3 for guix-patches@gnu.org; Fri, 01 May 2020 04:56:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.90_1) (envelope-from ) id 1jURSk-0004cj-SN for guix-patches@gnu.org; Fri, 01 May 2020 04:56:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:36669) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jURSk-0004bb-AJ for guix-patches@gnu.org; Fri, 01 May 2020 04:56:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jURSk-0006Oz-9D for guix-patches@gnu.org; Fri, 01 May 2020 04:56:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#40993] cuirass: Add build products download support. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 01 May 2020 08:56:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 40993 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 40993@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.158832331524552 (code B ref -1); Fri, 01 May 2020 08:56:02 +0000 Received: (at submit) by debbugs.gnu.org; 1 May 2020 08:55:15 +0000 Received: from localhost ([127.0.0.1]:48215 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jURRy-0006Nv-Kt for submit@debbugs.gnu.org; Fri, 01 May 2020 04:55:15 -0400 Received: from lists.gnu.org ([209.51.188.17]:60388) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jURRq-0006Ne-02 for submit@debbugs.gnu.org; Fri, 01 May 2020 04:55:13 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:35908) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jURRo-00026Q-0a for guix-patches@gnu.org; Fri, 01 May 2020 04:55:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.90_1) (envelope-from ) id 1jURRl-0001BZ-QA for guix-patches@gnu.org; Fri, 01 May 2020 04:55:03 -0400 Received: from mail-wm1-x334.google.com ([2a00:1450:4864:20::334]:36544) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jURRl-000168-1p for guix-patches@gnu.org; Fri, 01 May 2020 04:55:01 -0400 Received: by mail-wm1-x334.google.com with SMTP id u127so5650411wmg.1 for ; Fri, 01 May 2020 01:55:00 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:subject:date:message-id:user-agent:mime-version; bh=7l/8d6KFGZo/1ZEcIVOE8teBEyXqCJdsnTaVz65BbGE=; b=ZWaaicVV33Xn9R3U036aVrFXeLWy3U6S4d7B/SP1B++xgciSTeVq+O/KlK/Hguscnp J0I2+P6kankMaR6qMN6zVOePadr4fRnNJz64Q8CG++8Yjz2hLAsfvz3PIw+ePIXEJefx o/7ZpgqeRKhgM7mTHpOwnZewcLswRTel6CoHG1N76XE3+k2/we7GQfqqnH7yz2afqHpm uWgSRw+oLvH1dCozxYm79gUTYCunAwAr0fiYsUTsQkI1DcoOfhtIgTOtD1buAH9VKHNx g0Qb9x5Q8mlJ5U5aJplM1BBT8CjfXZO5QshX1pxDavKKv0isLyVICvZ9DmdUnA3j8AM8 lSBA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:subject:date:message-id:user-agent :mime-version; bh=7l/8d6KFGZo/1ZEcIVOE8teBEyXqCJdsnTaVz65BbGE=; b=t9/9nDLSrzmVnlOq9S3r/KkauvNSYpf9bVOjEB4+jAcgpmANNVHgTKIG20MWUBGDSY e+/7IE8enPMOxe/HbQt5y023fdjHd+Txpo2n/D5Q6jQ2NDnpfG3pnaXInKgyn1nUGW+K a+dSMMSoCsW6OxPd4V5TNBl2FWicgA7Rue+5iDHkFORxwLemxR9eAXjzgWvWNHA9TjaG R3aMIbS2YnwLzv0L0qAew96EO1F8vzyVkkDv7uVxdFLz5I893lBPnCkYvWI2i9RBimjc ijLUT5HuKCLcga9XEvxpjg+dtIG3txVS+mP+4NXw50S+eaWpnzkypI0o7BLb5r7Fy0+N Rhvg== X-Gm-Message-State: AGi0PuaF+IFJbw0ck4+orUBoWPrz+HyXFDI6T3ymcE9wKOlFfjyXM70R TI9r4TP3/VYnmleFpABWV4Z3Fo/0 X-Google-Smtp-Source: APiQypIdcFyipHgRlp11pBfXwF2BPrigjYRhJfHKfYNm2e/mlDjRGep533qiFcHOB5unXCIEFlXq1w== X-Received: by 2002:a1c:5502:: with SMTP id j2mr3193629wmb.56.1588323298607; Fri, 01 May 2020 01:54:58 -0700 (PDT) Received: from meru ([2a01:cb18:832e:5f00:2134:99dd:8794:8d1e]) by smtp.gmail.com with ESMTPSA id w18sm3255838wrn.55.2020.05.01.01.54.56 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 01 May 2020 01:54:57 -0700 (PDT) From: Mathieu Othacehe Date: Fri, 01 May 2020 10:54:56 +0200 Message-ID: <87ees4uja7.fsf@gmail.com> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.3 (gnu/linux) MIME-Version: 1.0 Received-SPF: pass client-ip=2a00:1450:4864:20::334; envelope-from=m.othacehe@gmail.com; helo=mail-wm1-x334.google.com X-detected-operating-system: by eggs.gnu.org: Error: [-] PROGRAM ABORT : Malformed IPv6 address (bad octet value). Location : parse_addr6(), p0f-client.c:67 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches Hello, Here's a patch adding support for build products downloading in Cuirass. It is inspired by a similar mechanism in Hydra. Attached a screenshot of what I obtained with the following specification: --8<---------------cut here---------------start------------->8--- (define hello-master '((#:name . "guix-master") (#:load-path-inputs . ()) (#:package-path-inputs . ()) (#:proc-input . "guix") (#:proc-file . "build-aux/cuirass/gnu-system.scm") (#:proc . cuirass-jobs) (#:proc-args (subset . "all")) (#:inputs . (((#:name . "guix") (#:url . "https://gitlab.com/mothacehe/guix") (#:load-path . ".") (#:branch . "master") (#:no-compile? . #t)))) (#:build-outputs . (((#:job . "iso9660-image*") (#:type . "iso") (#:output . "out") (#:path . "")))))) (list hello-master) --8<---------------cut here---------------end--------------->8--- Thanks, Mathieu From dbb78929d7c8aa3b9007660795f55232ab47dbfb Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 1 May 2020 10:32:18 +0200 Subject: [PATCH] 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/" route, serving the requested file with the new respond-file procedure. Also gather build products and pass them to "build-details" for "build//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. --- Makefile.am | 4 ++- doc/cuirass.texi | 14 +++++++-- examples/guix-jobs.scm | 4 ++- examples/hello-git.scm | 4 ++- examples/hello-singleton.scm | 4 ++- examples/hello-subset.scm | 4 ++- examples/random.scm | 4 ++- src/cuirass/base.scm | 44 ++++++++++++++++++++++++++-- src/cuirass/database.scm | 57 ++++++++++++++++++++++++++++++++---- src/cuirass/http.scm | 36 +++++++++++++++++------ src/cuirass/templates.scm | 37 +++++++++++++++++++++-- src/schema.sql | 13 +++++++- src/sql/upgrade-7.sql | 15 ++++++++++ tests/database.scm | 4 ++- tests/http.scm | 5 ++-- 15 files changed, 218 insertions(+), 31 deletions(-) create mode 100644 src/sql/upgrade-7.sql diff --git a/Makefile.am b/Makefile.am index 65c9a29..f4a3663 100644 --- a/Makefile.am +++ b/Makefile.am @@ -5,6 +5,7 @@ # Copyright © 2018 Ludovic Courtès # Copyright © 2018 Clément Lassieur # Copyright © 2018 Tatiana Sholokhova +# Copyright © 2020 Mathieu Othacehe # # 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 \ diff --git a/doc/cuirass.texi b/doc/cuirass.texi index e652e8d..c6f64c9 100644 --- a/doc/cuirass.texi +++ b/doc/cuirass.texi @@ -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 . 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 @@ -1,6 +1,7 @@ ;;; guix-jobs.scm -- job specification test for Guix ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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")) 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 @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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 . ())))) 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 @@ -1,6 +1,7 @@ ;;; hello-singleton.scm -- job specification test for hello in master ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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) 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 @@ -1,6 +1,7 @@ ;;; hello-subset.scm -- job specification test for hello subset ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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")) diff --git a/examples/random.scm b/examples/random.scm index 37b97a2..f15e158 100644 --- a/examples/random.scm +++ b/examples/random.scm @@ -1,6 +1,7 @@ ;;; random.scm -- Job specification that creates random build jobs ;;; Copyright © 2018 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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 . ())))) 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 @@ -1,7 +1,7 @@ ;;; base.scm -- Cuirass base module ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016, 2017 Mathieu Lirzin -;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018 Clément Lassieur ;;; @@ -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))) + + (map (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. + (#:sha256-hash . "") + (#: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*)))) 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 @@ -1,6 +1,6 @@ ;;; database.scm -- store evaluation and build results ;;; Copyright © 2016, 2017 Mathieu Lirzin -;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018, 2020 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; Copyright © 2018 Tatiana Sholokhova @@ -47,6 +47,7 @@ db-get-pending-derivations build-status db-add-build + db-add-build-product db-update-build-status! db-get-output db-get-inputs @@ -65,6 +66,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 @@ -334,7 +337,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) ", " @@ -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 ";") (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) @@ -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)) + (#:build-outputs . + ,(with-input-from-string build-outputs read))) specs))))))) (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 + (sqlite-exec db "\ +INSERT INTO BuildProducts (build, type, file_size, sha256_hash, +path) VALUES (" + (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 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, sha256_hash, path from BuildProducts +WHERE build = " build-id)) + (products '())) + (match rows + (() (reverse products)) + ((#(id type file-size sha256-hash path) + . rest) + (loop rest + (cons `((#:id . ,id) + (#:type . ,type) + (#:file-size . ,file-size) + (#:sha256-hash . ,sha256-hash) + (#:path . ,path)) + products))))))) 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 @@ -1,6 +1,6 @@ ;;;; http.scm -- HTTP API ;;; Copyright © 2016 Mathieu Lirzin -;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; Copyright © 2018 Tatiana Sholokhova @@ -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)) (_ 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 @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Tatiana Sholokhova ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2019, 2020 Ricardo Wurmus +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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." diff --git a/src/schema.sql b/src/schema.sql index 1104551..3838f75 100644 --- a/src/schema.sql +++ b/src/schema.sql @@ -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, + sha256_hash 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, diff --git a/src/sql/upgrade-7.sql b/src/sql/upgrade-7.sql new file mode 100644 index 0000000..02e9c41 --- /dev/null +++ b/src/sql/upgrade-7.sql @@ -0,0 +1,15 @@ +BEGIN TRANSACTION; + +CREATE TABLE BuildProducts ( + build INTEGER NOT NULL, + type TEXT NOT NULL, + file_size BIGINT NOT NULL, + sha256_hash 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; diff --git a/tests/database.scm b/tests/database.scm index 6098465..98b5012 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2018 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; 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) diff --git a/tests/http.scm b/tests/http.scm index d20a3c3..d69c25c 100644 --- a/tests/http.scm +++ b/tests/http.scm @@ -1,7 +1,7 @@ ;;; http.scm -- tests for (cuirass http) module ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès -;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018 Clément Lassieur ;;; ;;; 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") -- 2.26.0