diff mbox

using Cuirass to track a guix packages' git

Message ID 87fup0rqwz.fsf@gnu.org
State New
Headers show

Commit Message

Jan Nieuwenhuizen Sept. 15, 2016, 10:10 p.m. UTC
Hi!

I have been playing with Cuirass and I like it a lot!

Next to replacing Hydra for GuixSD, there is another use case that I'd
like Cuirass to support: tracking an (any) upstream packages' git.

When the target of your continuous integration is not Guix itself but
some specific package, you may well want to allow usage of substitutes
(patch 1).

Assuming you have checked-out guix and cuirass in ~/src/guix and
~/src/cuirass, doing

   ./pre-inst-env cuirass --use-substitutes --specifications=tests/hello-git.scm

will monitor any changes to Cuirass' git repository and rebuild the
latest commit of the Cuirass package using Guix (patch 2 and 3).

Of course, a build a failure should not crash cuirass and also be
noted/stamped, not repeated every heartbeat (patch 4).

I had some trouble with the #:no-compile? option, it's currently
specified twice.  On the Cuirass side I think it should be a property
of the spec, but it seems it gets only passed as part of the
arguments.  Ideas?

Thank you!
Greetings,
Jan

Comments

Mathieu Lirzin Sept. 20, 2016, 7:49 p.m. UTC | #1
Hello Jan,

Jan Nieuwenhuizen <janneke@gnu.org> writes:

> I have been playing with Cuirass and I like it a lot!

Cool. :)

I want to let you know that I have just started looking at your patches.
I have been quite busy lately.  Sorry for the latency.

Next time I will let you know sooner if you should expect a delay.

> Next to replacing Hydra for GuixSD, there is another use case that I'd
> like Cuirass to support: tracking an (any) upstream packages' git.

This is highly desirable indeed.

> When the target of your continuous integration is not Guix itself but
> some specific package, you may well want to allow usage of substitutes
> (patch 1).

Agreed.

> Assuming you have checked-out guix and cuirass in ~/src/guix and
> ~/src/cuirass, doing
>
>    ./pre-inst-env cuirass --use-substitutes --specifications=tests/hello-git.scm
>
> will monitor any changes to Cuirass' git repository and rebuild the
> latest commit of the Cuirass package using Guix (patch 2 and 3).
>
> Of course, a build a failure should not crash cuirass and also be
> noted/stamped, not repeated every heartbeat (patch 4).

yes :)

> I had some trouble with the #:no-compile? option, it's currently
> specified twice.  On the Cuirass side I think it should be a property
> of the spec, but it seems it gets only passed as part of the
> arguments.  Ideas?

No idea for now.  I will comment/review your code in details in a
following mail.  I should be able to do that in the next 48H.

Thank you for your patches, patience and courage!
Mathieu Lirzin Sept. 22, 2016, 10:03 p.m. UTC | #2
Hello Jan,

Jan Nieuwenhuizen <janneke@gnu.org> writes:

> I had some trouble with the #:no-compile? option, it's currently
> specified twice.  On the Cuirass side I think it should be a property
> of the spec, but it seems it gets only passed as part of the
> arguments.  Ideas?

OK, I think I got it.  With the idea to move to a client/server
architecture in the future, Cuirass uses the database to keep track of
the specifications (in a weird way).  When new specifications are added
with --specifications, they are first put in the database before being
fetched back with the previously added ones.  As a consequence if a key
in the specification is not handle when adding the spec to the database
in 'db-add-specification' procedure, then it will be ignored.

Does it make sense?

If yes, then I guess that patch 2 and 3 can easily be adapted to use
only '#:no-compile?' as a property.

> From a26857176da63b36ec446654c79528a02fa4a3d1 Mon Sep 17 00:00:00 2001
> From: Jan Nieuwenhuizen <janneke@gnu.org>
> Date: Thu, 15 Sep 2016 22:50:42 +0200
> Subject: [PATCH 1/4] cuirass: optionally support using of substitutes.
>
> bin/cuirass.in (options): Add --use-substitutes.
> (show-help): Idem.
> (main): Set %use-substitutes?.
> ---
>  bin/cuirass.in       |  5 ++++-
>  bin/evaluate.in      |  8 +++++---
>  src/cuirass/base.scm | 10 ++++++++--
>  3 files changed, 17 insertions(+), 6 deletions(-)
>
> diff --git a/bin/cuirass.in b/bin/cuirass.in
> index 553a5d0..88813b8 100644
> --- a/bin/cuirass.in
> +++ b/bin/cuirass.in
> @@ -35,6 +35,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
>                              Add specifications from SPECFILE to database.
>    -D  --database=DB         Use DB to store build results.
>    -I, --interval=N          Wait N seconds between each poll
> +      --use-substitutes     Allow usage of pre-built substitutes
>    -V, --version             Display version
>    -h, --help                Display this help message")
>    (newline)
> @@ -46,6 +47,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
>      (specifications (single-char #\S) (value #t))
>      (database       (single-char #\D) (value #t))
>      (interval       (single-char #\I) (value #t))
> +    (use-substitutes                  (value #f))
>      (version        (single-char #\V) (value #f))
>      (help           (single-char #\h) (value #f))))
>  
> @@ -60,7 +62,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
>          ((%program-name     (car args))
>           (%package-database (option-ref opts 'database (%package-database)))
>           (%package-cachedir
> -          (option-ref opts 'cache-directory (%package-cachedir))))
> +          (option-ref opts 'cache-directory (%package-cachedir)))
> +         (%use-substitutes? (option-ref opts 'use-substitutes #f)))
>        (cond
>         ((option-ref opts 'help #f)
>          (show-help)
> diff --git a/bin/evaluate.in b/bin/evaluate.in
> index f0542ce..767e15e 100644
> --- a/bin/evaluate.in
> +++ b/bin/evaluate.in
> @@ -44,8 +44,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
>                (string-append cachedir "/" (assq-ref spec #:name))
>              (primitive-load (assq-ref spec #:file)))))
>         (with-store store
> -         ;; Make sure we don't resort to substitutes.
> -         (set-build-options store #:use-substitutes? #f #:substitute-urls '())
> +         (unless (assoc-ref spec #:use-substitutes?)
> +           ;; Make sure we don't resort to substitutes.
> +           (set-build-options store #:use-substitutes? #f #:substitute-urls '()))
>           ;; Grafts can trigger early builds.  We do not want that to happen
>           ;; during evaluation, so use a sledgehammer to catch such problems.
>           (set! build-things
> @@ -54,7 +55,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
>                            stderr)
>                   (simple-format stderr "'build-things' arguments: ~S~%" args)
>                   (exit 1)))
> -         (parameterize ((%package-database database))
> +         (parameterize ((%package-database database)
> +                        (%use-substitutes? (assoc-ref spec #:use-substitutes?)))
>             ;; Call the entry point of FILE and print the resulting job sexp.
>             (let* ((proc    (module-ref %user-module 'hydra-jobs))
>                    (thunks  (proc store (assq-ref spec #:arguments)))
> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
> index 52e0d00..8ad6af4 100644
> --- a/src/cuirass/base.scm
> +++ b/src/cuirass/base.scm
> @@ -34,7 +34,12 @@
>              build-packages
>              process-specs
>              ;; Parameters.
> -            %package-cachedir))
> +            %package-cachedir
> +            %use-substitutes?))
> +
> +(define %use-substitutes?
> +  ;; Define whether to use substitutes
> +  (make-parameter #f))
>  
>  (define %package-cachedir
>    ;; Define to location of cache directory of this package.
> @@ -149,7 +154,8 @@ if required."
>                    (with-store store
>                      (let* ((spec* (acons #:current-commit commit spec))
>                             (jobs  (evaluate store db spec*)))
> -                      (set-build-options store #:use-substitutes? #f)
> +                      (unless (%use-substitutes?)
> +                        (set-build-options store #:use-substitutes? #f))
>                        (build-packages store db jobs))))
>                  (db-add-stamp db spec commit)))
>              jobspecs))
> -- 
> 2.10.0

OK.

> From c7af2c3459135577a5e1565ec780854959035f5f Mon Sep 17 00:00:00 2001
> From: Jan Nieuwenhuizen <janneke@gnu.org>
> Date: Thu, 15 Sep 2016 23:15:54 +0200
> Subject: [PATCH 2/4] cuirass: support tracking of a guix package's git.
>
> * src/cuirass/base.scm (process-specs): Skip compilation if #:no-compile?.
> ---
>  src/cuirass/base.scm | 9 ++++++---
>  1 file changed, 6 insertions(+), 3 deletions(-)
>
> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
> index 8ad6af4..e040f71 100644
> --- a/src/cuirass/base.scm
> +++ b/src/cuirass/base.scm
> @@ -147,10 +147,13 @@ if required."
>    "Evaluate and build JOBSPECS and store results in DB."
>    (for-each (λ (spec)
>                (let ((commit (fetch-repository spec))
> -                    (stamp  (db-get-stamp db spec)))
> +                    (stamp  (db-get-stamp db spec))
> +                    (arguments (assq-ref spec #:arguments)))
>                  (unless (string=? commit stamp)
> -                  (compile (string-append (%package-cachedir) "/"
> -                                          (assq-ref spec #:name)))
> +                  (when (and (not (assq-ref spec #:no-compile?))
> +                             (not (assq-ref arguments 'no-compile?)))
> +                    (compile (string-append (%package-cachedir) "/"
> +                                            (assq-ref spec #:name))))
>                    (with-store store
>                      (let* ((spec* (acons #:current-commit commit spec))
>                             (jobs  (evaluate store db spec*)))
> -- 
> 2.10.0

OK with the #no-compile? fix described above.

>
> From 5595b346fd82c619035d2ce202064f37bc47dbe6 Mon Sep 17 00:00:00 2001
> From: Jan Nieuwenhuizen <janneke@gnu.org>
> Date: Wed, 14 Sep 2016 23:14:57 +0200
> Subject: [PATCH 3/4] tests: track cuirass' git.
>
> * guix/ci.scm: New file.
> * build-aux/pre-inst-env.in: Add it to GUIX_PACKAGE_PATH.
> * bin/evaluate.in (main): Lookup proc using name specified by #:proc.
> * tests/guix-track-git.scm: New file.
> * tests/hello-git.scm: Test it.
> ---
>  bin/evaluate.in           |   3 +-
>  build-aux/pre-inst-env.in |   3 +
>  guix/ci.scm               |  65 ++++++++++++++
>  tests/guix-track-git.scm  | 225 ++++++++++++++++++++++++++++++++++++++++++++++
>  tests/hello-git.scm       |  53 +++++++++++
>  5 files changed, 348 insertions(+), 1 deletion(-)
>  create mode 100644 guix/ci.scm
>  create mode 100644 tests/guix-track-git.scm
>  create mode 100644 tests/hello-git.scm
>
> diff --git a/bin/evaluate.in b/bin/evaluate.in
> index 767e15e..872d0b0 100644
> --- a/bin/evaluate.in
> +++ b/bin/evaluate.in
> @@ -58,7 +58,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
>           (parameterize ((%package-database database)
>                          (%use-substitutes? (assoc-ref spec #:use-substitutes?)))
>             ;; Call the entry point of FILE and print the resulting job sexp.
> -           (let* ((proc    (module-ref %user-module 'hydra-jobs))
> +           (let* ((proc-name (assq-ref spec #:proc))
> +                  (proc    (module-ref %user-module proc-name))
>                    (thunks  (proc store (assq-ref spec #:arguments)))
>                    (db      (db-open))
>                    (commit  (assq-ref spec #:current-commit))
> diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in
> index e8d9487..b67dc5e 100644
> --- a/build-aux/pre-inst-env.in
> +++ b/build-aux/pre-inst-env.in
> @@ -30,4 +30,7 @@ export CUIRASS_DATADIR
>  PATH="$abs_top_builddir/bin:$PATH"
>  export PATH
>  
> +GUIX_PACKAGE_PATH="guix${GUIX_PACKAGE_PATH:+:}$GUIX_PACKAGE_PATH"
> +export GUIX_PACKAGE_PATH
> +
>  exec "$@"
> diff --git a/guix/ci.scm b/guix/ci.scm
> new file mode 100644
> index 0000000..0eb886a
> --- /dev/null
> +++ b/guix/ci.scm
> @@ -0,0 +1,65 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
> +;;;
> +;;; This file is part of GNU Guix.
> +;;;
> +;;; GNU Guix is free software; you can redistribute it and/or modify it
> +;;; under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation; either version 3 of the License, or (at
> +;;; your option) any later version.
> +;;;
> +;;; GNU Guix is distributed in the hope that it will be useful, but
> +;;; WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
> +
> +(define-module (ci)
> +  #:use-module ((guix licenses) #:prefix l:)
> +  #:use-module (gnu packages)
> +  #:use-module (guix packages)
> +  #:use-module (guix git-download)
> +  #:use-module (gnu packages autotools)
> +  #:use-module (gnu packages base)
> +  #:use-module (gnu packages databases)
> +  #:use-module (gnu packages guile)
> +  #:use-module (gnu packages package-management)
> +  #:use-module (gnu packages pkg-config)
> +  #:use-module (guix build-system gnu))
> +
> +(define-public cuirass-git
> +  (package
> +    (name "cuirass-git")
> +    (version "0.0")
> +    (source (origin
> +              (method git-fetch)
> +              (uri (git-reference
> +                    (url "https://notabug.org/mthl/cuirass")
> +                    (commit "master")))
> +              (sha256
> +               (base32
> +                "1jw3smw6axqr58ahkyjncygv0nk3hdrqkv0hm4awwj0hg5nl3d2p"))))
> +    (build-system gnu-build-system)
> +    (arguments
> +     `(#:phases
> +        (modify-phases %standard-phases
> +          (add-after 'unpack 'bootstrap
> +            (lambda _ (zero? (system* "sh" "bootstrap")))))))
> +    (native-inputs
> +     `(("autoconf" ,autoconf)
> +       ("automake" ,automake)
> +       ("guile" ,guile-2.0)
> +       ("guile-json" ,guile-json)
> +       ("guile-sqlite3" ,guile-sqlite3)       
> +       ("guix" ,guix)
> +       ("pkg-config" ,pkg-config)
> +       ("sqlite" ,sqlite)))
> +    (synopsis "Continuous integration system")
> +    (description
> +     "Cuirass is a continuous integration system which uses GNU Guix.  It is
> +intended as replacement for Hydra.")
> +    (home-page "https://notabug.org/mthl/cuirass")
> +    (license l:gpl3+)))
> +

Since this is a package definition of Cuirass, would it make sense to
rename it to "guix.scm" recommended in Guix manual?  Is the (ci) module
definition required?

> diff --git a/tests/guix-track-git.scm b/tests/guix-track-git.scm
> new file mode 100644
> index 0000000..15fd575
> --- /dev/null
> +++ b/tests/guix-track-git.scm
> @@ -0,0 +1,225 @@
> +;;; guix-track-git.scm -- job specification tracking a guix packages's git
> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
> +;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
> +;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
> +;;;
> +;;; This file is part of Cuirass.
> +;;;
> +;;; GNU Guix is free software; you can redistribute it and/or modify it
> +;;; under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation; either version 3 of the License, or (at
> +;;; your option) any later version.
> +;;;
> +;;; GNU Guix is distributed in the hope that it will be useful, but
> +;;; WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
> +
> +;;;
> +;;; This file defines build jobs for the Hydra continuation integration
> +;;; tool.
> +;;;
> +
> +(define local-guix (string-append (getenv "HOME") "/src/guix"))
> +(define local-cuirass (string-append (getenv "HOME") "/src/cuirass/src"))
> +
> +;; Attempt to use our very own Guix modules.
> +(eval-when (compile load eval)
> +
> +  (set! %load-path (cons* local-guix local-cuirass %load-path))
> +  (set! %load-path (cons (string-append local-cuirass "/gnu/packages/patches") %load-path))
> +  (set! %load-compiled-path (cons local-guix %load-compiled-path))
> +  (set! %load-compiled-path (cons local-cuirass %load-compiled-path))
> +  
> +  ;; Ignore any available .go, and force recompilation.  This is because our
> +  ;; checkout in the store has mtime set to the epoch, and thus .go files look
> +  ;; newer, even though they may not correspond.
> +  (set! %fresh-auto-compile #t))
> +
> +(use-modules (guix config)
> +             (guix store)
> +             (guix grafts)
> +             (guix packages)
> +             (guix derivations)
> +             (guix monads)
> +             ((guix licenses)
> +              #:select (gpl3+ license-name license-uri license-comment))
> +             ((guix utils) #:select (%current-system))
> +             ((guix scripts system) #:select (read-operating-system))
> +             (gnu packages)
> +             (gnu packages gcc)
> +             (gnu packages base)
> +             (gnu packages gawk)
> +             (gnu packages guile)
> +             (gnu packages gettext)
> +             (gnu packages compression)
> +             (gnu packages multiprecision)
> +             (gnu packages make-bootstrap)
> +             (gnu packages commencement)
> +             (gnu packages package-management)
> +             (gnu system)
> +             (gnu system vm)
> +             (gnu system install)
> +             (gnu tests)
> +             (srfi srfi-1)
> +             (srfi srfi-26)
> +             (ice-9 optargs)
> +             (ice-9 match))
> +
> +(use-modules (gnu packages dezyne)
> +             (gnu system development-verum)
> +             (guix dezyne-dev))
> +
> +;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
> +;; port to the bit bucket, let us write to the error port instead.
> +(setvbuf (current-error-port) _IOLBF)
> +(set-current-output-port (current-error-port))
> +
> +(define (license->alist lcs)
> +  "Return LCS <license> object as an alist."
> +  ;; Sometimes 'license' field is a list of licenses.
> +  (if (list? lcs)
> +      (map license->alist lcs)
> +      `((name . ,(license-name lcs))
> +        (uri . ,(license-uri lcs))
> +        (comment . ,(license-comment lcs)))))
> +
> +(define (package-metadata package)
> +  "Convert PACKAGE to an alist suitable for Hydra."
> +  `((#:description . ,(package-synopsis package))
> +    (#:long-description . ,(package-description package))
> +    (#:license . ,(license->alist (package-license package)))
> +    (#:home-page . ,(package-home-page package))
> +    (#:maintainers . ("bug-guix@gnu.org"))
> +    (#:max-silent-time . ,(or (assoc-ref (package-properties package)
> +                                         'max-silent-time)
> +                              3600))      ;1 hour by default
> +    (#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
> +                      72000))))           ;20 hours by default
> +
> +(define (package-job store job-name package system)
> +  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
> +  (λ ()
> +    `((#:job-name . ,(string-append (symbol->string job-name) "." system))
> +      (#:derivation . ,(derivation-file-name
> +                        (parameterize ((%graft? #f))
> +                          (package-derivation store package system
> +                                              #:graft? #f))))
> +      ,@(package-metadata package))))
> +
> +(define job-name
> +  ;; Return the name of a package's job.
> +  (compose string->symbol package-full-name))
> +
> +(define package->job
> +  (let ((base-packages
> +         (delete-duplicates
> +          (append-map (match-lambda
> +                       ((_ package _ ...)
> +                        (match (package-transitive-inputs package)
> +                          (((_ inputs _ ...) ...)
> +                           inputs))))
> +                      %final-inputs))))
> +    (lambda (store package system)
> +      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
> +valid."
> +      (cond ((member package base-packages)
> +             #f)
> +            ((supported-package? package system)
> +             (package-job store (job-name package) package system))
> +            (else
> +             #f)))))
> +
> +;;; END hydra/gnu-system.scm
> +
> +
> +;;;
> +;;; Cuirass CI tracking packages' git
> +;;;
> +
> +(use-modules (srfi srfi-11)
> +             (srfi srfi-9 gnu)
> +             (rnrs io ports)
> +             (gnu packages)
> +             (guix base32)
> +             (guix git-download)
> +             (guix hash)
> +             (guix packages)
> +             (guix serialization)
> +             (guix utils)
> +             (guix ui)
> +             (cuirass base))
> +
> +(define (url->file-name url)
> +  (string-trim
> +   (string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
> +    #\-))
> +
> +(define* (package->spec pkg #:key (branch "master") commit url)
> +  (let ((url (or url ((compose git-reference-url origin-uri package-source) pkg))))
> +    `((#:name . ,(url->file-name url))
> +      (#:url . ,url)
> +      (#:branch . ,branch)
> +      (#:commit . ,commit))))
> +
> +(define (vcs-file? file stat)
> +  (case (stat:type stat)
> +    ((directory)
> +     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
> +    (else
> +     #f)))
> +
> +(define select? (negate vcs-file?))
> +
> +(define (file-hash file)
> +  ;; Compute the hash of FILE.
> +  ;; Catch and gracefully report possible '&nar-error' conditions.
> +  (with-error-handling
> +    (let-values (((port get-hash) (open-sha256-port)))
> +      (write-file file port #:select? select?)
> +      (flush-output-port port)
> +      (get-hash))))      
> +
> +(define (commit? string)
> +  (string-every (string->char-set "0123456789abcdef") string))
> +
> +(define (call-with-output-fdes fdes new-file thunk)
> +  (let ((outport (fdes->outport fdes))
> +        (port (open-file new-file "w")))
> +    (move->fdes port fdes)
> +    (let ((result (thunk)))
> +      (move->fdes port fdes)
> +      result)))
> +
> +(define* (package->git-tracked pkg #:key (branch "master") commit url)
> +  (let* ((source (package-source pkg))
> +         (uri (origin-uri source)))
> +    (if (not branch) pkg
> +        (let* ((spec (package->spec pkg #:branch branch #:commit commit #:url url))
> +               (commit (call-with-output-fdes 1 "/dev/null"
> +                                              (lambda () (fetch-repository spec))))
> +               (url (or url (git-reference-url uri)))
> +               (git-dir (string-append (%package-cachedir) "/" (url->file-name url)))
> +               (hash (bytevector->nix-base32-string (file-hash git-dir)))
> +               (source (origin (uri (git-reference (url url) (commit commit)))
> +                              (method git-fetch)
> +                              (sha256 (base32 hash)))))
> +          (set-fields pkg ((package-source) source))))))
> +
> +
> +;;;
> +;;; Guix entry point.
> +;;;
> +
> +(define (guix-jobs store arguments)
> +  (let* ((name (or (assoc-ref arguments 'name) "hello"))
> +         (pkg (specification->package name))
> +         (branch (or (assoc-ref arguments 'branch) "master"))
> +         (url (assoc-ref arguments 'url))
> +         (pkg.git (package->git-tracked pkg #:branch branch #:url url))
> +         (system (or (assoc-ref arguments 'system) "x86_64-linux")))
> +    (parameterize ((%graft? #f))
> +      (list (package-job store (job-name pkg) pkg.git system)))))
> diff --git a/tests/hello-git.scm b/tests/hello-git.scm
> new file mode 100644
> index 0000000..dc68782
> --- /dev/null
> +++ b/tests/hello-git.scm
> @@ -0,0 +1,53 @@
> +;;; hello-singleton.scm -- job specification test for hello in master
> +;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
> +;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
> +;;;
> +;;; This file is part of Cuirass.
> +;;;
> +;;; Cuirass is free software: you can redistribute it and/or modify
> +;;; it under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation, either version 3 of the License, or
> +;;; (at your option) any later version.
> +;;;
> +;;; Cuirass is distributed in the hope that it will be useful,
> +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
> +
> +(use-modules (srfi srfi-1))
> +
> +(define (local-file file)
> +  ;; In the common case jobs will be defined relative to the repository.
> +  ;; However for testing purpose use local gnu-system.scm instead.
> +  (string-append (dirname (current-filename)) "/" file))
> +
> +(define (url->file-name url)
> +  (string-trim
> +   (string-map (lambda (c) (if (memq c (string->list ":/")) #\- c)) url)
> +   #\-))
> +
> +(define vc
> +  ;; where your version-control checkouts live
> +  (string-append (getenv "HOME") "/src"))
> +(define guix-checkout (string-append vc "/guix"))
> +
> +;; building GNU hello from git is too much work
> +;; (define hello-checkout (string-append vc "/hello"))
> +;; (define hello-git "http://git.savannah.gnu.org/r/hello.git")
> +;; ... so let's track cuirass' git
> +(define cuirass-checkout (string-append vc "/cuirass"))
> +(define cuirass-git "https://notabug.org/mthl/cuirass")
> +;;(define cuirass-git "https://gitlab.com/janneke/cuirass.git")
> +
> +(list
> + `((#:name . ,(url->file-name cuirass-checkout))
> +   (#:url . ,cuirass-git)
> +   (#:branch . "master")
> +   (#:no-compile? . #t)
> +   (#:load-path . ,guix-checkout)
> +   (#:proc . guix-jobs)
> +   (#:file . ,(local-file "guix-track-git.scm"))
> +   (#:arguments (name . "cuirass-git") (no-compile? . #t) (url . ,cuirass-git))))
> -- 
> 2.10.0

OK with the #no-compile? fix described above.

> From 67c3e529a811705c69047380414ba4687544b129 Mon Sep 17 00:00:00 2001
> From: Jan Nieuwenhuizen <janneke@gnu.org>
> Date: Fri, 16 Sep 2016 09:25:55 +0200
> Subject: [PATCH 4/4] cuirass: handle build failure.
>
> * src/cuirass/base.scm (build-packages): Catch build failures, write error log
> and update database.
> ---
>  src/cuirass/base.scm | 30 +++++++++++++++++++++---------
>  1 file changed, 21 insertions(+), 9 deletions(-)
>
> diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
> index e040f71..a65c412 100644
> --- a/src/cuirass/base.scm
> +++ b/src/cuirass/base.scm
> @@ -124,22 +124,34 @@ if required."
>  (define (build-packages store db jobs)
>    "Build JOBS and return a list of Build results."
>    (map (λ (job)
> -         (let ((log-port (%make-void-port "w0"))
> -               (name     (assq-ref job #:job-name))
> -               (drv      (assq-ref job #:derivation))
> -               (eval-id  (assq-ref job #:eval-id)))
> +         (let* ((name     (assq-ref job #:job-name))
> +                (drv      (assq-ref job #:derivation))
> +                (eval-id  (assq-ref job #:eval-id))
> +                (success? #t)
> +                (error-log (string-append (%package-cachedir) "/"
> +                                          name ".log")))
>             (simple-format #t "building ~A...\n" drv)
> -           (parameterize ((current-build-output-port log-port))
> -             (build-derivations store (list drv))
> -             (let* ((output (derivation-path->output-path drv))
> -                    (log    (log-file store output))
> +           (let ((log (call-with-output-string
> +                        (λ (port)
> +                          (parameterize ((current-build-output-port port))
> +                            (catch 'srfi-34
> +                              (λ ()
> +                                (build-derivations store (list drv)))
> +                              (λ (key . args)
> +                                (set! success? #f)
> +                                (pk "kets key:" key "args:" args))))))))
> +             (when (not success?)
> +               (with-output-to-file error-log
> +                 (lambda () (display log)))
> +               (simple-format #t "build failed: ~a\n" error-log))
> +             (let* ((output (and success? (derivation-path->output-path drv)))
> +                    (log    (if success? (log-file store output) error-log))
>                      (build  `((#:derivation . ,drv)
>                                (#:eval-id . ,eval-id)
>                                (#:log . ,log)
>                                (#:output . ,output))))
>                 (db-add-build db build)
>                 (simple-format #t "~A\n" output)
> -               (close-port log-port)
>                 build))))
>         jobs))
>  
> -- 
> 2.10.0

OK.

Can you send the updated patches?
I think you have done an amazing job.  Thank you!
diff mbox

Patch

From 67c3e529a811705c69047380414ba4687544b129 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Fri, 16 Sep 2016 09:25:55 +0200
Subject: [PATCH 4/4] cuirass: handle build failure.

* src/cuirass/base.scm (build-packages): Catch build failures, write error log
and update database.
---
 src/cuirass/base.scm | 30 +++++++++++++++++++++---------
 1 file changed, 21 insertions(+), 9 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index e040f71..a65c412 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -124,22 +124,34 @@  if required."
 (define (build-packages store db jobs)
   "Build JOBS and return a list of Build results."
   (map (λ (job)
-         (let ((log-port (%make-void-port "w0"))
-               (name     (assq-ref job #:job-name))
-               (drv      (assq-ref job #:derivation))
-               (eval-id  (assq-ref job #:eval-id)))
+         (let* ((name     (assq-ref job #:job-name))
+                (drv      (assq-ref job #:derivation))
+                (eval-id  (assq-ref job #:eval-id))
+                (success? #t)
+                (error-log (string-append (%package-cachedir) "/"
+                                          name ".log")))
            (simple-format #t "building ~A...\n" drv)
-           (parameterize ((current-build-output-port log-port))
-             (build-derivations store (list drv))
-             (let* ((output (derivation-path->output-path drv))
-                    (log    (log-file store output))
+           (let ((log (call-with-output-string
+                        (λ (port)
+                          (parameterize ((current-build-output-port port))
+                            (catch 'srfi-34
+                              (λ ()
+                                (build-derivations store (list drv)))
+                              (λ (key . args)
+                                (set! success? #f)
+                                (pk "kets key:" key "args:" args))))))))
+             (when (not success?)
+               (with-output-to-file error-log
+                 (lambda () (display log)))
+               (simple-format #t "build failed: ~a\n" error-log))
+             (let* ((output (and success? (derivation-path->output-path drv)))
+                    (log    (if success? (log-file store output) error-log))
                     (build  `((#:derivation . ,drv)
                               (#:eval-id . ,eval-id)
                               (#:log . ,log)
                               (#:output . ,output))))
                (db-add-build db build)
                (simple-format #t "~A\n" output)
-               (close-port log-port)
                build))))
        jobs))
 
-- 
2.10.0