guix
/
guix
mirror of git://git.savannah.gnu.org/guix.git
3
4
Fork 0
Code Issues Releases Wiki Activity

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.
This commit is contained in:
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 \
build-aux/build-self.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/hydra-to-cuirass.scm \
build-aux/check-final-inputs-self-contained.scm \
build-aux/check-channel-news.scm \
build-aux/compile-as-derivation.scm \
@ -955,28 +948,18 @@ check-channel-news: $(GOBJECTS)
$(AM_V_at)$(top_builddir)/pre-inst-env "$(GUILE)" \
"$(top_srcdir)/build-aux/check-channel-news.scm"
# Compute the Hydra jobs and write them in the target file.
hydra-jobs.scm: $(GOBJECTS)
$(AM_V_at)$(MKDIR_P) "`dirname "$@"`"
# Compute the Cuirass jobs.
cuirass-jobs: $(GOBJECTS)
rm -rf "$@"
$(AM_V_at)$(MKDIR_P) "$@"
$(AM_V_GEN)$(top_builddir)/pre-inst-env "$(GUILE)" \
"$(top_srcdir)/build-aux/hydra/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" "$@"
"$(top_srcdir)/build-aux/cuirass/evaluate.scm" "$@"
.PHONY: gen-ChangeLog gen-AUTHORS gen-tarball-version
.PHONY: assert-no-store-file-names assert-binaries-available
.PHONY: assert-final-inputs-self-contained check-channel-news
.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.

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)
(for-each (cut test-final-inputs store <>)
%hydra-supported-systems)))
%cuirass-supported-systems)))

105
build-aux/cuirass/evaluate.scm Normal file
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")
%base-packages/hurd
%base-packages)))
%hydra-supported-systems)))
%cuirass-supported-systems)))
(define %system-manifest
(manifest

448
gnu/ci.scm
View File

@ -3,7 +3,7 @@
;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
;;; 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.
;;;
@ -21,6 +21,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu ci)
#:use-module (guix channels)
#:use-module (guix config)
#:use-module (guix store)
#:use-module (guix grafts)
@ -64,67 +65,69 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (%cross-targets
#:export (%core-packages
%cross-targets
channel-source->package
hydra-jobs))
cuirass-jobs))
;;; Commentary:
;;;
;;; This file defines build jobs for the Hydra and Cuirass continuation
;;; integration tools.
;;; This file defines build jobs for Cuirass.
;;;
;;; Code:
(define* (package->alist store package system
#:optional (package-derivation package-derivation))
"Convert PACKAGE to an alist suitable for Hydra."
(parameterize ((%graft? #f))
(let ((drv (package-derivation store package system
#:graft? #f)))
`((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 . ,(package-synopsis package))
(long-description . ,(package-description package))
(define* (derivation->job name drv
#:key
period
(max-silent-time 3600)
(timeout 3600))
"Return a Cuirass job called NAME and describing DRV. PERIOD is the minimal
duration that must separate two evaluations of the same job. If PERIOD is
false, then the job will be evaluated as soon as possible.
;; XXX: Hydra ignores licenses that are not a <license> structure or a
;; list thereof.
(license . ,(let loop ((license (package-license package)))
(match license
((? license?)
(license-name license))
((lst ...)
(map loop license)))))
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
((name . path)
`(,name . ,path))))
(derivation->output-paths drv)))
(#:nix-name . ,(derivation-name drv))
(#:system . ,(derivation-system drv))
(#:period . ,period)
(#:max-silent-time . ,max-silent-time)
(#:timeout . ,timeout)))
(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)
(define* (package-job store job-name package system
#:key cross? target)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(let ((job-name (symbol-append job-name (string->symbol ".")
(string->symbol system))))
`(,job-name . ,(cut package->alist store package system))))
(let ((job-name (string-append job-name "." system)))
(parameterize ((%graft? #f))
(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)
"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM."
`(,(symbol-append (string->symbol target) (string->symbol ".") job-name
(string->symbol ".") (string->symbol system)) .
,(cute package->alist store package system
(lambda* (store package system #:key graft?)
(package-cross-derivation store package target system
#:graft? graft?)))))
(let ((name (string-append target "." job-name "." system)))
(package-job store name package system
#:cross? #t
#:target target)))
(define %core-packages
;; 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?)
%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.
;; This does not mean that other architectures are not supported, only that
;; 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
expensive in storage and I/O operations, hence their periodicity is limited by
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)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
(let ((name (string-append name "." system)))
(parameterize ((%graft? #f))
(derivation->job name drv
#:period (hours 48)))))
(define (build-image image)
(run-with-store store
@ -256,25 +254,26 @@ system.")
(expt 2 20))
(if (member system %guix-system-supported-systems)
`(,(->job 'usb-image
`(,(->job "usb-image"
(build-image
(image
(inherit efi-disk-image)
(operating-system installation-os))))
,(->job 'iso9660-image
,(->job "iso9660-image"
(build-image
(image
(inherit (image-with-label
iso9660-image
(string-append "GUIX_" system "_"
(if (> (string-length %guix-version) 7)
(substring %guix-version 0 7)
%guix-version))))
iso9660-image
(string-append "GUIX_" system "_"
(if (> (string-length %guix-version) 7)
(substring %guix-version 0 7)
%guix-version))))
(operating-system installation-os))))
;; Only cross-compile Guix System images from x86_64-linux for now.
,@(if (string=? system "x86_64-linux")
(map (lambda (image)
(->job (image-name image) (build-image image)))
(->job (symbol->string (image-name image))
(build-image image)))
%guix-system-images)
'()))
'()))
@ -322,112 +321,72 @@ system.")
(define* (system-test-jobs store system
#:key source commit)
"Return a list of jobs for the system tests."
(define (test->thunk test)
(lambda ()
(define drv
(run-with-store store
(mbegin %store-monad
(set-current-system system)
(set-grafting #f)
(set-guile-for-build (default-guile))
(system-test-value test))))
;; Those tests are extremely expensive in I/O operations and storage
;; size, use the "period" attribute to run them with a period of at
;; least 48 hours.
`((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 . ,(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))))
(parameterize ((current-guix-package
(channel-source->package source #:commit commit)))
(let ((name (string-append "test." (system-test-name test)
"." system))
(drv (run-with-store store
(mbegin %store-monad
(set-current-system system)
(set-grafting #f)
(set-guile-for-build (default-guile))
(system-test-value test)))))
;; Those tests are extremely expensive in I/O operations and storage
;; size, use the "period" attribute to run them with a period of at
;; least 48 hours.
(derivation->job name drv
#:period (hours 24)))))
(if (member system %guix-system-supported-systems)
;; Override the value of 'current-guix' used by system tests. Using a
;; channel instance makes tests that rely on 'current-guix' less
;; expensive. It also makes sure we get a valid Guix package when this
;; code is not running from a checkout.
(parameterize ((current-guix-package
(channel-source->package source #:commit commit)))
(map ->job (all-system-tests)))
(map ->job (all-system-tests))
'()))
(define (tarball-jobs store system)
"Return Hydra 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))))
"Return jobs to build the self-contained Guix binary tarball."
(define (->job name drv)
(let ((name (symbol-append name (string->symbol ".")
(string->symbol system))))
`(,name . ,(lambda ()
(parameterize ((%graft? #f))
(->alist drv))))))
(let ((name (string-append name "." system)))
(parameterize ((%graft? #f))
(derivation->job name drv
#:period (hours 24)))))
;; XXX: Add a job for the stable Guix?
(list (->job 'binary-tarball
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(>>= (profile-derivation (packages->manifest (list guix)))
(lambda (profile)
(self-contained-tarball "guix-binary" profile
#:localstatedir? #t
#:compressor
(lookup-compressor "xz")))))
#:system system))))
(list
(->job "binary-tarball"
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(>>= (profile-derivation (packages->manifest (list guix)))
(lambda (profile)
(self-contained-tarball "guix-binary" profile
#:localstatedir? #t
#:compressor
(lookup-compressor "xz")))))
#:system system))))
(define job-name
;; Return the name of a package's job.
(compose string->symbol package-name))
package-name)
(define package->job
(let ((base-packages
(delete-duplicates
(append-map (match-lambda
((_ package _ ...)
(match (package-transitive-inputs package)
(((_ inputs _ ...) ...)
inputs))))
((_ 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)
(package-job store (symbol-append 'base. (job-name package))
(package-job store (string-append "base." (job-name package))
package system))
((supported-package? package system)
(let ((drv (package-derivation store package system
@ -461,14 +420,19 @@ valid."
packages)))
#:select? (const #t))) ;include hidden packages
(define (arguments->manifests arguments)
(define (arguments->manifests arguments channels)
"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
((input-name . relative-path)
(let* ((checkout (assq-ref arguments (string->symbol input-name)))
(base (assq-ref checkout 'file-name)))
(in-vicinity base relative-path))))
(assq-ref arguments 'manifests)))
((name . path)
(let ((checkout (channel-name->checkout name)))
(in-vicinity checkout path))))
arguments))
(define (manifests->packages store manifests)
"Return the list of packages found in MANIFESTS."
@ -484,100 +448,94 @@ valid."
load-manifest)
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)
"Return Hydra jobs."
(define (cuirass-jobs store arguments)
"Register Cuirass jobs."
(define subset
(match (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
(assoc-ref arguments 'subset))
(define systems
(match (assoc-ref arguments 'systems)
(#f %hydra-supported-systems)
(#f %cuirass-supported-systems)
((lst ...) lst)
((? string? str) (call-with-input-string str read))))
(define checkout
(or (find-current-checkout arguments)
(assq-ref arguments 'superior-guix-checkout)))
(define channels
(let ((channels (assq-ref arguments 'channels)))
(map sexp->channel channels)))
(define guix
(find guix-channel? channels))
(define commit
(assq-ref checkout 'revision))
(channel-commit guix))
(define source
(assq-ref checkout 'file-name))
(channel-url guix))
;; Turn off grafts. Grafting is meant to happen on the user's machines.
(parameterize ((%graft? #f))
;; Return one job for each package, except bootstrap packages.
(append-map (lambda (system)
(format (current-error-port)
"evaluating for '~a' (heap size: ~a MiB)...~%"
system
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(invalidate-derivation-caches!)
(case subset
((all)
;; Build everything, including replacements.
(let ((all (all-packages))
(job (lambda (package)
(package->job store package
system))))
(append (filter-map job all)
(image-jobs store system)
(system-test-jobs store system
#:source source
#:commit commit)
(tarball-jobs store system)
(cross-jobs store system))))
((core)
;; Build core packages only.
(append (map (lambda (package)
(package-job store (job-name package)
package system))
%core-packages)
(cross-jobs store system)))
((hello)
;; Build hello package only.
(let ((hello (specification->package "hello")))
(list (package-job store (job-name hello) hello system))))
((list)
;; Build selected list of packages only.
(let* ((names (assoc-ref arguments 'subset))
(packages (map specification->package names)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages)))
((manifests)
;; Build packages in the list of manifests.
(let* ((manifests (arguments->manifests arguments))
(packages (manifests->packages store manifests)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages)))
(else
(error "unknown subset" subset))))
systems)))
(append-map
(lambda (system)
(format (current-error-port)
"evaluating for '~a' (heap size: ~a MiB)...~%"
system
(round
(/ (assoc-ref (gc-stats) 'heap-size)
(expt 2. 20))))
(invalidate-derivation-caches!)
(match subset
('all
;; Build everything, including replacements.
(let ((all (all-packages))
(job (lambda (package)
(package->job store package system))))
(append
(filter-map job all)
(image-jobs store system)
(system-test-jobs store system
#:source source
#:commit commit)
(tarball-jobs store system)
(cross-jobs store system))))
('core
;; Build core packages only.
(append
(map (lambda (package)
(package-job store (job-name package)
package system))
%core-packages)
(cross-jobs store system)))
('guix
;; Build Guix modules only.
(guix-jobs store systems
#:source source
#:commit commit))
('hello
;; Build hello package only.
(let ((hello (specification->package "hello")))
(list (package-job store (job-name hello)
hello system))))
(('packages . rest)
;; Build selected list of packages only.
(let ((packages (map specification->package rest)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages)))
(('manifests . rest)
;; Build packages in the list of manifests.
(let* ((manifests (arguments->manifests rest channels))
(packages (manifests->packages store manifests)))
(map (lambda (package)
(package-job store (job-name package)
package system))
packages)))
(else
(error "unknown subset" subset))))
systems)))

4
guix/packages.scm
View File

@ -131,7 +131,7 @@
%supported-systems
%hurd-systems
%hydra-supported-systems
%cuirass-supported-systems
supported-package?
&package-error
@ -351,7 +351,7 @@ name of its URI."
;; The GNU/Hurd systems for which support is being developed.
'("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.
;;
;; XXX: MIPS is unavailable in CI: