;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; 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>
;;;
;;; This file is part of GNU Guix.
;;;
#: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)
#: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)
#: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 pine64)
#:use-module (gnu tests)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (channel-source->package
+ #:export (%cross-targets
+ channel-source->package
hydra-jobs))
;;; Commentary:
#: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 <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
+ (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))
+ (license . ,(and=> (package-license package) license-name))
+ (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."
;; 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
%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"
(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"))
+;; 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 %u-boot-systems
- '("armhf-linux"))
+(define %guix-system-images
+ (list hurd-barebones-qcow2-image
+ pine64-barebones-raw-image))
-(define (qemu-jobs store system)
- "Return a list of jobs that build QEMU images for SYSTEM."
+(define (image-jobs store system)
+ "Return a list of jobs that build images for SYSTEM."
(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)
(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
#:key source commit system
#:allow-other-keys)
(run-with-store store
- (mlet* %store-monad ((source (lower-object source))
+ ;; SOURCE can be a lowerable object such as <local-file>
+ ;; or a file name. Adjust accordingly.
+ (mlet* %store-monad ((source (if (string? source)
+ (return source)
+ (lower-object source)))
(instance
-> (checkout->channel-instance
source #:commit commit)))
(system-test-value test))))
`((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))
"." 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
"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.")
(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)
(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))
HCoop / jackhill / guix / guix.git / blobdiff