[jackhill/guix/guix.git] / gnu / ci.scm

;;; 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, 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, 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/>.

(define-module (gnu ci)
  #:use-module (guix channels)
  #:use-module (guix config)
  #:use-module (guix describe)
  #:use-module (guix store)
  #:use-module (guix grafts)
  #: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)
  #:use-module (guix gexp)
  #:use-module (guix ui)
  #:use-module ((guix licenses)
                #:select (gpl3+ license? license-name))
  #:use-module ((guix utils) #:select (%current-system))
  #:use-module ((guix scripts system) #:select (read-operating-system))
  #:use-module ((guix scripts pack)
                #: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 gawk)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages multiprecision)
  #: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)
  #:use-module (ice-9 match)
  #:export (%core-packages
            %cross-targets
            channel-source->package
            cuirass-jobs))

;;; Commentary:
;;;
;;; This file defines build jobs for Cuirass.
;;;
;;; Code:

(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 (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."
  (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
  ;; implicit, and (2) they cannot be cross-built (due to the explicit input
  ;; chain.)
  (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
        %binutils-bootstrap-tarball
        (%glibc-bootstrap-tarball)
        %gcc-bootstrap-tarball
        %guile-bootstrap-tarball
        %bootstrap-tarballs))

(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"
    "arm-linux-gnueabihf"
    "aarch64-linux-gnu"
    "powerpc-linux-gnu"
    "riscv64-linux-gnu"
    "i586-pc-gnu"                                 ;aka. GNU/Hurd
    "i686-w64-mingw32"
    "x86_64-w64-mingw32"))

(define (cross-jobs store system)
  "Return 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
    ;; mips64el-linux-gnuabi64.
    (and (or (string-prefix? "i686-" system)
             (string-prefix? "i586-" system)
             (string-prefix? "armhf-" system))
         (string-contains target "64")))    ;x86_64, mips64el, aarch64, etc.

  (define (same? target)
    ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
    ;; don't try to cross-compile to 'mips64el-linux-gnu' from
    ;; 'mips64el-linux'.
    (or (string-contains target system)
        (and (string-prefix? "armhf" system)    ;armhf-linux
             (string-prefix? "arm" target))))   ;arm-linux-gnueabihf

  (define (pointless? target)
    ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
    (match system
      ((or "x86_64-linux" "i686-linux")
       (if (string-contains target "mingw")
           (not (string=? "x86_64-linux" system))
           #f))
      (_
       ;; Don't try to cross-compile from non-Intel platforms: this isn't
       ;; very useful and these are often brittle configurations.
       #t)))

  (define (either proc1 proc2 proc3)
    (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)))

(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.
(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 (->job name 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
      (mbegin %store-monad
        (set-guile-for-build (default-guile))
        (lower-object (system-image image)))))

  (define MiB
    (expt 2 20))

  (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 (symbol->string (image-name image))
                            (build-image image)))
                   %guix-system-images)
              '()))
      '()))

(define channel-build-system
  ;; Build system used to "convert" a channel instance to a package.
  (let* ((build (lambda* (store name inputs
                                #:key source commit system
                                #:allow-other-keys)
                  (run-with-store store
                    ;; 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)))
                      (channel-instances->derivation (list instance)))
                    #:system system)))
         (lower (lambda* (name #:key system source commit
                               #:allow-other-keys)
                  (bag
                    (name name)
                    (system system)
                    (build build)
                    (arguments `(#:source ,source
                                 #:commit ,commit))))))
    (build-system (name 'channel)
                  (description "Turn a channel instance into a package.")
                  (lower lower))))

(define* (channel-source->package source #:key commit)
  "Return a package for the given channel SOURCE, a lowerable object."
  (package
    (inherit guix)
    (version (string-append (package-version guix) "+"))
    (build-system channel-build-system)
    (arguments `(#:source ,source
                 #:commit ,commit))
    (inputs '())
    (native-inputs '())
    (propagated-inputs '())))

(define* (system-test-jobs store system
                           #:key source commit)
  "Return a list of jobs for the system tests."
  (define (->job 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.
      (map ->job (all-system-tests))
      '()))

(define (tarball-jobs store system)
  "Return jobs to build the self-contained Guix binary tarball."
  (define (->job name 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))))

(define job-name
  ;; Return the name of a package's job.
  package-name)

(define package->job
  (let ((base-packages
         (delete-duplicates
          (append-map (match-lambda
                        ((_ 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 (string-append "base." (job-name package))
                          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))))
            (else
             #f)))))

(define (all-packages)
  "Return the list of packages to build."
  (define (adjust package result)
    (cond ((package-replacement package)
           ;; XXX: If PACKAGE and its replacement have the same name/version,
           ;; then both Cuirass jobs will have the same name, which
           ;; effectively means that the second one will be ignored.  Thus,
           ;; return the replacement first.
           (cons* (package-replacement package)   ;build both
                  package
                  result))
          ((package-superseded package)
           result)                                ;don't build it
          (else
           (cons package result))))

  (fold-packages adjust
                 (fold adjust '()                 ;include base packages
                       (match (%final-inputs)
                         (((labels packages _ ...) ...)
                          packages)))
                 #:select? (const #t)))           ;include hidden packages

(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
         ((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."
  (define (load-manifest manifest)
    (save-module-excursion
     (lambda ()
       (set-current-module (make-user-module '((guix profiles) (gnu))))
       (primitive-load manifest))))

  (delete-duplicates!
   (map manifest-entry-item
        (append-map (compose manifest-entries
                             load-manifest)
                    manifests))))

\f
;;;
;;; Cuirass entry point.
;;;

(define (cuirass-jobs store arguments)
  "Register Cuirass jobs."
  (define subset
    (assoc-ref arguments 'subset))

  (define systems
    (match (assoc-ref arguments 'systems)
      (#f              %cuirass-supported-systems)
      ((lst ...)       lst)
      ((? string? str) (call-with-input-string str read))))

  (define channels
    (let ((channels (assq-ref arguments 'channels)))
      (map sexp->channel channels)))

  (define guix
    (find guix-channel? channels))

  (define commit
    (channel-commit guix))

  (define source
    (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!)
       (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))))
         (('channels . channels)
          ;; Build only the packages from CHANNELS.
          (let ((all (all-packages)))
            (filter-map
             (lambda (package)
               (match (package-channels package)
                 ((channel . _)
                  (and (member (channel-name channel) channels)
                       (package->job store package system)))
                 (else #f)))
             all)))
         (('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)))
Commit	Line	Data
59fb5c1c	1	;;; GNU Guix --- Functional package management for GNU
2032d847	2	;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
db2785cd	3	;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
f71b0a00	4	;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
f43ec1c5	5	;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
76bea3f8	6	;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
59fb5c1c LC	7	;;;
	8	;;; This file is part of GNU Guix.
	9	;;;
	10	;;; GNU Guix is free software; you can redistribute it and/or modify it
	11	;;; under the terms of the GNU General Public License as published by
	12	;;; the Free Software Foundation; either version 3 of the License, or (at
	13	;;; your option) any later version.
	14	;;;
	15	;;; GNU Guix is distributed in the hope that it will be useful, but
	16	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;;; GNU General Public License for more details.
	19	;;;
	20	;;; You should have received a copy of the GNU General Public License
	21	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	22
	23	(define-module (gnu ci)
76bea3f8	24	#:use-module (guix channels)
59fb5c1c	25	#:use-module (guix config)
61a11653	26	#:use-module (guix describe)
59fb5c1c LC	27	#:use-module (guix store)
	28	#:use-module (guix grafts)
	29	#:use-module (guix profiles)
	30	#:use-module (guix packages)
7e6d8d36	31	#:use-module (guix channels)
f43ec1c5	32	#:use-module (guix config)
59fb5c1c	33	#:use-module (guix derivations)
7e6d8d36	34	#:use-module (guix build-system)
59fb5c1c	35	#:use-module (guix monads)
dd1ee160	36	#:use-module (guix gexp)
59fb5c1c	37	#:use-module (guix ui)
b5f8c2c8 LC	38	#:use-module ((guix licenses)
b5f8c2c8 LC	39	#:select (gpl3+ license? license-name))
59fb5c1c LC	40	#:use-module ((guix utils) #:select (%current-system))
	41	#:use-module ((guix scripts system) #:select (read-operating-system))
	42	#:use-module ((guix scripts pack)
	43	#:select (lookup-compressor self-contained-tarball))
	44	#:use-module (gnu bootloader)
	45	#:use-module (gnu bootloader u-boot)
f19cf27c	46	#:use-module (gnu image)
59fb5c1c LC	47	#:use-module (gnu packages)
	48	#:use-module (gnu packages gcc)
	49	#:use-module (gnu packages base)
	50	#:use-module (gnu packages gawk)
	51	#:use-module (gnu packages guile)
	52	#:use-module (gnu packages gettext)
	53	#:use-module (gnu packages compression)
	54	#:use-module (gnu packages multiprecision)
	55	#:use-module (gnu packages make-bootstrap)
	56	#:use-module (gnu packages package-management)
	57	#:use-module (gnu system)
f19cf27c	58	#:use-module (gnu system image)
59fb5c1c LC	59	#:use-module (gnu system vm)
59fb5c1c LC	60	#:use-module (gnu system install)
b06ba9e0	61	#:use-module (gnu system images hurd)
846e5240	62	#:use-module (gnu system images novena)
8a4f1eef	63	#:use-module (gnu system images pine64)
17d9a91e	64	#:use-module (gnu system images pinebook-pro)
59fb5c1c LC	65	#:use-module (gnu tests)
	66	#:use-module (srfi srfi-1)
	67	#:use-module (srfi srfi-26)
	68	#:use-module (ice-9 match)
76bea3f8 MO	69	#:export (%core-packages
76bea3f8 MO	70	%cross-targets
f292c501	71	channel-source->package
76bea3f8	72	cuirass-jobs))
59fb5c1c LC	73
	74	;;; Commentary:
	75	;;;
76bea3f8	76	;;; This file defines build jobs for Cuirass.
59fb5c1c LC	77	;;;
	78	;;; Code:
	79
76bea3f8 MO	80	(define* (derivation->job name drv
	81	#:key
	82	period
	83	(max-silent-time 3600)
	84	(timeout 3600))
	85	"Return a Cuirass job called NAME and describing DRV. PERIOD is the minimal
	86	duration that must separate two evaluations of the same job. If PERIOD is
	87	false, then the job will be evaluated as soon as possible.
	88
	89	MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
	90	building the derivation."
	91	`((#:job-name . ,name)
	92	(#:derivation . ,(derivation-file-name drv))
	93	(#:outputs . ,(filter-map
	94	(lambda (res)
	95	(match res
	96	((name . path)
	97	`(,name . ,path))))
	98	(derivation->output-paths drv)))
	99	(#:nix-name . ,(derivation-name drv))
	100	(#:system . ,(derivation-system drv))
	101	(#:period . ,period)
	102	(#:max-silent-time . ,max-silent-time)
	103	(#:timeout . ,timeout)))
	104
	105	(define* (package-job store job-name package system
	106	#:key cross? target)
59fb5c1c	107	"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
76bea3f8 MO	108	(let ((job-name (string-append job-name "." system)))
	109	(parameterize ((%graft? #f))
	110	(let* ((drv (if cross?
	111	(package-cross-derivation store package target system
	112	#:graft? #f)
	113	(package-derivation store package system
	114	#:graft? #f)))
	115	(max-silent-time (or (assoc-ref (package-properties package)
	116	'max-silent-time)
	117	3600))
	118	(timeout (or (assoc-ref (package-properties package)
	119	'timeout)
	120	72000)))
	121	(derivation->job job-name drv
	122	#:max-silent-time max-silent-time
	123	#:timeout timeout)))))
59fb5c1c LC	124
	125	(define (package-cross-job store job-name package target system)
	126	"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
	127	SYSTEM."
76bea3f8 MO	128	(let ((name (string-append target "." job-name "." system)))
	129	(package-job store name package system
	130	#:cross? #t
	131	#:target target)))
59fb5c1c LC	132
	133	(define %core-packages
	134	;; Note: Don't put the '-final' package variants because (1) that's
	135	;; implicit, and (2) they cannot be cross-built (due to the explicit input
	136	;; chain.)
84f38f03	137	(list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
59fb5c1c LC	138	gmp mpfr mpc coreutils findutils diffutils patch sed grep
	139	gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
	140	%bootstrap-binaries-tarball
	141	%binutils-bootstrap-tarball
	142	(%glibc-bootstrap-tarball)
	143	%gcc-bootstrap-tarball
	144	%guile-bootstrap-tarball
	145	%bootstrap-tarballs))
	146
668a5198 LC	147	(define (packages-to-cross-build target)
	148	"Return the list of packages to cross-build for TARGET."
	149	;; Don't cross-build the bootstrap tarballs for MinGW.
	150	(if (string-contains target "mingw")
	151	(drop-right %core-packages 6)
	152	%core-packages))
59fb5c1c LC	153
	154	(define %cross-targets
	155	'("mips64el-linux-gnu"
59fb5c1c LC	156	"arm-linux-gnueabihf"
	157	"aarch64-linux-gnu"
	158	"powerpc-linux-gnu"
2032d847	159	"riscv64-linux-gnu"
59fb5c1c	160	"i586-pc-gnu" ;aka. GNU/Hurd
67dac6b8 CD	161	"i686-w64-mingw32"
67dac6b8 CD	162	"x86_64-w64-mingw32"))
59fb5c1c	163
3046e73b LC	164	(define (cross-jobs store system)
	165	"Return a list of cross-compilation jobs for SYSTEM."
	166	(define (from-32-to-64? target)
	167	;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
	168	;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
	169	;; mips64el-linux-gnuabi64.
	170	(and (or (string-prefix? "i686-" system)
	171	(string-prefix? "i586-" system)
	172	(string-prefix? "armhf-" system))
	173	(string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
	174
	175	(define (same? target)
	176	;; Return true if SYSTEM and TARGET are the same thing. This is so we
	177	;; don't try to cross-compile to 'mips64el-linux-gnu' from
	178	;; 'mips64el-linux'.
	179	(or (string-contains target system)
	180	(and (string-prefix? "armhf" system) ;armhf-linux
	181	(string-prefix? "arm" target)))) ;arm-linux-gnueabihf
	182
	183	(define (pointless? target)
	184	;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
	185	(match system
	186	((or "x86_64-linux" "i686-linux")
	187	(if (string-contains target "mingw")
	188	(not (string=? "x86_64-linux" system))
	189	#f))
	190	(_
	191	;; Don't try to cross-compile from non-Intel platforms: this isn't
	192	;; very useful and these are often brittle configurations.
	193	#t)))
	194
	195	(define (either proc1 proc2 proc3)
	196	(lambda (x)
	197	(or (proc1 x) (proc2 x) (proc3 x))))
	198
	199	(append-map (lambda (target)
	200	(map (lambda (package)
	201	(package-cross-job store (job-name package)
	202	package target system))
50b99c90	203	(packages-to-cross-build target)))
3046e73b LC	204	(remove (either from-32-to-64? same? pointless?)
	205	%cross-targets)))
	206
76bea3f8 MO	207	(define* (guix-jobs store systems #:key source commit)
	208	"Return a list of jobs for Guix itself."
	209	(define build
	210	(primitive-load (string-append source "/build-aux/build-self.scm")))
	211
	212	(map
	213	(lambda (system)
	214	(let ((name (string->symbol
	215	(string-append "guix." system)))
	216	(drv (run-with-store store
	217	(build source #:version commit #:system system
	218	#:pull-version 1
	219	#:guile-version "2.2"))))
	220	(derivation->job name drv)))
	221	systems))
	222
b06ba9e0 MO	223	;; Architectures that are able to build or cross-build Guix System images.
	224	;; This does not mean that other architectures are not supported, only that
	225	;; they are often not fast enough to support Guix System images building.
	226	(define %guix-system-supported-systems
	227	'("x86_64-linux" "i686-linux"))
59fb5c1c	228
b06ba9e0	229	(define %guix-system-images
8a4f1eef	230	(list hurd-barebones-qcow2-image
17d9a91e	231	pine64-barebones-raw-image
846e5240 DM	232	pinebook-pro-barebones-raw-image
846e5240 DM	233	novena-barebones-raw-image))
59fb5c1c	234
fc2fa7ad MO	235	(define (hours hours)
	236	(* 3600 hours))
	237
b06ba9e0	238	(define (image-jobs store system)
fc2fa7ad MO	239	"Return a list of jobs that build images for SYSTEM. Those jobs are
	240	expensive in storage and I/O operations, hence their periodicity is limited by
	241	passing the PERIOD argument."
59fb5c1c	242	(define (->job name drv)
76bea3f8 MO	243	(let ((name (string-append name "." system)))
	244	(parameterize ((%graft? #f))
	245	(derivation->job name drv
	246	#:period (hours 48)))))
59fb5c1c	247
b06ba9e0 MO	248	(define (build-image image)
	249	(run-with-store store
	250	(mbegin %store-monad
	251	(set-guile-for-build (default-guile))
	252	(lower-object (system-image image)))))
	253
59fb5c1c LC	254	(define MiB
	255	(expt 2 20))
	256
b06ba9e0	257	(if (member system %guix-system-supported-systems)
76bea3f8	258	`(,(->job "usb-image"
b06ba9e0 MO	259	(build-image
	260	(image
	261	(inherit efi-disk-image)
b06ba9e0	262	(operating-system installation-os))))
76bea3f8	263	,(->job "iso9660-image"
b06ba9e0 MO	264	(build-image
b06ba9e0 MO	265	(image
f43ec1c5	266	(inherit (image-with-label
76bea3f8 MO	267	iso9660-image
	268	(string-append "GUIX_" system "_"
	269	(if (> (string-length %guix-version) 7)
	270	(substring %guix-version 0 7)
	271	%guix-version))))
b06ba9e0 MO	272	(operating-system installation-os))))
	273	;; Only cross-compile Guix System images from x86_64-linux for now.
	274	,@(if (string=? system "x86_64-linux")
	275	(map (lambda (image)
76bea3f8 MO	276	(->job (symbol->string (image-name image))
76bea3f8 MO	277	(build-image image)))
b06ba9e0 MO	278	%guix-system-images)
b06ba9e0 MO	279	'()))
1189f405	280	'()))
59fb5c1c	281
7e6d8d36 LC	282	(define channel-build-system
	283	;; Build system used to "convert" a channel instance to a package.
	284	(let* ((build (lambda* (store name inputs
dd1ee160	285	#:key source commit system
c3ab921e	286	#:allow-other-keys)
7e6d8d36	287	(run-with-store store
bc8b2ffd LC	288	;; SOURCE can be a lowerable object such as <local-file>
	289	;; or a file name. Adjust accordingly.
	290	(mlet* %store-monad ((source (if (string? source)
	291	(return source)
	292	(lower-object source)))
dd1ee160 LC	293	(instance
	294	-> (checkout->channel-instance
	295	source #:commit commit)))
	296	(channel-instances->derivation (list instance)))
c3ab921e	297	#:system system)))
dd1ee160 LC	298	(lower (lambda* (name #:key system source commit
dd1ee160 LC	299	#:allow-other-keys)
7e6d8d36 LC	300	(bag
	301	(name name)
	302	(system system)
	303	(build build)
dd1ee160 LC	304	(arguments `(#:source ,source
dd1ee160 LC	305	#:commit ,commit))))))
7e6d8d36 LC	306	(build-system (name 'channel)
	307	(description "Turn a channel instance into a package.")
	308	(lower lower))))
	309
dd1ee160 LC	310	(define* (channel-source->package source #:key commit)
dd1ee160 LC	311	"Return a package for the given channel SOURCE, a lowerable object."
7e6d8d36 LC	312	(package
7e6d8d36 LC	313	(inherit guix)
dd1ee160	314	(version (string-append (package-version guix) "+"))
7e6d8d36	315	(build-system channel-build-system)
dd1ee160 LC	316	(arguments `(#:source ,source
dd1ee160 LC	317	#:commit ,commit))
7e6d8d36 LC	318	(inputs '())
	319	(native-inputs '())
	320	(propagated-inputs '())))
	321
	322	(define* (system-test-jobs store system
	323	#:key source commit)
59fb5c1c	324	"Return a list of jobs for the system tests."
59fb5c1c	325	(define (->job test)
76bea3f8 MO	326	(parameterize ((current-guix-package
	327	(channel-source->package source #:commit commit)))
	328	(let ((name (string-append "test." (system-test-name test)
	329	"." system))
	330	(drv (run-with-store store
	331	(mbegin %store-monad
	332	(set-current-system system)
	333	(set-grafting #f)
	334	(set-guile-for-build (default-guile))
	335	(system-test-value test)))))
	336
	337	;; Those tests are extremely expensive in I/O operations and storage
	338	;; size, use the "period" attribute to run them with a period of at
	339	;; least 48 hours.
	340	(derivation->job name drv
	341	#:period (hours 24)))))
59fb5c1c	342
b06ba9e0	343	(if (member system %guix-system-supported-systems)
7e6d8d36 LC	344	;; Override the value of 'current-guix' used by system tests. Using a
	345	;; channel instance makes tests that rely on 'current-guix' less
	346	;; expensive. It also makes sure we get a valid Guix package when this
	347	;; code is not running from a checkout.
76bea3f8	348	(map ->job (all-system-tests))
59fb5c1c LC	349	'()))
	350
	351	(define (tarball-jobs store system)
76bea3f8	352	"Return jobs to build the self-contained Guix binary tarball."
59fb5c1c	353	(define (->job name drv)
76bea3f8 MO	354	(let ((name (string-append name "." system)))
	355	(parameterize ((%graft? #f))
	356	(derivation->job name drv
	357	#:period (hours 24)))))
59fb5c1c LC	358
59fb5c1c LC	359	;; XXX: Add a job for the stable Guix?
76bea3f8 MO	360	(list
	361	(->job "binary-tarball"
	362	(run-with-store store
	363	(mbegin %store-monad
	364	(set-guile-for-build (default-guile))
	365	(>>= (profile-derivation (packages->manifest (list guix)))
	366	(lambda (profile)
	367	(self-contained-tarball "guix-binary" profile
	368	#:localstatedir? #t
	369	#:compressor
	370	(lookup-compressor "xz")))))
	371	#:system system))))
59fb5c1c LC	372
	373	(define job-name
	374	;; Return the name of a package's job.
76bea3f8	375	package-name)
59fb5c1c LC	376
	377	(define package->job
	378	(let ((base-packages
	379	(delete-duplicates
	380	(append-map (match-lambda
76bea3f8 MO	381	((_ package _ ...)
	382	(match (package-transitive-inputs package)
	383	(((_ inputs _ ...) ...)
	384	inputs))))
59fb5c1c LC	385	(%final-inputs)))))
	386	(lambda (store package system)
	387	"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
	388	valid."
	389	(cond ((member package base-packages)
76bea3f8	390	(package-job store (string-append "base." (job-name package))
59fb5c1c LC	391	package system))
	392	((supported-package? package system)
	393	(let ((drv (package-derivation store package system
	394	#:graft? #f)))
	395	(and (substitutable-derivation? drv)
	396	(package-job store (job-name package)
	397	package system))))
	398	(else
	399	#f)))))
	400
	401	(define (all-packages)
	402	"Return the list of packages to build."
	403	(define (adjust package result)
	404	(cond ((package-replacement package)
f00ff8db LC	405	;; XXX: If PACKAGE and its replacement have the same name/version,
	406	;; then both Cuirass jobs will have the same name, which
	407	;; effectively means that the second one will be ignored. Thus,
	408	;; return the replacement first.
	409	(cons* (package-replacement package) ;build both
	410	package
59fb5c1c LC	411	result))
	412	((package-superseded package)
	413	result) ;don't build it
	414	(else
	415	(cons package result))))
	416
	417	(fold-packages adjust
	418	(fold adjust '() ;include base packages
	419	(match (%final-inputs)
	420	(((labels packages _ ...) ...)
	421	packages)))
	422	#:select? (const #t))) ;include hidden packages
	423
76bea3f8	424	(define (arguments->manifests arguments channels)
59fb5c1c	425	"Return the list of manifests extracted from ARGUMENTS."
76bea3f8 MO	426	(define (channel-name->checkout name)
	427	(let ((channel (find (lambda (channel)
	428	(eq? (channel-name channel) name))
	429	channels)))
	430	(channel-url channel)))
	431
59fb5c1c	432	(map (match-lambda
76bea3f8 MO	433	((name . path)
	434	(let ((checkout (channel-name->checkout name)))
	435	(in-vicinity checkout path))))
	436	arguments))
59fb5c1c LC	437
	438	(define (manifests->packages store manifests)
	439	"Return the list of packages found in MANIFESTS."
	440	(define (load-manifest manifest)
	441	(save-module-excursion
	442	(lambda ()
	443	(set-current-module (make-user-module '((guix profiles) (gnu))))
	444	(primitive-load manifest))))
	445
	446	(delete-duplicates!
	447	(map manifest-entry-item
	448	(append-map (compose manifest-entries
	449	load-manifest)
	450	manifests))))
	451
	452	\f
	453	;;;
76bea3f8	454	;;; Cuirass entry point.
59fb5c1c LC	455	;;;
59fb5c1c LC	456
76bea3f8 MO	457	(define (cuirass-jobs store arguments)
76bea3f8 MO	458	"Register Cuirass jobs."
59fb5c1c	459	(define subset
76bea3f8	460	(assoc-ref arguments 'subset))
59fb5c1c LC	461
	462	(define systems
	463	(match (assoc-ref arguments 'systems)
76bea3f8	464	(#f %cuirass-supported-systems)
59fb5c1c LC	465	((lst ...) lst)
	466	((? string? str) (call-with-input-string str read))))
	467
76bea3f8 MO	468	(define channels
	469	(let ((channels (assq-ref arguments 'channels)))
	470	(map sexp->channel channels)))
	471
	472	(define guix
	473	(find guix-channel? channels))
7e6d8d36 LC	474
7e6d8d36 LC	475	(define commit
76bea3f8	476	(channel-commit guix))
7e6d8d36 LC	477
7e6d8d36 LC	478	(define source
76bea3f8	479	(channel-url guix))
7e6d8d36	480
59fb5c1c LC	481	;; Turn off grafts. Grafting is meant to happen on the user's machines.
	482	(parameterize ((%graft? #f))
	483	;; Return one job for each package, except bootstrap packages.
76bea3f8 MO	484	(append-map
	485	(lambda (system)
	486	(format (current-error-port)
	487	"evaluating for '~a' (heap size: ~a MiB)...~%"
	488	system
	489	(round
	490	(/ (assoc-ref (gc-stats) 'heap-size)
	491	(expt 2. 20))))
	492	(invalidate-derivation-caches!)
	493	(match subset
	494	('all
	495	;; Build everything, including replacements.
	496	(let ((all (all-packages))
	497	(job (lambda (package)
	498	(package->job store package system))))
	499	(append
	500	(filter-map job all)
	501	(image-jobs store system)
	502	(system-test-jobs store system
	503	#:source source
	504	#:commit commit)
	505	(tarball-jobs store system)
	506	(cross-jobs store system))))
	507	('core
	508	;; Build core packages only.
	509	(append
	510	(map (lambda (package)
	511	(package-job store (job-name package)
	512	package system))
	513	%core-packages)
	514	(cross-jobs store system)))
	515	('guix
	516	;; Build Guix modules only.
	517	(guix-jobs store systems
	518	#:source source
	519	#:commit commit))
	520	('hello
	521	;; Build hello package only.
	522	(let ((hello (specification->package "hello")))
	523	(list (package-job store (job-name hello)
	524	hello system))))
61a11653 MO	525	(('channels . channels)
	526	;; Build only the packages from CHANNELS.
	527	(let ((all (all-packages)))
	528	(filter-map
	529	(lambda (package)
	530	(match (package-channels package)
	531	((channel . _)
	532	(and (member (channel-name channel) channels)
	533	(package->job store package system)))
	534	(else #f)))
	535	all)))
76bea3f8 MO	536	(('packages . rest)
	537	;; Build selected list of packages only.
	538	(let ((packages (map specification->package rest)))
	539	(map (lambda (package)
	540	(package-job store (job-name package)
	541	package system))
	542	packages)))
	543	(('manifests . rest)
	544	;; Build packages in the list of manifests.
	545	(let* ((manifests (arguments->manifests rest channels))
	546	(packages (manifests->packages store manifests)))
	547	(map (lambda (package)
	548	(package-job store (job-name package)
	549	package system))
	550	packages)))
	551	(else
	552	(error "unknown subset" subset))))
	553	systems)))