From c980a4a1357ca96c523e45b904cb2c2c1ead5b40 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 14 Feb 2021 17:34:49 +0100 Subject: [PATCH] ci: Remove hydra support. This removes hydra support to use Cuirass as the only continuous integration system. It also changes the way jobs are transmitted to Cuirass. The "cuirass-jobs" procedure no longer returns jobs. Instead it is passed a "register" callback that can be called to register jobs. This decreases the memory consumption and increases the evaluation speed as there's no need to operate a possibly huge list of jobs anymore. * 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: Adapt it to use the Cuirass register procedure. * build-aux/cuirass/gnu-system.scm: Ditto. * gnu/ci.scm (package->alist): Remove it. (register-job-from-drv): New procedure. (package-job, package-cross-job, cross-jobs, image-jobs, system-test-jobs, tarball-jobs): Add a register arguments and pass it to "register-job-from-drv" procedure. (hydra-jobs): Rename it to ... (cuirass-jobs): ... this procedure. Also add a register argument. --- Makefile.am | 17 +- build-aux/{hydra => cuirass}/evaluate.scm | 30 +- build-aux/cuirass/gnu-system.scm | 93 ++++- build-aux/cuirass/guix-modular.scm | 83 ++++- build-aux/cuirass/hydra-to-cuirass.scm | 47 --- build-aux/hydra/gnu-system.scm | 88 ----- build-aux/hydra/guix-modular.scm | 91 ----- build-aux/hydra/guix.scm | 106 ------ gnu/ci.scm | 429 ++++++++++------------ 9 files changed, 373 insertions(+), 611 deletions(-) rename build-aux/{hydra => cuirass}/evaluate.scm (82%) delete mode 100644 build-aux/cuirass/hydra-to-cuirass.scm delete mode 100644 build-aux/hydra/gnu-system.scm delete mode 100644 build-aux/hydra/guix-modular.scm delete mode 100644 build-aux/hydra/guix.scm diff --git a/Makefile.am b/Makefile.am index 52537fb53d..85307707d6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -603,14 +603,9 @@ 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 \ @@ -950,21 +945,13 @@ 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 "$@"`" - $(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/evaluate.scm" \ "$(top_srcdir)/build-aux/cuirass/gnu-system.scm" \ - cuirass > "$@.tmp" + "$@.tmp" $(AM_V_at)mv "$@.tmp" "$@" .PHONY: gen-ChangeLog gen-AUTHORS gen-tarball-version diff --git a/build-aux/hydra/evaluate.scm b/build-aux/cuirass/evaluate.scm similarity index 82% rename from build-aux/hydra/evaluate.scm rename to build-aux/cuirass/evaluate.scm index c74fcdb763..f2ad67a104 100644 --- a/build-aux/hydra/evaluate.scm +++ b/build-aux/cuirass/evaluate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès ;;; Copyright © 2017 Jan Nieuwenhuizen +;;; Copyright © 2021 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -73,7 +74,7 @@ Otherwise return THING." ;; Without further ado... (match (command-line) - ((command file cuirass? ...) + ((command file output) ;; Load FILE, a Scheme file that defines Hydra jobs. (let ((port (current-output-port)) (real-build-things build-things)) @@ -91,7 +92,7 @@ Otherwise return THING." ;; 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 + "sha256" %top-srcdir #:select? (git-predicate %top-srcdir)))) (with-directory-excursion source (save-module-excursion @@ -102,23 +103,13 @@ Otherwise return THING." 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)))))) + (call-with-output-file output + (lambda (port) + ((module-ref %user-module 'cuirass-jobs) + store + `((guix-modular . ((file-name . ,source)))) + (lambda args + (write args port)))))))))) ((command _ ...) (format (current-error-port) "Usage: ~a FILE [cuirass] Evaluate the Hydra or Cuirass jobs defined in FILE.~%" @@ -128,4 +119,3 @@ Evaluate the Hydra or Cuirass jobs defined in FILE.~%" ;;; Local Variables: ;;; eval: (put 'call-with-time 'scheme-indent-function 1) ;;; End: - diff --git a/build-aux/cuirass/gnu-system.scm b/build-aux/cuirass/gnu-system.scm index 0eb834cfba..71f33691fc 100644 --- a/build-aux/cuirass/gnu-system.scm +++ b/build-aux/cuirass/gnu-system.scm @@ -1,5 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès ;;; Copyright © 2017 Jan Nieuwenhuizen +;;; Copyright © 2018, 2019 Clément Lassieur +;;; Copyright © 2021 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,5 +24,91 @@ ;;; tool. ;;; -(include "../hydra/gnu-system.scm") -(include "hydra-to-cuirass.scm") +(use-modules (guix inferior) (guix channels) + (guix) + (guix ui) + (srfi srfi-1) + (ice-9 match) + (ice-9 threads)) + +;; 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* (cuirass-jobs store arguments register) + "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. + (call-with-temporary-directory + (lambda (directory) + (let* ((name (string-append directory "/ci-inferior")) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (inferior (open-inferior (derivation->output-path derivation)))) + + ;; XXX: The inferior cannot call directly the register procedure that + ;; is declared in Cuirass. Use a socket to proxy the inferior + ;; registration requests. + (call-with-new-thread + (lambda () + (bind socket AF_UNIX name) + (listen socket 1024) + (match (select (list socket) '() '() 60) + (((_) () ()) + (match (accept socket) + ((client . address) + (setvbuf client 'block 1024) + (let loop ((exp (read client))) + (unless (eof-object? exp) + (apply register exp) + (loop (read client))))))) + ((() () ()) + #f)) + (close-port socket))) + + (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior) + (inferior-eval-with-store + inferior store + `(lambda (store) + (let* ((socket (socket AF_UNIX SOCK_STREAM 0)) + (register (lambda args + (write args socket)))) + (connect socket AF_UNIX ,name) + (setvbuf socket 'block 1024) + (cuirass-jobs store '((superior-guix-checkout . ,checkout) + ,@arguments) + register) + (close-port socket)))))))) diff --git a/build-aux/cuirass/guix-modular.scm b/build-aux/cuirass/guix-modular.scm index cbbdbf1133..0b546e55df 100644 --- a/build-aux/cuirass/guix-modular.scm +++ b/build-aux/cuirass/guix-modular.scm @@ -1,6 +1,83 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 2018, 2020 Ludovic Courtès +;;; Copyright © 2021 Mathieu Othacehe ;;; -;;; This file defines Cuirass build jobs to build Guix itself. +;;; 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 . + +;;; +;;; 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) + (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 register source version system) + "Register a Cuirass job a list building the modular Guix derivation from +SOURCE for SYSTEM. Use VERSION as the version identifier." + (define build + (primitive-load (string-append source "/build-aux/build-self.scm"))) + + (let ((name (string-append "guix." system)) + (drv (run-with-store store + (build source #:version version #:system system + #:pull-version 1 + #:guile-version "2.2")))) + (register name + #: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)))) + +(define (cuirass-jobs store arguments register) + "Return Cuirass 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 + (assq-ref arguments 'guix-modular)) + + (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) -(include "../hydra/guix-modular.scm") -(include "hydra-to-cuirass.scm") + (for-each (lambda (system) + (build-job store register file version system)) + systems))) 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 -;;; -;;; 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 . - -;;; -;;; 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/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 -;;; Copyright © 2017 Jan Nieuwenhuizen -;;; Copyright © 2018, 2019 Clément Lassieur -;;; -;;; 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 . - -;;; -;;; 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 -;;; -;;; 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 . - -;;; -;;; 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 -;;; -;;; 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 . - -;;; -;;; 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/gnu/ci.scm b/gnu/ci.scm index 96bff64875..80c1553916 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2018, 2019 Clément Lassieur ;;; Copyright © 2020 Julien Lepiller -;;; Copyright © 2020 Mathieu Othacehe +;;; Copyright © 2020, 2021 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -64,67 +64,70 @@ #: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 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) - "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)))) - -(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?))))) +(define* (register-job-from-drv store drv + #:key + name + register + period + (max-silent-time 3600) + (timeout 3600)) + "Register DRV in Cuirass by calling the REGISTER procedure." + ;; See "register-job" procedure in the (cuirass jobs) module. + (register name + #: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) + #:period period + #:max-silent-time max-silent-time + #:timeout timeout)) + +(define* (package-job store job-name register package system + #:key cross? target) + "Register a job called JOB-NAME that builds PACKAGE on 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))) + (register-job-from-drv store drv + #:name job-name + #:register register + #:max-silent-time max-silent-time + #:timeout timeout))))) + +(define (package-cross-job store job-name register package target system) + "Register a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET +on SYSTEM." + (let ((name (string-append target "." job-name "." system))) + (package-job store name register package system + #:cross? #t + #:target target))) (define %core-packages ;; Note: Don't put the '-final' package variants because (1) that's @@ -157,8 +160,8 @@ SYSTEM." "i686-w64-mingw32" "x86_64-w64-mingw32")) -(define (cross-jobs store system) - "Return a list of cross-compilation jobs for SYSTEM." +(define (cross-jobs store register system) + "Register a list of cross-compilation jobs for SYSTEM." (define (from-32-to-64? target) ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to @@ -192,13 +195,14 @@ SYSTEM." (lambda (x) (or (proc1 x) (proc2 x) (proc3 x)))) - (append-map (lambda (target) - (map (lambda (package) - (package-cross-job store (job-name package) - package target system)) - (packages-to-cross-build target))) - (remove (either from-32-to-64? same? pointless?) - %cross-targets))) + (for-each (lambda (target) + (for-each (lambda (package) + (package-cross-job store (job-name package) + register package + target system)) + (packages-to-cross-build target))) + (remove (either from-32-to-64? same? pointless?) + %cross-targets))) ;; Architectures that are able to build or cross-build Guix System images. ;; This does not mean that other architectures are not supported, only that @@ -215,36 +219,17 @@ SYSTEM." (define (hours hours) (* 3600 hours)) -(define (image-jobs store system) +(define (image-jobs store register 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)) + (register-job-from-drv store drv + #:name name + #:register register + #:period (hours 48))))) (define (build-image image) (run-with-store store @@ -256,25 +241,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) '())) '())) @@ -319,122 +305,85 @@ system.") (native-inputs '()) (propagated-inputs '()))) -(define* (system-test-jobs store system +(define* (system-test-jobs store register 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"))))) - + "Register a list of jobs for the system tests." (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. + (register-job-from-drv store drv + #:name name + #:register register + #: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))) + (for-each ->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)))) - +(define (tarball-jobs store register system) + "Register 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)) + (register-job-from-drv store drv + #:name name + #:register register + #: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)))) + (->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) + (lambda (store register 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 system)) + (package-job store (string-append "base." (job-name package)) + register package system)) ((supported-package? package system) (let ((drv (package-derivation store package system #:graft? #f))) (and (substitutable-derivation? drv) (package-job store (job-name package) - package system)))) + register package system)))) (else #f))))) @@ -497,11 +446,11 @@ Return #f if no such checkout is found." ;;; -;;; Hydra entry point. +;;; Cuirass entry point. ;;; -(define (hydra-jobs store arguments) - "Return Hydra jobs." +(define (cuirass-jobs store arguments register) + "Register Cuirass jobs." (define subset (match (assoc-ref arguments 'subset) ("core" 'core) ; only build core packages @@ -529,55 +478,57 @@ Return #f if no such checkout is found." ;; 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))) + (for-each (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 register + package system)))) + (filter-map job all) + (image-jobs store register system) + (system-test-jobs store register system + #:source source + #:commit commit) + (tarball-jobs store register system) + (cross-jobs store register system))) + ((core) + ;; Build core packages only. + (begin + (for-each (lambda (package) + (package-job store (job-name package) + register package system)) + %core-packages) + (cross-jobs store register system))) + ((hello) + ;; Build hello package only. + (let ((hello (specification->package "hello"))) + (list (package-job store (job-name hello) + register hello system)))) + ((list) + ;; Build selected list of packages only. + (let* ((names (assoc-ref arguments 'subset)) + (packages (map specification->package names))) + (for-each (lambda (package) + (package-job store (job-name package) + register package system)) + packages))) + ((manifests) + ;; Build packages in the list of manifests. + (let* ((manifests (arguments->manifests arguments)) + (packages (manifests->packages store manifests))) + (for-each (lambda (package) + (package-job store (job-name package) + register package system)) + packages))) + (else + (error "unknown subset" subset)))) + systems))) -- 2.24.0