X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/bb4674b43fa413a6d41694b2093c3b00d11eea47..12580eb435b4a43be76ad3b900657ec67a70fee7:/gnu/ci.scm diff --git a/gnu/ci.scm b/gnu/ci.scm index 44a6a87e1a..96bff64875 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -1,7 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès -;;; Copyright © 2017 Jan Nieuwenhuizen +;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2018, 2019 Clément Lassieur +;;; Copyright © 2020 Julien Lepiller +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +27,7 @@ #:use-module (guix profiles) #:use-module (guix packages) #:use-module (guix channels) + #:use-module (guix config) #:use-module (guix derivations) #:use-module (guix build-system) #:use-module (guix monads) @@ -38,6 +41,7 @@ #:select (lookup-compressor self-contained-tarball)) #:use-module (gnu bootloader) #:use-module (gnu bootloader u-boot) + #:use-module (gnu image) #:use-module (gnu packages) #:use-module (gnu packages gcc) #:use-module (gnu packages base) @@ -49,8 +53,13 @@ #:use-module (gnu packages make-bootstrap) #:use-module (gnu packages package-management) #:use-module (gnu system) + #:use-module (gnu system image) #:use-module (gnu system vm) #:use-module (gnu system install) + #:use-module (gnu system images hurd) + #:use-module (gnu system images novena) + #:use-module (gnu system images pine64) + #:use-module (gnu system images pinebook-pro) #:use-module (gnu tests) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -70,28 +79,36 @@ #:optional (package-derivation package-derivation)) "Convert PACKAGE to an alist suitable for Hydra." (parameterize ((%graft? #f)) - `((derivation . ,(derivation-file-name - (package-derivation store package system - #:graft? #f))) - (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 + (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." @@ -113,7 +130,7 @@ SYSTEM." ;; Note: Don't put the '-final' package variants because (1) that's ;; implicit, and (2) they cannot be cross-built (due to the explicit input ;; chain.) - (list gcc-4.8 gcc-4.9 gcc-5 glibc binutils + (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils gmp mpfr mpc coreutils findutils diffutils patch sed grep gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz %bootstrap-binaries-tarball @@ -123,12 +140,15 @@ SYSTEM." %guile-bootstrap-tarball %bootstrap-tarballs)) -(define %packages-to-cross-build - %core-packages) +(define (packages-to-cross-build target) + "Return the list of packages to cross-build for TARGET." + ;; Don't cross-build the bootstrap tarballs for MinGW. + (if (string-contains target "mingw") + (drop-right %core-packages 6) + %core-packages)) (define %cross-targets '("mips64el-linux-gnu" - "mips64el-linux-gnuabi64" "arm-linux-gnueabihf" "aarch64-linux-gnu" "powerpc-linux-gnu" @@ -176,25 +196,45 @@ SYSTEM." (map (lambda (package) (package-cross-job store (job-name package) package target system)) - %packages-to-cross-build)) + (packages-to-cross-build target))) (remove (either from-32-to-64? same? pointless?) %cross-targets))) -(define %guixsd-supported-systems - '("x86_64-linux" "i686-linux" "armhf-linux")) - -(define %u-boot-systems - '("armhf-linux")) - -(define (qemu-jobs store system) - "Return a list of jobs that build QEMU images for SYSTEM." +;; 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. +(define %guix-system-supported-systems + '("x86_64-linux" "i686-linux")) + +(define %guix-system-images + (list hurd-barebones-qcow2-image + pine64-barebones-raw-image + pinebook-pro-barebones-raw-image + novena-barebones-raw-image)) + +(define (hours hours) + (* 3600 hours)) + +(define (image-jobs store 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)) - (description . "Stand-alone QEMU image of the GNU system") - (long-description . "This is a demo stand-alone QEMU image of the GNU + (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+)) - (max-silent-time . 600) + (period . ,(hours 48)) + (max-silent-time . 3600) (timeout . 3600) (home-page . ,%guix-home-page-url) (maintainers . ("bug-guix@gnu.org")))) @@ -206,36 +246,37 @@ system.") (parameterize ((%graft? #f)) (->alist drv)))))) + (define (build-image image) + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (lower-object (system-image image))))) + (define MiB (expt 2 20)) - (if (member system %guixsd-supported-systems) - (if (member system %u-boot-systems) - (list (->job 'flash-image - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (system-disk-image - (operating-system (inherit installation-os) - (bootloader (bootloader-configuration - (bootloader u-boot-bootloader) - (target #f)))) - #:disk-image-size - (* 1500 MiB)))))) - (list (->job 'usb-image - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (system-disk-image installation-os - #:disk-image-size - (* 1500 MiB))))) - (->job 'iso9660-image - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (system-disk-image installation-os - #:file-system-type - "iso9660")))))) + (if (member system %guix-system-supported-systems) + `(,(->job 'usb-image + (build-image + (image + (inherit efi-disk-image) + (operating-system installation-os)))) + ,(->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)))) + (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))) + %guix-system-images) + '())) '())) (define channel-build-system @@ -291,12 +332,24 @@ system.") (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+)) - (max-silent-time . 600) + (period . ,(hours 48)) + (max-silent-time . 3600) (timeout . 3600) (home-page . ,%guix-home-page-url) (maintainers . ("bug-guix@gnu.org"))))) @@ -307,11 +360,7 @@ system.") "." system)))) (cons name (test->thunk test)))) - (if (and (member system %guixsd-supported-systems) - - ;; XXX: Our build farm has too few ARMv7 machines and they are very - ;; slow, so skip system tests there. - (not (string=? system "armhf-linux"))) + (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 @@ -325,12 +374,21 @@ 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")))) + (maintainers . ("bug-guix@gnu.org")) + (period . ,(hours 24)))) (define (->job name drv) (let ((name (symbol-append name (string->symbol ".") @@ -354,8 +412,7 @@ all its dependencies, and ready to be installed on \"foreign\" distributions.") (define job-name ;; Return the name of a package's job. - (compose string->symbol - (cut package-full-name <> "-"))) + (compose string->symbol package-name)) (define package->job (let ((base-packages @@ -488,7 +545,7 @@ Return #f if no such checkout is found." (package->job store package system)))) (append (filter-map job all) - (qemu-jobs store system) + (image-jobs store system) (system-test-jobs store system #:source source #:commit commit) @@ -503,20 +560,16 @@ Return #f if no such checkout is found." (cross-jobs store system))) ((hello) ;; Build hello package only. - (if (string=? system (%current-system)) - (let ((hello (specification->package "hello"))) - (list (package-job store (job-name hello) hello system))) - '())) + (let ((hello (specification->package "hello"))) + (list (package-job store (job-name hello) hello system)))) ((list) ;; Build selected list of packages only. - (if (string=? system (%current-system)) - (let* ((names (assoc-ref arguments 'subset)) - (packages (map specification->package names))) - (map (lambda (package) - (package-job store (job-name package) - package system)) - packages)) - '())) + (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))