cuirass: Add build products download support.

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>

 #

 # This file is part of Cuirass.

 #

   src/sql/upgrade-3.sql				\

   src/sql/upgrade-4.sql				\

   src/sql/upgrade-5.sql				\

 dist_css_DATA =					\

   src/static/css/cuirass.css			\

diff --git a/doc/cuirass.texi b/doc/cuirass.texi

index e652e8d..c6f64c9 100644

 server.

 Copyright @copyright{} 2016, 2017 Mathieu Lirzin@*

 Copyright @copyright{} 2018 Ludovic Courtès@*

 Copyright @copyright{} 2018 Clément Lassieur

                  (#:url . "git://my-custom-packages.git")

                  (#:load-path . ".")

                  (#:branch . "master")

 @end lisp

 In this specification the keys are Scheme keywords which have the nice

 @code{#:load-path-inputs}, @code{#:package-path-inputs} and

 @code{#:proc-input} refer to these inputs by their name.

 @quotation Note

 @c This refers to

 @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

 ;;; guix-jobs.scm -- job specification test for Guix

 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>

 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

                   (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")

                   (#:load-path . ".")

                   (#:branch . "master")

 (define guix-master

   (job-base #:branch "master"))

diff --git a/examples/hello-git.scm b/examples/hello-git.scm

index 6468452..c5e2ca2 100644

 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>

 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>

 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

                    (#:url . ,(string-append "file://" top-srcdir))

                    (#:load-path . ".")

                    (#:branch . "master")

diff --git a/examples/hello-singleton.scm b/examples/hello-singleton.scm

index a39191f..2d2d746 100644

 ;;; 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>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

                   (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")

                   (#:load-path . ".")

                   (#:branch . "master")

 (list hello-master)

diff --git a/examples/hello-subset.scm b/examples/hello-subset.scm

index 8c0d990..e86668e 100644

 ;;; hello-subset.scm -- job specification test for hello subset

 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>

 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

                   (#:url . "https://git.savannah.gnu.org/git/guix/guix-cuirass.git")

                   (#:load-path . ".")

                   (#:branch . "master")

 (define guix-master

   (job-base #:branch "master"))

diff --git a/examples/random.scm b/examples/random.scm

index 37b97a2..f15e158 100644

 ;;; 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>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

                    (#:url . ,(string-append "file://" top-srcdir))

                    (#:load-path . ".")

                    (#:branch . "master")

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm

index 2b18dc6..b745058 100644

 ;;; 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 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 atomic)

   #:use-module (ice-9 ftw)

   #:use-module (ice-9 threads)

       (spawn-builds store valid)

       (log-message "done with restarted builds"))))

   "Build JOBS and return a list of Build results."

   (define (register job)

     (let* ((name     (assq-ref job #:job-name))

                               outputs))

                            outputs))

          (fail (- (length derivations) success)))

     (log-message "outputs:\n~a" (string-join outs "\n"))

     (log-message "success: ~a, fail: ~a" success fail)

     results))

                  (let ((jobs (evaluate store spec eval-id checkouts)))

                    (log-message "building ~a jobs for '~a'"

                                 (length jobs) name)

           ;; '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

 ;;; database.scm -- store evaluation and build results

 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>

 ;;; 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

             build-status

             db-add-build

             db-update-build-status!

             db-get-output

             db-get-inputs

             db-get-evaluations-id-min

             db-get-evaluations-id-max

             db-get-evaluation-specification

             db-get-evaluation-summary

             db-get-checkouts

             read-sql-file

   (with-db-worker-thread db

     (sqlite-exec db "\

 INSERT OR IGNORE INTO Specifications (name, load_path_inputs, \

   VALUES ("

                  (assq-ref spec #:name) ", "

                  (assq-ref spec #:load-path-inputs) ", "

                  (assq-ref spec #:proc-input) ", "

                  (assq-ref spec #:proc-file) ", "

                  (symbol->string (assq-ref spec #:proc)) ", "

     (let ((spec-id (last-insert-rowid db)))

       (for-each (lambda (input)

                   (db-add-input (assq-ref spec #:name) input))

       (match rows

         (() specs)

         ((#(name load-path-inputs package-path-inputs proc-input proc-file proc

            . rest)

          (loop rest

                (cons `((#:name . ,name)

                        (#:proc-file . ,proc-file)

                        (#:proc . ,(with-input-from-string proc read))

                        (#:proc-args . ,(with-input-from-string proc-args read))

                      specs)))))))

 (define (db-add-evaluation spec-name checkouts)

          =>

          (sqlite-exec db "ROLLBACK;") #f))))

 (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

 SELECT specification FROM Evaluations

 WHERE id = " eval)))

       (and=> (expect-one-row rows) (cut vector-ref <> 0)))))

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm

index c5901f0..79fa246 100644

 ;;;; http.scm -- HTTP API

 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>

 ;;; 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>

         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")

        (sxml->xml body port))))

   (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) "/")))

                (file-exists? file-path)

                (not (file-is-directory? file-path)))

   (define (respond-gzipped-file file)

     ;; Return FILE with 'gzip' content-encoding.

               (#:url . "https://git.savannah.gnu.org/git/guix.git")

               (#:load-path . ".")

               (#:branch . ,name)

         (respond (build-response #:code 302

                                  #:headers `((location . ,(string->uri-reference

                                                            "/admin/specifications"))))

            (respond-json (object->json-string hydra-build))

            (respond-build-not-found id))))

     (('GET "build" build-id "details")

        (if build

            (respond-html

             (html-page (string-append "Build " build-id)

                        `(((#:name . ,(assq-ref build #:specification))

                           (#:link . ,(string-append "/jobset/" (assq-ref build #:specification)))))))

            (respond-build-not-found build-id))))

              query))

            (respond-json-with-error 500 "Query parameter not provided!"))))

     (('GET "static" path ...)

      (respond-static-file path))

     (_

diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm

index 4104c7b..600d9d8 100644

 ;;; 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>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

   #:use-module (srfi srfi-26)

   #:use-module (web uri)

   #:use-module (guix derivations)

   #:use-module (guix store)

   #:use-module ((guix utils) #:select (string-replace-substring))

   #:use-module ((cuirass database) #:select (build-status))

                             "Add")))))

            '()))))

   "Return HTML showing details for the BUILD."

   (define status (assq-ref build #:status))

   (define blocking-outputs

       (tr (th "Outputs")

           (td ,(map (match-lambda ((out (#:path . path))

                                    `(pre ,path)))

 (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

   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

 );

 CREATE TABLE Inputs (

   FOREIGN KEY (evaluation) REFERENCES Evaluations (id)

 );

 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

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>

 ;;;

 ;;; This file is part of Cuirass.

 ;;;

                   (#:branch . "master")

                   (#:tag . #f)

                   (#:commit . #f)

 (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 © 2018 Clément Lassieur <clement@lassieur.org>

 ;;;

 ;;; This file is part of Cuirass.

                             (#:branch . "master")

                             (#:tag . #f)

                             (#:commit . #f)

            (checkouts1

             '(((#:commit . "fakesha1")

                (#:input . "savannah")

-- 

2.26.0

index 79fa246..bdc780c 100644

   #:use-module (web uri)

   #:use-module (fibers)

   #:use-module (fibers channels)

   #:use-module (sxml simple)

   #:use-module (cuirass templates)

   #:use-module (guix utils)

         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")

        (sxml->xml body port))))

     (let ((content-type (or (assoc-ref %file-mime-types

                                        (file-extension file))

                             '(application/octet-stream))))

       (respond `((content-type . ,content-type)

   (define (respond-static-file path)

     ;; PATH is a list of path components

   (define (respond-gzipped-file file)

     ;; Return FILE with 'gzip' content-encoding.

     (respond `((content-type . (text/plain (charset . "UTF-8")))

   (define (respond-build-not-found build-id)

     (respond-json-with-error

     (('GET "download" id)

      (let ((path (db-get-build-product-path id)))

     (('GET "static" path ...)

      (respond-static-file path))

diff --git a/src/web/server/fiberized.scm b/src/web/server/fiberized.scm

index 308b642..68ae132 100644

   #:use-module (web request)

   #:use-module (web response)

   #:use-module (web server)

   #:use-module (ice-9 binary-ports)

   #:use-module (ice-9 match)

   #:use-module (fibers)

               ((0) (memq 'keep-alive (response-connection response)))))

            (else #f)))))

 (define (client-loop client have-request)

   ;; Always disable Nagle's algorithm, as we handle buffering

   ;; ourselves.

                                               #:headers '((content-length . 0)))

                               #vu8()))))

               (lambda (response body)

                 (when body

                 (force-output client)

                 (if (and (keep-alive? response)

                          (not (eof-object? (peek-char client))))

-- 

2.26.0

index 79fa246..0b2f056 100644

         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")

        (sxml->xml body port))))

     (let ((content-type (or (assoc-ref %file-mime-types

                                        (file-extension file))

                             '(application/octet-stream))))

       (respond `((content-type . ,content-type)

   (define (respond-static-file path)

     ;; PATH is a list of path components

   (define (respond-gzipped-file file)

     ;; Return FILE with 'gzip' content-encoding.

     (respond `((content-type . (text/plain (charset . "UTF-8")))

   (define (respond-build-not-found build-id)

     (respond-json-with-error

     (('GET "download" id)

      (let ((path (db-get-build-product-path id)))

     (('GET "static" path ...)

      (respond-static-file path))

diff --git a/src/web/server/fiberized.scm b/src/web/server/fiberized.scm

index 308b642..7769202 100644

 ;;; Code:

 (define-module (web server fiberized)

   #:use-module (srfi srfi-9)

   #:use-module (web http)

   #:use-module (web request)

   #:use-module (web response)

   #:use-module (ice-9 match)

   #:use-module (fibers)

   #:use-module (fibers channels)

 (define (make-default-socket family addr port)

   (let ((sock (socket PF_INET SOCK_STREAM 0)))

               ((0) (memq 'keep-alive (response-connection response)))))

            (else #f)))))

 (define (client-loop client have-request)

   ;; Always disable Nagle's algorithm, as we handle buffering

   ;; ourselves.

                                               #:headers '((content-length . 0)))

                               #vu8()))))

               (lambda (response body)

     (lambda (k . args)

       (catch #t

         (lambda () (close-port client))

-- 

2.26.2