mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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:
parent
4399b1cf57
commit
76bea3f8bc
13 changed files with 318 additions and 767 deletions
29
Makefile.am
29
Makefile.am
|
@ -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.
|
||||||
|
|
||||||
|
|
|
@ -83,5 +83,4 @@ (define (test-final-inputs store system)
|
||||||
(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
Normal file
105
build-aux/cuirass/evaluate.scm
Normal 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)))
|
|
@ -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")
|
|
|
@ -1,6 +0,0 @@
|
||||||
;;;
|
|
||||||
;;; This file defines Cuirass build jobs to build Guix itself.
|
|
||||||
;;;
|
|
||||||
|
|
||||||
(include "../hydra/guix-modular.scm")
|
|
||||||
(include "hydra-to-cuirass.scm")
|
|
|
@ -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)))
|
|
|
@ -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:
|
|
||||||
|
|
|
@ -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))))))))
|
|
|
@ -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)))
|
|
|
@ -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))))
|
|
|
@ -103,7 +103,7 @@ (define %base-manifest
|
||||||
(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
312
gnu/ci.scm
|
@ -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 @@ (define-module (gnu ci)
|
||||||
#: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 @@ (define (either proc1 proc2 proc3)
|
||||||
(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 @@ (define (image-jobs store 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 @@ (define MiB
|
||||||
(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 @@ (define MiB
|
||||||
;; 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 @@ (define* (channel-source->package source #:key commit)
|
||||||
(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 @@ (define (->job name drv)
|
||||||
|
|
||||||
(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 @@ (define package->job
|
||||||
"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 @@ (define (adjust package result)
|
||||||
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 @@ (define (load-manifest manifest)
|
||||||
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 @@ (define source
|
||||||
(/ (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)
|
||||||
|
|
|
@ -131,7 +131,7 @@ (define-module (guix packages)
|
||||||
|
|
||||||
%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 @@ (define %hurd-systems
|
||||||
;; 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:
|
||||||
|
|
Loading…
Reference in a new issue