diff options
| -rw-r--r-- | Makefile.am | 29 | ||||
| -rw-r--r-- | build-aux/check-final-inputs-self-contained.scm | 3 | ||||
| -rw-r--r-- | build-aux/cuirass/evaluate.scm | 105 | ||||
| -rw-r--r-- | build-aux/cuirass/gnu-system.scm | 25 | ||||
| -rw-r--r-- | build-aux/cuirass/guix-modular.scm | 6 | ||||
| -rw-r--r-- | build-aux/cuirass/hydra-to-cuirass.scm | 47 | ||||
| -rw-r--r-- | build-aux/hydra/evaluate.scm | 131 | ||||
| -rw-r--r-- | build-aux/hydra/gnu-system.scm | 88 | ||||
| -rw-r--r-- | build-aux/hydra/guix-modular.scm | 91 | ||||
| -rw-r--r-- | build-aux/hydra/guix.scm | 106 | ||||
| -rw-r--r-- | etc/release-manifest.scm | 2 | ||||
| -rw-r--r-- | gnu/ci.scm | 452 | ||||
| -rw-r--r-- | guix/packages.scm | 4 |
13 files changed, 320 insertions, 769 deletions
diff --git a/Makefile.am b/Makefile.am index bb27297096..0f87c958f7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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. diff --git a/build-aux/check-final-inputs-self-contained.scm b/build-aux/check-final-inputs-self-contained.scm index c819086508..a6148d12e3 100644 --- a/build-aux/check-final-inputs-self-contained.scm +++ b/build-aux/check-final-inputs-self-contained.scm @@ -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))) diff --git a/build-aux/cuirass/evaluate.scm b/build-aux/cuirass/evaluate.scm new file mode 100644 index 0000000000..fc0744ad2a --- /dev/null +++ b/build-aux/cuirass/evaluate.scm @@ -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))) diff --git a/build-aux/cuirass/gnu-system.scm b/build-aux/cuirass/gnu-system.scm deleted file mode 100644 index 0eb834cfba..0000000000 --- a/build-aux/cuirass/gnu-system.scm +++ /dev/null @@ -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") diff --git a/build-aux/cuirass/guix-modular.scm b/build-aux/cuirass/guix-modular.scm deleted file mode 100644 index cbbdbf1133..0000000000 --- a/build-aux/cuirass/guix-modular.scm +++ /dev/null @@ -1,6 +0,0 @@ -;;; -;;; This file defines Cuirass build jobs to build Guix itself. -;;; - -(include "../hydra/guix-modular.scm") -(include "hydra-to-cuirass.scm") diff --git a/build-aux/cuirass/hydra-to-cuirass.scm b/build-aux/cuirass/hydra-to-cuirass.scm deleted file mode 100644 index 75c77ea35a..0000000000 --- a/build-aux/cuirass/hydra-to-cuirass.scm +++ /dev/null @@ -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))) diff --git a/build-aux/hydra/evaluate.scm b/build-aux/hydra/evaluate.scm deleted file mode 100644 index c74fcdb763..0000000000 --- a/build-aux/hydra/evaluate.scm +++ /dev/null @@ -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: - diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm deleted file mode 100644 index a03324daeb..0000000000 --- a/build-aux/hydra/gnu-system.scm +++ /dev/null @@ -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)))))))) diff --git a/build-aux/hydra/guix-modular.scm b/build-aux/hydra/guix-modular.scm deleted file mode 100644 index 060b84b8ef..0000000000 --- a/build-aux/hydra/guix-modular.scm +++ /dev/null @@ -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))) diff --git a/build-aux/hydra/guix.scm b/build-aux/hydra/guix.scm deleted file mode 100644 index 08193ec82e..0000000000 --- a/build-aux/hydra/guix.scm +++ /dev/null @@ -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)))) diff --git a/etc/release-manifest.scm b/etc/release-manifest.scm index da98d6e00b..a1f731a945 100644 --- a/etc/release-manifest.scm +++ b/etc/release-manifest.scm @@ -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 diff --git a/gnu/ci.scm b/gnu/ci.scm index 96bff64875..6edcdd0e19 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -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)) - - ;; 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))))) - - (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* (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. + +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))) + +(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))) diff --git a/guix/packages.scm b/guix/packages.scm index eae8fcbb6e..a057a88c63 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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: |