me
/
guix
Archived
1
0
Fork 0
Code

ci: Remove hydra support. 

This removes hydra support to use Cuirass as the only continuous integration
system.

* build-aux/hydra/gnu-system.scm: Remove it.
* build-aux/hydra/guix-modular.scm: Ditto.
* build-aux/hydra/guix.scm: Ditto.
* build-aux/cuirass/hydra-to-cuirass.scm: Ditto.
* Makefile.am (EXTRA_DIST): Update it.
(hydra-jobs.scm): Remove it.
(cuirass-jobs.scm): Update it.
* build-aux/hydra/evaluate.scm: Move it to ...
* build-aux/cuirass/evaluate.scm: ... here.
* build-aux/cuirass/guix-modular.scm: Remove it.
* build-aux/cuirass/gnu-system.scm: Ditto.
* guix/packages.scm (%hydra-supported-systems): Rename it to ...
(%cuirass-supported-systems): ... this variable.
* build-aux/check-final-inputs-self-contained: Adapt it.
* etc/release-manifest.scm: Ditto.
* gnu/ci.scm (package->alist): Remove it.
(derivation->job): New procedure.
(package-job, package-cross-job, cross-jobs, image-jobs, system-test-jobs,
tarball-jobs): Use it.
(guix-jobs): New procedure.
(hydra-jobs): Rename it to ...
(cuirass-jobs): ... this procedure.
master
Mathieu Othacehe 2021-03-10 08:48:19 +01:00
parent 4399b1cf57
commit 76bea3f8bc
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
13 changed files with 318 additions and 767 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Makefile.am
View File

@ -608,14 +608,7 @@ EXTRA_DIST += \
etc/historical-authorizations \ etc/historical-authorizations \
build-aux/build-self.scm \ build-aux/build-self.scm \
build-aux/compile-all.scm \ build-aux/compile-all.scm \
build-aux/hydra/evaluate.scm \
build-aux/hydra/gnu-system.scm \
build-aux/hydra/guix.scm \
build-aux/hydra/guix-modular.scm \
build-aux/cuirass/gnu-system.scm \
build-aux/cuirass/guix-modular.scm \
build-aux/cuirass/hurd-manifest.scm \ build-aux/cuirass/hurd-manifest.scm \
build-aux/cuirass/hydra-to-cuirass.scm \
build-aux/check-final-inputs-self-contained.scm \ build-aux/check-final-inputs-self-contained.scm \
build-aux/check-channel-news.scm \ build-aux/check-channel-news.scm \
build-aux/compile-as-derivation.scm \ build-aux/compile-as-derivation.scm \
@ -955,28 +948,18 @@ check-channel-news: $(GOBJECTS)
$(AM_V_at)$(top_builddir)/pre-inst-env "$(GUILE)" \ $(AM_V_at)$(top_builddir)/pre-inst-env "$(GUILE)" \
"$(top_srcdir)/build-aux/check-channel-news.scm" "$(top_srcdir)/build-aux/check-channel-news.scm"
# Compute the Hydra jobs and write them in the target file. # Compute the Cuirass jobs.
hydra-jobs.scm: $(GOBJECTS) cuirass-jobs: $(GOBJECTS)
$(AM_V_at)$(MKDIR_P) "`dirname "$@"`" rm -rf "$@"
$(AM_V_at)$(MKDIR_P) "$@"
$(AM_V_GEN)$(top_builddir)/pre-inst-env "$(GUILE)" \ $(AM_V_GEN)$(top_builddir)/pre-inst-env "$(GUILE)" \
"$(top_srcdir)/build-aux/hydra/evaluate.scm" \ "$(top_srcdir)/build-aux/cuirass/evaluate.scm" "$@"
"$(top_srcdir)/build-aux/hydra/gnu-system.scm" > "$@.tmp"
$(AM_V_at)mv "$@.tmp" "$@"
# Compute the Cuirass jobs and write them in the target file.
cuirass-jobs.scm: $(GOBJECTS)
$(AM_V_at)$(MKDIR_P) "`dirname "$@"`"
$(AM_V_GEN)$(top_builddir)/pre-inst-env "$(GUILE)" \
"$(top_srcdir)/build-aux/hydra/evaluate.scm" \
"$(top_srcdir)/build-aux/cuirass/gnu-system.scm" \
cuirass > "$@.tmp"
$(AM_V_at)mv "$@.tmp" "$@"
.PHONY: gen-ChangeLog gen-AUTHORS gen-tarball-version .PHONY: gen-ChangeLog gen-AUTHORS gen-tarball-version
.PHONY: assert-no-store-file-names assert-binaries-available .PHONY: assert-no-store-file-names assert-binaries-available
.PHONY: assert-final-inputs-self-contained check-channel-news .PHONY: assert-final-inputs-self-contained check-channel-news
.PHONY: clean-go make-go as-derivation authenticate .PHONY: clean-go make-go as-derivation authenticate
.PHONY: update-guix-package update-NEWS release .PHONY: update-guix-package update-NEWS cuirass-jobs release
# Downloading up-to-date PO files. # Downloading up-to-date PO files.

3
build-aux/check-final-inputs-self-contained.scm
View File

@ -83,5 +83,4 @@ refer to the bootstrap tools."
(set-build-options store #:use-substitutes? #t) (set-build-options store #:use-substitutes? #t)
(for-each (cut test-final-inputs store <>) (for-each (cut test-final-inputs store <>)
%hydra-supported-systems))) %cuirass-supported-systems)))

105
build-aux/cuirass/evaluate.scm 100644
View File

@ -0,0 +1,105 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Mathieu Othacehe <othacehe@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/>.
;;; This program replicates the behavior of Cuirass's 'evaluate' process.
;;; It displays the evaluated jobs on the standard output.
(use-modules (guix channels)
(guix derivations)
(guix git-download)
(guix inferior)
(guix packages)
(guix store)
(guix ui)
((guix ui) #:select (build-notifier))
(ice-9 match)
(ice-9 threads))
(define %top-srcdir
(and=> (assq-ref (current-source-location) 'filename)
(lambda (file)
(canonicalize-path
(string-append (dirname file) "/../..")))))
(match (command-line)
((command directory)
(let ((real-build-things build-things))
(with-store store
;; Make sure we don't resort to substitutes.
(set-build-options store
#:use-substitutes? #f
#:substitute-urls '())
;; The evaluation of Guix itself requires building a "trampoline"
;; program, and possibly everything it depends on. Thus, allow builds
;; but print a notification.
(with-build-handler (build-notifier #:use-substitutes? #f)
;; Add %TOP-SRCDIR to the store with a proper Git predicate so we
;; work from a clean checkout.
(let ((source (add-to-store store "guix-source" #t
"sha256" %top-srcdir
#:select? (git-predicate %top-srcdir))))
(define instances
(list (checkout->channel-instance source)))
(define channels
(map channel-instance-channel instances))
(define derivation
;; Compute the derivation of Guix for COMMIT.
(run-with-store store
(channel-instances->derivation instances)))
;; TODO: Remove 'show-what-to-build' call when Cuirass' 'evaluate'
;; scripts uses 'with-build-handler'.
(show-what-to-build store (list derivation))
(build-derivations store (list derivation))
;; Evaluate jobs on a per-system basis for two reasons. It speeds
;; up the evaluation speed as the evaluations can be performed
;; concurrently. It also decreases the amount of memory needed per
;; evaluation process.
(n-par-for-each
(/ (current-processor-count) 2)
(lambda (system)
(with-store store
(let ((inferior
(open-inferior (derivation->output-path derivation)))
(channels (map channel-instance->sexp instances)))
(inferior-eval '(use-modules (gnu ci)) inferior)
(let ((jobs
(inferior-eval-with-store
inferior store
`(lambda (store)
(cuirass-jobs store
'((subset . all)
(systems . ,(list system))
(channels . ,channels))))))
(file
(string-append directory "/jobs-" system ".scm")))
(call-with-output-file file
(lambda (port)
(write jobs port)))))))
%cuirass-supported-systems))))))
(x
(format (current-error-port) "Wrong command: ~a~%." x)
(exit 1)))

25
build-aux/cuirass/gnu-system.scm
View File

@ -1,25 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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/>.
;;;
;;; This file defines build jobs for the Cuirass continuation integration
;;; tool.
;;;
(include "../hydra/gnu-system.scm")
(include "hydra-to-cuirass.scm")

6
build-aux/cuirass/guix-modular.scm
View File

@ -1,6 +0,0 @@
;;;
;;; This file defines Cuirass build jobs to build Guix itself.
;;;
(include "../hydra/guix-modular.scm")
(include "hydra-to-cuirass.scm")

47
build-aux/cuirass/hydra-to-cuirass.scm
View File

@ -1,47 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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/>.
;;;
;;; This file defines the conversion of Hydra build jobs to Cuirass build
;;; jobs. It is meant to be included in other files.
;;;
(use-modules ((guix licenses)
#:select (license? license-name license-uri license-comment)))
(define (cuirass-jobs store arguments)
"Return Cuirass jobs."
(map hydra-job->cuirass-job (hydra-jobs store arguments)))
(define (hydra-job->cuirass-job hydra-job)
(let ((name (car hydra-job))
(job ((cdr hydra-job))))
(lambda _ (acons #:job-name (symbol->string name)
(map symbol-alist-entry->keyword-alist-entry job)))))
(define (symbol-alist-entry->keyword-alist-entry entry)
(cons (symbol->keyword (car entry)) (entry->sexp-entry (cdr entry))))
(define (entry->sexp-entry o)
(match o
((? license?) `((name . (license-name o))
(uri . ,(license-uri o))
(comment . ,(license-comment o))))
((lst ...)
(map entry->sexp-entry lst))
(_ o)))

131
build-aux/hydra/evaluate.scm
View File

@ -1,131 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 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/>.
;;; This program replicates the behavior of Hydra's 'hydra-eval-guile-job'.
;;; It evaluates the Hydra job defined by the program passed as its first
;;; arguments and outputs an sexp of the jobs on standard output.
(use-modules (guix store)
(guix git-download)
((guix build utils) #:select (with-directory-excursion))
((guix ui) #:select (build-notifier))
(srfi srfi-19)
(ice-9 match)
(ice-9 pretty-print)
(ice-9 format))
(define %top-srcdir
(and=> (assq-ref (current-source-location) 'filename)
(lambda (file)
(canonicalize-path
(string-append (dirname file) "/../..")))))
(define %user-module
;; Hydra user module.
(let ((m (make-module)))
(beautify-user-module! m)
m))
(define (call-with-time thunk kont)
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
values."
(let* ((start (current-time time-monotonic))
(result (call-with-values thunk list))
(end (current-time time-monotonic)))
(apply kont (time-difference end start) result)))
(define (call-with-time-display thunk)
"Call THUNK and write to the current output port its duration."
(call-with-time thunk
(lambda (time . results)
(format #t "~,3f seconds~%"
(+ (time-second time)
(/ (time-nanosecond time) 1e9)))
(apply values results))))
(define (assert-valid-job job thing)
"Raise an error if THING is not an alist with a valid 'derivation' entry.
Otherwise return THING."
(unless (and (list? thing)
(and=> (assoc-ref thing 'derivation)
(lambda (value)
(and (string? value)
(string-suffix? ".drv" value)))))
(error "job did not produce a valid alist" job thing))
thing)
;; Without further ado...
(match (command-line)
((command file cuirass? ...)
;; Load FILE, a Scheme file that defines Hydra jobs.
(let ((port (current-output-port))
(real-build-things build-things))
(with-store store
;; Make sure we don't resort to substitutes.
(set-build-options store
#:use-substitutes? #f
#:substitute-urls '())
;; The evaluation of Guix itself requires building a "trampoline"
;; program, and possibly everything it depends on. Thus, allow builds
;; but print a notification.
(with-build-handler (build-notifier #:use-substitutes? #f)
;; Add %TOP-SRCDIR to the store with a proper Git predicate so we work
;; from a clean checkout
(let ((source (add-to-store store "guix-source" #t
"sha256" %top-srcdir
#:select? (git-predicate %top-srcdir))))
(with-directory-excursion source
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(format (current-error-port)
"loading '~a' relative to '~a'...~%"
file source)
(primitive-load file))))
;; Call the entry point of FILE and print the resulting job sexp.
(pretty-print
(match ((module-ref %user-module
(if (equal? cuirass? "cuirass")
'cuirass-jobs
'hydra-jobs))
store `((guix
. ((file-name . ,source)))))
(((names . thunks) ...)
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(force-output (current-error-port))
(cons job
(assert-valid-job job
(call-with-time-display thunk))))
names thunks)))
port))))))
((command _ ...)
(format (current-error-port) "Usage: ~a FILE [cuirass]
Evaluate the Hydra or Cuirass jobs defined in FILE.~%"
command)
(exit 1)))
;;; Local Variables:
;;; eval: (put 'call-with-time 'scheme-indent-function 1)
;;; End:

88
build-aux/hydra/gnu-system.scm
View File

@ -1,88 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.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/>.
;;;
;;; This file defines build jobs for the Hydra continuation integration
;;; tool.
;;;
(use-modules (guix inferior) (guix channels)
(guix)
(guix ui)
(srfi srfi-1)
(ice-9 match))
;; 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) 'line)
(set-current-output-port (current-error-port))
(define (find-current-checkout arguments)
"Find the first checkout of ARGUMENTS that provided the current file.
Return #f if no such checkout is found."
(let ((current-root
(canonicalize-path
(string-append (dirname (current-filename)) "/../.."))))
(find (lambda (argument)
(and=> (assq-ref argument 'file-name)
(lambda (name)
(string=? name current-root)))) arguments)))
(define (hydra-jobs store arguments)
"Return a list of jobs where each job is a NAME/THUNK pair."
(define checkout
(find-current-checkout arguments))
(define commit
(assq-ref checkout 'revision))
(define source
(assq-ref checkout 'file-name))
(define instance
(checkout->channel-instance source #:commit commit))
(define derivation
;; Compute the derivation of Guix for COMMIT.
(run-with-store store
(channel-instances->derivation (list instance))))
;; TODO: Remove 'show-what-to-build' call when Cuirass' 'evaluate' scripts
;; uses 'with-build-handler'.
(show-what-to-build store (list derivation))
(build-derivations store (list derivation))
;; Open an inferior for the just-built Guix.
(let ((inferior (open-inferior (derivation->output-path derivation))))
(inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
(map (match-lambda
((name . fields)
;; Hydra expects a thunk, so here it is.
(cons name (lambda () fields))))
(inferior-eval-with-store
inferior store
`(lambda (store)
(map (match-lambda
((name . thunk)
(cons name (thunk))))
(hydra-jobs store '((superior-guix-checkout . ,checkout)
,@arguments))))))))

91
build-aux/hydra/guix-modular.scm
View File

@ -1,91 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2020 Ludovic Courtès <ludo@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/>.
;;;
;;; This file defines a continuous integration job to build the same modular
;;; Guix as 'guix pull', which is defined in (guix self).
;;;
(use-modules (guix store)
(guix config)
(guix utils)
((guix packages) #:select (%hydra-supported-systems))
(guix derivations)
(guix monads)
((guix licenses) #:prefix license:)
(srfi srfi-1)
(ice-9 match))
;; 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) 'line)
(set-current-output-port (current-error-port))
(define* (build-job store source version system)
"Return a Hydra job a list building the modular Guix derivation from SOURCE
for SYSTEM. Use VERSION as the version identifier."
(lambda ()
(define build
(primitive-load (string-append source "/build-aux/build-self.scm")))
(let ((drv (run-with-store store
(build source #:version version #:system system
#:pull-version 1
#:guile-version "2.2"))))
`((derivation . ,(derivation-file-name drv)) ;the latest 2.2.x
(log . ,(log-file store (derivation-file-name drv)))
(outputs . ,(filter-map (lambda (res)
(match res
((name . path)
`(,name . ,path))))
(derivation->output-paths drv)))
(nix-name . ,(derivation-name drv))
(system . ,(derivation-system drv))
(description . "Modular Guix")
(long-description
. "This is the modular Guix package as produced by 'guix pull'.")
(license . ,license:gpl3+)
(home-page . ,%guix-home-page-url)
(maintainers . (,%guix-bug-report-address))))))
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define systems
(match (assoc-ref arguments 'systems)
(#f %hydra-supported-systems)
((lst ...) lst)
((? string? str) (call-with-input-string str read))))
(define guix-checkout
(or (assq-ref arguments 'guix) ;Hydra on hydra
(assq-ref arguments 'guix-modular))) ;Cuirass on berlin
(define version
(or (assq-ref guix-checkout 'revision)
"0.unknown"))
(let ((file (assq-ref guix-checkout 'file-name)))
(format (current-error-port) "using checkout ~s (~s; arguments: ~s)~%"
guix-checkout file arguments)
(map (lambda (system)
(let ((name (string->symbol
(string-append "guix." system))))
`(,name
. ,(build-job store file version system))))
systems)))

106
build-aux/hydra/guix.scm
View File

@ -1,106 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@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/>.
;;;
;;; This file defines build jobs of Guix itself for the Hydra continuation
;;; integration tool.
;;;
;; Attempt to use our very own Guix modules.
(eval-when (expand load eval)
;; 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)
;; Display which files are loaded.
(set! %load-verbosely #t)
(and=> (assoc-ref (current-source-location) 'filename)
(lambda (file)
(let ((dir (string-append (dirname file) "/../..")))
(format (current-error-port) "prepending ~s to the load path~%"
dir)
(set! %load-path (cons dir %load-path))))))
(use-modules (guix store)
(guix packages)
(guix utils)
(guix grafts)
(guix derivations)
(guix build-system gnu)
(gnu packages package-management)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 match))
;; 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* (package->alist store package system
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra."
`((derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system
#:graft? #f))))
(description . ,(package-synopsis package))
(long-description . ,(package-description package))
(license . ,(package-license package))
(home-page . ,(package-home-page package))
(maintainers . ("bug-guix@gnu.org"))))
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define systems
(match (filter-map (match-lambda
(('system . value)
value)
(_ #f))
arguments)
((lst ..1)
lst)
(_
(list (%current-system)))))
(define guix-checkout
(assq-ref arguments 'guix))
(let ((file (assq-ref guix-checkout 'file-name)))
(format (current-error-port) "using checkout ~s (~s)~%"
guix-checkout file)
`((tarball . ,(cute package->alist store
(dist-package guix file)
(%current-system)))
,@(map (lambda (system)
(let ((name (string->symbol
(string-append "guix." system))))
`(,name
. ,(cute package->alist store
(package
(inherit guix)
(version "latest")
(source file))
system))))
%hydra-supported-systems))))

2
etc/release-manifest.scm
View File

@ -103,7 +103,7 @@ TARGET."
(if (string=? system "i586-gnu") (if (string=? system "i586-gnu")
%base-packages/hurd %base-packages/hurd
%base-packages))) %base-packages)))
%hydra-supported-systems))) %cuirass-supported-systems)))
(define %system-manifest (define %system-manifest
(manifest (manifest

312
gnu/ci.scm
View File

@ -3,7 +3,7 @@
;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> ;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -21,6 +21,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu ci) (define-module (gnu ci)
#:use-module (guix channels)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix grafts) #:use-module (guix grafts)
@ -64,67 +65,69 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (%cross-targets #:export (%core-packages
%cross-targets
channel-source->package channel-source->package
hydra-jobs)) cuirass-jobs))
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; This file defines build jobs for the Hydra and Cuirass continuation ;;; This file defines build jobs for Cuirass.
;;; integration tools.
;;; ;;;
;;; Code: ;;; Code:
(define* (package->alist store package system (define* (derivation->job name drv
#:optional (package-derivation package-derivation)) #:key
"Convert PACKAGE to an alist suitable for Hydra." period
(parameterize ((%graft? #f)) (max-silent-time 3600)
(let ((drv (package-derivation store package system (timeout 3600))
#:graft? #f))) "Return a Cuirass job called NAME and describing DRV. PERIOD is the minimal
`((derivation . ,(derivation-file-name drv)) duration that must separate two evaluations of the same job. If PERIOD is
(log . ,(log-file store (derivation-file-name drv))) false, then the job will be evaluated as soon as possible.
(outputs . ,(filter-map (lambda (res)
MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
building the derivation."
`((#:job-name . ,name)
(#:derivation . ,(derivation-file-name drv))
(#:outputs . ,(filter-map
(lambda (res)
(match res (match res
((name . path) ((name . path)
`(,name . ,path)))) `(,name . ,path))))
(derivation->output-paths drv))) (derivation->output-paths drv)))
(nix-name . ,(derivation-name drv)) (#:nix-name . ,(derivation-name drv))
(system . ,(derivation-system drv)) (#:system . ,(derivation-system drv))
(description . ,(package-synopsis package)) (#:period . ,period)
(long-description . ,(package-description package)) (#:max-silent-time . ,max-silent-time)
(#:timeout . ,timeout)))
;; XXX: Hydra ignores licenses that are not a <license> structure or a (define* (package-job store job-name package system
;; list thereof. #:key cross? target)
(license . ,(let loop ((license (package-license package)))
(match license
((? license?)
(license-name license))
((lst ...)
(map loop license)))))
(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." "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(let ((job-name (symbol-append job-name (string->symbol ".") (let ((job-name (string-append job-name "." system)))
(string->symbol system)))) (parameterize ((%graft? #f))
`(,job-name . ,(cut package->alist store package system)))) (let* ((drv (if cross?
(package-cross-derivation store package target system
#:graft? #f)
(package-derivation store package system
#:graft? #f)))
(max-silent-time (or (assoc-ref (package-properties package)
'max-silent-time)
3600))
(timeout (or (assoc-ref (package-properties package)
'timeout)
72000)))
(derivation->job job-name drv
#:max-silent-time max-silent-time
#:timeout timeout)))))
(define (package-cross-job store job-name package target system) (define (package-cross-job store job-name package target system)
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM." SYSTEM."
`(,(symbol-append (string->symbol target) (string->symbol ".") job-name (let ((name (string-append target "." job-name "." system)))
(string->symbol ".") (string->symbol system)) . (package-job store name package system
,(cute package->alist store package system #:cross? #t
(lambda* (store package system #:key graft?) #:target target)))
(package-cross-derivation store package target system
#:graft? graft?)))))
(define %core-packages (define %core-packages
;; Note: Don't put the '-final' package variants because (1) that's ;; Note: Don't put the '-final' package variants because (1) that's
@ -200,6 +203,22 @@ SYSTEM."
(remove (either from-32-to-64? same? pointless?) (remove (either from-32-to-64? same? pointless?)
%cross-targets))) %cross-targets)))
(define* (guix-jobs store systems #:key source commit)
"Return a list of jobs for Guix itself."
(define build
(primitive-load (string-append source "/build-aux/build-self.scm")))
(map
(lambda (system)
(let ((name (string->symbol
(string-append "guix." system)))
(drv (run-with-store store
(build source #:version commit #:system system
#:pull-version 1
#:guile-version "2.2"))))
(derivation->job name drv)))
systems))
;; Architectures that are able to build or cross-build Guix System images. ;; Architectures that are able to build or cross-build Guix System images.
;; This does not mean that other architectures are not supported, only that ;; This does not mean that other architectures are not supported, only that
;; they are often not fast enough to support Guix System images building. ;; they are often not fast enough to support Guix System images building.
@ -219,32 +238,11 @@ SYSTEM."
"Return a list of jobs that build images for SYSTEM. Those jobs are "Return a list of jobs that build images for SYSTEM. Those jobs are
expensive in storage and I/O operations, hence their periodicity is limited by expensive in storage and I/O operations, hence their periodicity is limited by
passing the PERIOD argument." passing the PERIOD argument."
(define (->alist drv)
`((derivation . ,(derivation-file-name drv))
(log . ,(log-file store (derivation-file-name drv)))
(outputs . ,(filter-map (lambda (res)
(match res
((name . path)
`(,name . ,path))))
(derivation->output-paths drv)))
(nix-name . ,(derivation-name drv))
(system . ,(derivation-system drv))
(description . "Stand-alone image of the GNU system")
(long-description . "This is a demo stand-alone image of the GNU
system.")
(license . ,(license-name gpl3+))
(period . ,(hours 48))
(max-silent-time . 3600)
(timeout . 3600)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))))
(define (->job name drv) (define (->job name drv)
(let ((name (symbol-append name (string->symbol ".") (let ((name (string-append name "." system)))
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f)) (parameterize ((%graft? #f))
(->alist drv)))))) (derivation->job name drv
#:period (hours 48)))))
(define (build-image image) (define (build-image image)
(run-with-store store (run-with-store store
@ -256,12 +254,12 @@ system.")
(expt 2 20)) (expt 2 20))
(if (member system %guix-system-supported-systems) (if (member system %guix-system-supported-systems)
`(,(->job 'usb-image `(,(->job "usb-image"
(build-image (build-image
(image (image
(inherit efi-disk-image) (inherit efi-disk-image)
(operating-system installation-os)))) (operating-system installation-os))))
,(->job 'iso9660-image ,(->job "iso9660-image"
(build-image (build-image
(image (image
(inherit (image-with-label (inherit (image-with-label
@ -274,7 +272,8 @@ system.")
;; Only cross-compile Guix System images from x86_64-linux for now. ;; Only cross-compile Guix System images from x86_64-linux for now.
,@(if (string=? system "x86_64-linux") ,@(if (string=? system "x86_64-linux")
(map (lambda (image) (map (lambda (image)
(->job (image-name image) (build-image image))) (->job (symbol->string (image-name image))
(build-image image)))
%guix-system-images) %guix-system-images)
'())) '()))
'())) '()))
@ -322,83 +321,43 @@ system.")
(define* (system-test-jobs store system (define* (system-test-jobs store system
#:key source commit) #:key source commit)
"Return a list of jobs for the system tests." "Return a list of jobs for the system tests."
(define (test->thunk test) (define (->job test)
(lambda () (parameterize ((current-guix-package
(define drv (channel-source->package source #:commit commit)))
(run-with-store store (let ((name (string-append "test." (system-test-name test)
"." system))
(drv (run-with-store store
(mbegin %store-monad (mbegin %store-monad
(set-current-system system) (set-current-system system)
(set-grafting #f) (set-grafting #f)
(set-guile-for-build (default-guile)) (set-guile-for-build (default-guile))
(system-test-value test)))) (system-test-value test)))))
;; Those tests are extremely expensive in I/O operations and storage ;; Those tests are extremely expensive in I/O operations and storage
;; size, use the "period" attribute to run them with a period of at ;; size, use the "period" attribute to run them with a period of at
;; least 48 hours. ;; least 48 hours.
`((derivation . ,(derivation-file-name drv)) (derivation->job name drv
(log . ,(log-file store (derivation-file-name drv))) #:period (hours 24)))))
(outputs . ,(filter-map (lambda (res)
(match res
((name . path)
`(,name . ,path))))
(derivation->output-paths drv)))
(nix-name . ,(derivation-name drv))
(system . ,(derivation-system drv))
(description . ,(format #f "Guix '~a' system test"
(system-test-name test)))
(long-description . ,(system-test-description test))
(license . ,(license-name gpl3+))
(period . ,(hours 48))
(max-silent-time . 3600)
(timeout . 3600)
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org")))))
(define (->job test)
(let ((name (string->symbol
(string-append "test." (system-test-name test)
"." system))))
(cons name (test->thunk test))))
(if (member system %guix-system-supported-systems) (if (member system %guix-system-supported-systems)
;; Override the value of 'current-guix' used by system tests. Using a ;; Override the value of 'current-guix' used by system tests. Using a
;; channel instance makes tests that rely on 'current-guix' less ;; channel instance makes tests that rely on 'current-guix' less
;; expensive. It also makes sure we get a valid Guix package when this ;; expensive. It also makes sure we get a valid Guix package when this
;; code is not running from a checkout. ;; code is not running from a checkout.
(parameterize ((current-guix-package (map ->job (all-system-tests))
(channel-source->package source #:commit commit)))
(map ->job (all-system-tests)))
'())) '()))
(define (tarball-jobs store system) (define (tarball-jobs store system)
"Return Hydra jobs to build the self-contained Guix binary tarball." "Return jobs to build the self-contained Guix binary tarball."
(define (->alist drv)
`((derivation . ,(derivation-file-name drv))
(log . ,(log-file store (derivation-file-name drv)))
(outputs . ,(filter-map (lambda (res)
(match res
((name . path)
`(,name . ,path))))
(derivation->output-paths drv)))
(nix-name . ,(derivation-name drv))
(system . ,(derivation-system drv))
(description . "Stand-alone binary Guix tarball")
(long-description . "This is a tarball containing binaries of Guix and
all its dependencies, and ready to be installed on \"foreign\" distributions.")
(license . ,(license-name gpl3+))
(home-page . ,%guix-home-page-url)
(maintainers . ("bug-guix@gnu.org"))
(period . ,(hours 24))))
(define (->job name drv) (define (->job name drv)
(let ((name (symbol-append name (string->symbol ".") (let ((name (string-append name "." system)))
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f)) (parameterize ((%graft? #f))
(->alist drv)))))) (derivation->job name drv
#:period (hours 24)))))
;; XXX: Add a job for the stable Guix? ;; XXX: Add a job for the stable Guix?
(list (->job 'binary-tarball (list
(->job "binary-tarball"
(run-with-store store (run-with-store store
(mbegin %store-monad (mbegin %store-monad
(set-guile-for-build (default-guile)) (set-guile-for-build (default-guile))
@ -412,7 +371,7 @@ all its dependencies, and ready to be installed on \"foreign\" distributions.")
(define job-name (define job-name
;; Return the name of a package's job. ;; Return the name of a package's job.
(compose string->symbol package-name)) package-name)
(define package->job (define package->job
(let ((base-packages (let ((base-packages
@ -427,7 +386,7 @@ all its dependencies, and ready to be installed on \"foreign\" distributions.")
"Return a job for PACKAGE on SYSTEM, or #f if this combination is not "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid." valid."
(cond ((member package base-packages) (cond ((member package base-packages)
(package-job store (symbol-append 'base. (job-name package)) (package-job store (string-append "base." (job-name package))
package system)) package system))
((supported-package? package system) ((supported-package? package system)
(let ((drv (package-derivation store package system (let ((drv (package-derivation store package system
@ -461,14 +420,19 @@ valid."
packages))) packages)))
#:select? (const #t))) ;include hidden packages #:select? (const #t))) ;include hidden packages
(define (arguments->manifests arguments) (define (arguments->manifests arguments channels)
"Return the list of manifests extracted from ARGUMENTS." "Return the list of manifests extracted from ARGUMENTS."
(define (channel-name->checkout name)
(let ((channel (find (lambda (channel)
(eq? (channel-name channel) name))
channels)))
(channel-url channel)))
(map (match-lambda (map (match-lambda
((input-name . relative-path) ((name . path)
(let* ((checkout (assq-ref arguments (string->symbol input-name))) (let ((checkout (channel-name->checkout name)))
(base (assq-ref checkout 'file-name))) (in-vicinity checkout path))))
(in-vicinity base relative-path)))) arguments))
(assq-ref arguments 'manifests)))
(define (manifests->packages store manifests) (define (manifests->packages store manifests)
"Return the list of packages found in MANIFESTS." "Return the list of packages found in MANIFESTS."
@ -484,52 +448,40 @@ valid."
load-manifest) load-manifest)
manifests)))) manifests))))
(define (find-current-checkout arguments)
"Find the first checkout of ARGUMENTS that provided the current file.
Return #f if no such checkout is found."
(let ((current-root
(canonicalize-path
(string-append (dirname (current-filename)) "/.."))))
(find (lambda (argument)
(and=> (assq-ref argument 'file-name)
(lambda (name)
(string=? name current-root)))) arguments)))
;;; ;;;
;;; Hydra entry point. ;;; Cuirass entry point.
;;; ;;;
(define (hydra-jobs store arguments) (define (cuirass-jobs store arguments)
"Return Hydra jobs." "Register Cuirass jobs."
(define subset (define subset
(match (assoc-ref arguments 'subset) (assoc-ref arguments 'subset))
("core" 'core) ; only build core packages
("hello" 'hello) ; only build hello
(((? string?) (? string?) ...) 'list) ; only build selected list of packages
("manifests" 'manifests) ; only build packages in the list of manifests
(_ 'all))) ; build everything
(define systems (define systems
(match (assoc-ref arguments 'systems) (match (assoc-ref arguments 'systems)
(#f %hydra-supported-systems) (#f %cuirass-supported-systems)
((lst ...) lst) ((lst ...) lst)
((? string? str) (call-with-input-string str read)))) ((? string? str) (call-with-input-string str read))))
(define checkout (define channels
(or (find-current-checkout arguments) (let ((channels (assq-ref arguments 'channels)))
(assq-ref arguments 'superior-guix-checkout))) (map sexp->channel channels)))
(define guix
(find guix-channel? channels))
(define commit (define commit
(assq-ref checkout 'revision)) (channel-commit guix))
(define source (define source
(assq-ref checkout 'file-name)) (channel-url guix))
;; Turn off grafts. Grafting is meant to happen on the user's machines. ;; Turn off grafts. Grafting is meant to happen on the user's machines.
(parameterize ((%graft? #f)) (parameterize ((%graft? #f))
;; Return one job for each package, except bootstrap packages. ;; Return one job for each package, except bootstrap packages.
(append-map (lambda (system) (append-map
(lambda (system)
(format (current-error-port) (format (current-error-port)
"evaluating for '~a' (heap size: ~a MiB)...~%" "evaluating for '~a' (heap size: ~a MiB)...~%"
system system
@ -537,42 +489,48 @@ Return #f if no such checkout is found."
(/ (assoc-ref (gc-stats) 'heap-size) (/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20)))) (expt 2. 20))))
(invalidate-derivation-caches!) (invalidate-derivation-caches!)
(case subset (match subset
((all) ('all
;; Build everything, including replacements. ;; Build everything, including replacements.
(let ((all (all-packages)) (let ((all (all-packages))
(job (lambda (package) (job (lambda (package)
(package->job store package (package->job store package system))))
system)))) (append
(append (filter-map job all) (filter-map job all)
(image-jobs store system) (image-jobs store system)
(system-test-jobs store system (system-test-jobs store system
#:source source #:source source
#:commit commit) #:commit commit)
(tarball-jobs store system) (tarball-jobs store system)
(cross-jobs store system)))) (cross-jobs store system))))
((core) ('core
;; Build core packages only. ;; Build core packages only.
(append (map (lambda (package) (append
(map (lambda (package)
(package-job store (job-name package) (package-job store (job-name package)
package system)) package system))
%core-packages) %core-packages)
(cross-jobs store system))) (cross-jobs store system)))
((hello) ('guix
;; Build Guix modules only.
(guix-jobs store systems
#:source source
#:commit commit))
('hello
;; Build hello package only. ;; Build hello package only.
(let ((hello (specification->package "hello"))) (let ((hello (specification->package "hello")))
(list (package-job store (job-name hello) hello system)))) (list (package-job store (job-name hello)
((list) hello system))))
(('packages . rest)
;; Build selected list of packages only. ;; Build selected list of packages only.
(let* ((names (assoc-ref arguments 'subset)) (let ((packages (map specification->package rest)))
(packages (map specification->package names)))
(map (lambda (package) (map (lambda (package)
(package-job store (job-name package) (package-job store (job-name package)
package system)) package system))
packages))) packages)))
((manifests) (('manifests . rest)
;; Build packages in the list of manifests. ;; Build packages in the list of manifests.
(let* ((manifests (arguments->manifests arguments)) (let* ((manifests (arguments->manifests rest channels))
(packages (manifests->packages store manifests))) (packages (manifests->packages store manifests)))
(map (lambda (package) (map (lambda (package)
(package-job store (job-name package) (package-job store (job-name package)

4
guix/packages.scm
View File

@ -131,7 +131,7 @@
%supported-systems %supported-systems
%hurd-systems %hurd-systems
%hydra-supported-systems %cuirass-supported-systems
supported-package? supported-package?
&package-error &package-error
@ -351,7 +351,7 @@ name of its URI."
;; The GNU/Hurd systems for which support is being developed. ;; The GNU/Hurd systems for which support is being developed.
'("i586-gnu" "i686-gnu")) '("i586-gnu" "i686-gnu"))
(define %hydra-supported-systems (define %cuirass-supported-systems
;; This is the list of system types for which build machines are available. ;; This is the list of system types for which build machines are available.
;; ;;
;; XXX: MIPS is unavailable in CI: ;; XXX: MIPS is unavailable in CI: