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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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 (derivation->job
            image->job

            %core-packages
            %cross-targets
            channel-source->package

            arguments->systems
            cuirass-jobs))

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

(define* (derivation->job name drv
                          #:key
                          (max-silent-time 3600)
                          (timeout 3600))
  "Return a Cuirass job called NAME and describing DRV.

MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
building the derivation."
  `((#:job-name . ,name)
    (#:derivation . ,(derivation-file-name drv))
    (#:inputs . ,(map (compose derivation-file-name
                               derivation-input-derivation)
                      (derivation-inputs 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))
    (#: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)))
    (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-8 gcc-9 gcc-10 gcc-11 glibc binutils
        gmp mpfr mpc coreutils findutils diffutils patch sed grep
        gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz
        %bootstrap-binaries-tarball
        %binutils-bootstrap-tarball
        (%glibc-bootstrap-tarball)
        %gcc-bootstrap-tarball
        %guile-bootstrap-tarball
        %bootstrap-tarballs))

(define (commencement-packages system)
  "Return the list of bootstrap packages from the commencement module for
SYSTEM."
  ;; Only include packages supported on SYSTEM.  For example, the Mes
  ;; bootstrap graph is currently not supported on ARM so it should be
  ;; excluded.
  (filter (lambda (obj)
            (and (package? obj)
                 (supported-package? obj system)))
          (module-map (lambda (sym var)
                        (variable-ref var))
                      (resolve-module '(gnu packages commencement)))))

(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"
    "powerpc64le-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->job store image
                     #:key name system)
  "Return the job for IMAGE on SYSTEM.  If NAME is passed, use it as job name,
otherwise use the IMAGE name."
  (let* ((image-name (or name
                         (symbol->string (image-name image))))
         (name (string-append image-name "." system))
         (drv (run-with-store store
                (mbegin %store-monad
                  (set-guile-for-build (default-guile))
                  (lower-object (system-image image))))))
    (parameterize ((%graft? #f))
      (derivation->job name drv))))

(define (image-jobs store system)
  "Return a list of jobs that build images for SYSTEM."
  (define MiB
    (expt 2 20))

  (if (member system %guix-system-supported-systems)
      `(,(image->job store
                     (image
                      (inherit efi-disk-image)
                      (operating-system installation-os))
                     #:name "usb-image"
                     #:system system)
        ,(image->job
          store
          (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))
          #:name "iso9660-image"
          #:system system)
        ;; Only cross-compile Guix System images from x86_64-linux for now.
        ,@(if (string=? system "x86_64-linux")
              (map (cut image->job store <>
                        #:system system)
                   %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)
    (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)))))

      (derivation->job name drv)))

  (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)))
      '()))

(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))))

  ;; 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
                                             #:profile-name "current-guix"
                                             #: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."
  (map (lambda (manifest)
         (any (lambda (checkout)
                (let ((path (in-vicinity checkout manifest)))
                  (and (file-exists? path)
                       path)))
              (map channel-url channels)))
       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))))

(define (arguments->systems arguments)
  "Return the systems list from ARGUMENTS."
  (match (assoc-ref arguments 'systems)
    (#f              %cuirass-supported-systems)
    ((lst ...)       lst)
    ((? string? str) (call-with-input-string str read))))

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

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

  (define systems
    (arguments->systems arguments))

  (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)
             (cross-jobs store system))))
         ('core
          ;; Build core packages only.
          (append
           (map (lambda (package)
                  (package-job store (job-name package)
                               package system))
                (append (commencement-packages 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))))
         ('images
          ;; Build Guix System images only.
          (image-jobs store system))
         ('system-tests
          ;; Build Guix System tests only.
          (system-test-jobs store system
                            #:source source
                            #:commit commit))
         ('tarball
          ;; Build Guix tarball only.
          (tarball-jobs store system))
         (('custom . modules)
          ;; Build custom modules jobs only.
          (append-map
           (lambda (module)
             (let ((proc (module-ref
                          (resolve-interface module)
                          'cuirass-jobs)))
               (proc store arguments)))
           modules))
         (('channels . channels)
          ;; Build only the packages from CHANNELS.
          (let ((all (all-packages)))
            (filter-map
             (lambda (package)
               (any (lambda (channel)
                      (and (member (channel-name channel) channels)
                           (package->job store package system)))
                    (package-channels package)))
             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
39f1486e	2	;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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)
996b5edf MO	69	#:export (derivation->job
	70	image->job
	71
	72	%core-packages
76bea3f8	73	%cross-targets
f292c501	74	channel-source->package
3034f3d0 MO	75
3034f3d0 MO	76	arguments->systems
76bea3f8	77	cuirass-jobs))
59fb5c1c LC	78
	79	;;; Commentary:
	80	;;;
76bea3f8	81	;;; This file defines build jobs for Cuirass.
59fb5c1c LC	82	;;;
	83	;;; Code:
	84
76bea3f8 MO	85	(define* (derivation->job name drv
76bea3f8 MO	86	#:key
76bea3f8 MO	87	(max-silent-time 3600)
76bea3f8 MO	88	(timeout 3600))
14ada964	89	"Return a Cuirass job called NAME and describing DRV.
76bea3f8 MO	90
	91	MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
	92	building the derivation."
	93	`((#:job-name . ,name)
	94	(#:derivation . ,(derivation-file-name drv))
e4c02ac7 MO	95	(#:inputs . ,(map (compose derivation-file-name
	96	derivation-input-derivation)
	97	(derivation-inputs drv)))
76bea3f8 MO	98	(#:outputs . ,(filter-map
	99	(lambda (res)
	100	(match res
	101	((name . path)
	102	`(,name . ,path))))
	103	(derivation->output-paths drv)))
	104	(#:nix-name . ,(derivation-name drv))
	105	(#:system . ,(derivation-system drv))
76bea3f8 MO	106	(#:max-silent-time . ,max-silent-time)
	107	(#:timeout . ,timeout)))
	108
	109	(define* (package-job store job-name package system
	110	#:key cross? target)
59fb5c1c	111	"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
76bea3f8 MO	112	(let ((job-name (string-append job-name "." system)))
	113	(parameterize ((%graft? #f))
	114	(let* ((drv (if cross?
	115	(package-cross-derivation store package target system
	116	#:graft? #f)
	117	(package-derivation store package system
	118	#:graft? #f)))
	119	(max-silent-time (or (assoc-ref (package-properties package)
	120	'max-silent-time)
	121	3600))
	122	(timeout (or (assoc-ref (package-properties package)
	123	'timeout)
	124	72000)))
	125	(derivation->job job-name drv
	126	#:max-silent-time max-silent-time
	127	#:timeout timeout)))))
59fb5c1c LC	128
	129	(define (package-cross-job store job-name package target system)
	130	"Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
	131	SYSTEM."
39f1486e	132	(let ((name (string-append target "." job-name)))
76bea3f8 MO	133	(package-job store name package system
	134	#:cross? #t
	135	#:target target)))
59fb5c1c LC	136
	137	(define %core-packages
	138	;; Note: Don't put the '-final' package variants because (1) that's
	139	;; implicit, and (2) they cannot be cross-built (due to the explicit input
	140	;; chain.)
9ac9df25	141	(list gcc-8 gcc-9 gcc-10 gcc-11 glibc binutils
59fb5c1c	142	gmp mpfr mpc coreutils findutils diffutils patch sed grep
9ac9df25	143	gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz
59fb5c1c LC	144	%bootstrap-binaries-tarball
	145	%binutils-bootstrap-tarball
	146	(%glibc-bootstrap-tarball)
	147	%gcc-bootstrap-tarball
	148	%guile-bootstrap-tarball
	149	%bootstrap-tarballs))
	150
ac815ecd LC	151	(define (commencement-packages system)
	152	"Return the list of bootstrap packages from the commencement module for
	153	SYSTEM."
	154	;; Only include packages supported on SYSTEM. For example, the Mes
	155	;; bootstrap graph is currently not supported on ARM so it should be
	156	;; excluded.
	157	(filter (lambda (obj)
	158	(and (package? obj)
	159	(supported-package? obj system)))
	160	(module-map (lambda (sym var)
	161	(variable-ref var))
	162	(resolve-module '(gnu packages commencement)))))
df49fe2a	163
668a5198 LC	164	(define (packages-to-cross-build target)
	165	"Return the list of packages to cross-build for TARGET."
	166	;; Don't cross-build the bootstrap tarballs for MinGW.
	167	(if (string-contains target "mingw")
	168	(drop-right %core-packages 6)
	169	%core-packages))
59fb5c1c LC	170
	171	(define %cross-targets
	172	'("mips64el-linux-gnu"
59fb5c1c LC	173	"arm-linux-gnueabihf"
	174	"aarch64-linux-gnu"
	175	"powerpc-linux-gnu"
8d9aece8	176	"powerpc64le-linux-gnu"
2032d847	177	"riscv64-linux-gnu"
59fb5c1c	178	"i586-pc-gnu" ;aka. GNU/Hurd
67dac6b8 CD	179	"i686-w64-mingw32"
67dac6b8 CD	180	"x86_64-w64-mingw32"))
59fb5c1c	181
3046e73b LC	182	(define (cross-jobs store system)
	183	"Return a list of cross-compilation jobs for SYSTEM."
	184	(define (from-32-to-64? target)
	185	;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
	186	;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
	187	;; mips64el-linux-gnuabi64.
	188	(and (or (string-prefix? "i686-" system)
	189	(string-prefix? "i586-" system)
	190	(string-prefix? "armhf-" system))
	191	(string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
	192
	193	(define (same? target)
	194	;; Return true if SYSTEM and TARGET are the same thing. This is so we
	195	;; don't try to cross-compile to 'mips64el-linux-gnu' from
	196	;; 'mips64el-linux'.
	197	(or (string-contains target system)
	198	(and (string-prefix? "armhf" system) ;armhf-linux
	199	(string-prefix? "arm" target)))) ;arm-linux-gnueabihf
	200
	201	(define (pointless? target)
	202	;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
	203	(match system
	204	((or "x86_64-linux" "i686-linux")
	205	(if (string-contains target "mingw")
	206	(not (string=? "x86_64-linux" system))
	207	#f))
	208	(_
	209	;; Don't try to cross-compile from non-Intel platforms: this isn't
	210	;; very useful and these are often brittle configurations.
	211	#t)))
	212
	213	(define (either proc1 proc2 proc3)
	214	(lambda (x)
	215	(or (proc1 x) (proc2 x) (proc3 x))))
	216
	217	(append-map (lambda (target)
	218	(map (lambda (package)
	219	(package-cross-job store (job-name package)
	220	package target system))
50b99c90	221	(packages-to-cross-build target)))
3046e73b LC	222	(remove (either from-32-to-64? same? pointless?)
	223	%cross-targets)))
	224
76bea3f8 MO	225	(define* (guix-jobs store systems #:key source commit)
	226	"Return a list of jobs for Guix itself."
	227	(define build
	228	(primitive-load (string-append source "/build-aux/build-self.scm")))
	229
	230	(map
	231	(lambda (system)
	232	(let ((name (string->symbol
	233	(string-append "guix." system)))
	234	(drv (run-with-store store
	235	(build source #:version commit #:system system
	236	#:pull-version 1
	237	#:guile-version "2.2"))))
	238	(derivation->job name drv)))
	239	systems))
	240
b06ba9e0 MO	241	;; Architectures that are able to build or cross-build Guix System images.
	242	;; This does not mean that other architectures are not supported, only that
	243	;; they are often not fast enough to support Guix System images building.
	244	(define %guix-system-supported-systems
	245	'("x86_64-linux" "i686-linux"))
59fb5c1c	246
b06ba9e0	247	(define %guix-system-images
8a4f1eef	248	(list hurd-barebones-qcow2-image
17d9a91e	249	pine64-barebones-raw-image
846e5240 DM	250	pinebook-pro-barebones-raw-image
846e5240 DM	251	novena-barebones-raw-image))
59fb5c1c	252
fc2fa7ad MO	253	(define (hours hours)
	254	(* 3600 hours))
	255
996b5edf MO	256	(define* (image->job store image
	257	#:key name system)
	258	"Return the job for IMAGE on SYSTEM. If NAME is passed, use it as job name,
	259	otherwise use the IMAGE name."
	260	(let* ((image-name (or name
	261	(symbol->string (image-name image))))
	262	(name (string-append image-name "." system))
	263	(drv (run-with-store store
	264	(mbegin %store-monad
	265	(set-guile-for-build (default-guile))
	266	(lower-object (system-image image))))))
	267	(parameterize ((%graft? #f))
	268	(derivation->job name drv))))
	269
b06ba9e0	270	(define (image-jobs store system)
14ada964	271	"Return a list of jobs that build images for SYSTEM."
59fb5c1c LC	272	(define MiB
	273	(expt 2 20))
	274
b06ba9e0	275	(if (member system %guix-system-supported-systems)
996b5edf MO	276	`(,(image->job store
	277	(image
	278	(inherit efi-disk-image)
	279	(operating-system installation-os))
	280	#:name "usb-image"
	281	#:system system)
	282	,(image->job
	283	store
	284	(image
	285	(inherit (image-with-label
	286	iso9660-image
	287	(string-append "GUIX_" system "_"
	288	(if (> (string-length %guix-version) 7)
	289	(substring %guix-version 0 7)
	290	%guix-version))))
	291	(operating-system installation-os))
	292	#:name "iso9660-image"
	293	#:system system)
b06ba9e0 MO	294	;; Only cross-compile Guix System images from x86_64-linux for now.
b06ba9e0 MO	295	,@(if (string=? system "x86_64-linux")
996b5edf MO	296	(map (cut image->job store <>
996b5edf MO	297	#:system system)
b06ba9e0 MO	298	%guix-system-images)
b06ba9e0 MO	299	'()))
1189f405	300	'()))
59fb5c1c	301
7e6d8d36 LC	302	(define channel-build-system
	303	;; Build system used to "convert" a channel instance to a package.
	304	(let* ((build (lambda* (store name inputs
dd1ee160	305	#:key source commit system
c3ab921e	306	#:allow-other-keys)
7e6d8d36	307	(run-with-store store
bc8b2ffd LC	308	;; SOURCE can be a lowerable object such as <local-file>
	309	;; or a file name. Adjust accordingly.
	310	(mlet* %store-monad ((source (if (string? source)
	311	(return source)
	312	(lower-object source)))
dd1ee160 LC	313	(instance
	314	-> (checkout->channel-instance
	315	source #:commit commit)))
	316	(channel-instances->derivation (list instance)))
c3ab921e	317	#:system system)))
dd1ee160 LC	318	(lower (lambda* (name #:key system source commit
dd1ee160 LC	319	#:allow-other-keys)
7e6d8d36 LC	320	(bag
	321	(name name)
	322	(system system)
	323	(build build)
dd1ee160 LC	324	(arguments `(#:source ,source
dd1ee160 LC	325	#:commit ,commit))))))
7e6d8d36 LC	326	(build-system (name 'channel)
	327	(description "Turn a channel instance into a package.")
	328	(lower lower))))
	329
dd1ee160 LC	330	(define* (channel-source->package source #:key commit)
dd1ee160 LC	331	"Return a package for the given channel SOURCE, a lowerable object."
7e6d8d36 LC	332	(package
7e6d8d36 LC	333	(inherit guix)
dd1ee160	334	(version (string-append (package-version guix) "+"))
7e6d8d36	335	(build-system channel-build-system)
dd1ee160 LC	336	(arguments `(#:source ,source
dd1ee160 LC	337	#:commit ,commit))
7e6d8d36 LC	338	(inputs '())
	339	(native-inputs '())
	340	(propagated-inputs '())))
	341
	342	(define* (system-test-jobs store system
	343	#:key source commit)
59fb5c1c	344	"Return a list of jobs for the system tests."
59fb5c1c	345	(define (->job test)
fc37346f MO	346	(let ((name (string-append "test." (system-test-name test)
	347	"." system))
	348	(drv (run-with-store store
	349	(mbegin %store-monad
	350	(set-current-system system)
	351	(set-grafting #f)
	352	(set-guile-for-build (default-guile))
	353	(system-test-value test)))))
76bea3f8	354
fc37346f	355	(derivation->job name drv)))
59fb5c1c	356
b06ba9e0	357	(if (member system %guix-system-supported-systems)
7e6d8d36 LC	358	;; Override the value of 'current-guix' used by system tests. Using a
	359	;; channel instance makes tests that rely on 'current-guix' less
	360	;; expensive. It also makes sure we get a valid Guix package when this
	361	;; code is not running from a checkout.
fc37346f MO	362	(parameterize ((current-guix-package
	363	(channel-source->package source #:commit commit)))
	364	(map ->job (all-system-tests)))
59fb5c1c LC	365	'()))
	366
	367	(define (tarball-jobs store system)
76bea3f8	368	"Return jobs to build the self-contained Guix binary tarball."
59fb5c1c	369	(define (->job name drv)
76bea3f8 MO	370	(let ((name (string-append name "." system)))
76bea3f8 MO	371	(parameterize ((%graft? #f))
14ada964	372	(derivation->job name drv))))
59fb5c1c LC	373
59fb5c1c LC	374	;; XXX: Add a job for the stable Guix?
76bea3f8 MO	375	(list
	376	(->job "binary-tarball"
	377	(run-with-store store
	378	(mbegin %store-monad
	379	(set-guile-for-build (default-guile))
	380	(>>= (profile-derivation (packages->manifest (list guix)))
	381	(lambda (profile)
	382	(self-contained-tarball "guix-binary" profile
2ccb715a	383	#:profile-name "current-guix"
76bea3f8 MO	384	#:localstatedir? #t
	385	#:compressor
	386	(lookup-compressor "xz")))))
	387	#:system system))))
59fb5c1c LC	388
	389	(define job-name
	390	;; Return the name of a package's job.
76bea3f8	391	package-name)
59fb5c1c LC	392
	393	(define package->job
	394	(let ((base-packages
	395	(delete-duplicates
	396	(append-map (match-lambda
76bea3f8 MO	397	((_ package _ ...)
	398	(match (package-transitive-inputs package)
	399	(((_ inputs _ ...) ...)
	400	inputs))))
59fb5c1c LC	401	(%final-inputs)))))
	402	(lambda (store package system)
	403	"Return a job for PACKAGE on SYSTEM, or #f if this combination is not
	404	valid."
	405	(cond ((member package base-packages)
76bea3f8	406	(package-job store (string-append "base." (job-name package))
59fb5c1c LC	407	package system))
	408	((supported-package? package system)
	409	(let ((drv (package-derivation store package system
	410	#:graft? #f)))
	411	(and (substitutable-derivation? drv)
	412	(package-job store (job-name package)
	413	package system))))
	414	(else
	415	#f)))))
	416
	417	(define (all-packages)
	418	"Return the list of packages to build."
	419	(define (adjust package result)
	420	(cond ((package-replacement package)
f00ff8db LC	421	;; XXX: If PACKAGE and its replacement have the same name/version,
	422	;; then both Cuirass jobs will have the same name, which
	423	;; effectively means that the second one will be ignored. Thus,
	424	;; return the replacement first.
	425	(cons* (package-replacement package) ;build both
	426	package
59fb5c1c LC	427	result))
	428	((package-superseded package)
	429	result) ;don't build it
	430	(else
	431	(cons package result))))
	432
	433	(fold-packages adjust
	434	(fold adjust '() ;include base packages
	435	(match (%final-inputs)
	436	(((labels packages _ ...) ...)
	437	packages)))
	438	#:select? (const #t))) ;include hidden packages
	439
76bea3f8	440	(define (arguments->manifests arguments channels)
59fb5c1c	441	"Return the list of manifests extracted from ARGUMENTS."
862af8c2 MO	442	(map (lambda (manifest)
	443	(any (lambda (checkout)
	444	(let ((path (in-vicinity checkout manifest)))
	445	(and (file-exists? path)
	446	path)))
	447	(map channel-url channels)))
76bea3f8	448	arguments))
59fb5c1c LC	449
	450	(define (manifests->packages store manifests)
	451	"Return the list of packages found in MANIFESTS."
	452	(define (load-manifest manifest)
	453	(save-module-excursion
	454	(lambda ()
	455	(set-current-module (make-user-module '((guix profiles) (gnu))))
	456	(primitive-load manifest))))
	457
	458	(delete-duplicates!
	459	(map manifest-entry-item
	460	(append-map (compose manifest-entries
	461	load-manifest)
	462	manifests))))
	463
3034f3d0 MO	464	(define (arguments->systems arguments)
	465	"Return the systems list from ARGUMENTS."
	466	(match (assoc-ref arguments 'systems)
	467	(#f %cuirass-supported-systems)
	468	((lst ...) lst)
	469	((? string? str) (call-with-input-string str read))))
	470
59fb5c1c LC	471	\f
59fb5c1c LC	472	;;;
76bea3f8	473	;;; Cuirass entry point.
59fb5c1c LC	474	;;;
59fb5c1c LC	475
76bea3f8 MO	476	(define (cuirass-jobs store arguments)
76bea3f8 MO	477	"Register Cuirass jobs."
59fb5c1c	478	(define subset
76bea3f8	479	(assoc-ref arguments 'subset))
59fb5c1c LC	480
59fb5c1c LC	481	(define systems
3034f3d0	482	(arguments->systems arguments))
59fb5c1c	483
76bea3f8 MO	484	(define channels
	485	(let ((channels (assq-ref arguments 'channels)))
	486	(map sexp->channel channels)))
	487
	488	(define guix
	489	(find guix-channel? channels))
7e6d8d36 LC	490
7e6d8d36 LC	491	(define commit
76bea3f8	492	(channel-commit guix))
7e6d8d36 LC	493
7e6d8d36 LC	494	(define source
76bea3f8	495	(channel-url guix))
7e6d8d36	496
59fb5c1c LC	497	;; Turn off grafts. Grafting is meant to happen on the user's machines.
	498	(parameterize ((%graft? #f))
	499	;; Return one job for each package, except bootstrap packages.
76bea3f8 MO	500	(append-map
	501	(lambda (system)
	502	(format (current-error-port)
	503	"evaluating for '~a' (heap size: ~a MiB)...~%"
	504	system
	505	(round
	506	(/ (assoc-ref (gc-stats) 'heap-size)
	507	(expt 2. 20))))
	508	(invalidate-derivation-caches!)
	509	(match subset
	510	('all
	511	;; Build everything, including replacements.
	512	(let ((all (all-packages))
	513	(job (lambda (package)
	514	(package->job store package system))))
	515	(append
	516	(filter-map job all)
76bea3f8 MO	517	(cross-jobs store system))))
	518	('core
	519	;; Build core packages only.
	520	(append
	521	(map (lambda (package)
	522	(package-job store (job-name package)
	523	package system))
ac815ecd	524	(append (commencement-packages system) %core-packages))
76bea3f8 MO	525	(cross-jobs store system)))
	526	('guix
	527	;; Build Guix modules only.
	528	(guix-jobs store systems
	529	#:source source
	530	#:commit commit))
	531	('hello
	532	;; Build hello package only.
	533	(let ((hello (specification->package "hello")))
	534	(list (package-job store (job-name hello)
	535	hello system))))
2afc79b5 MO	536	('images
	537	;; Build Guix System images only.
	538	(image-jobs store system))
	539	('system-tests
	540	;; Build Guix System tests only.
	541	(system-test-jobs store system
	542	#:source source
	543	#:commit commit))
	544	('tarball
	545	;; Build Guix tarball only.
	546	(tarball-jobs store system))
f97e220b MO	547	(('custom . modules)
	548	;; Build custom modules jobs only.
	549	(append-map
	550	(lambda (module)
	551	(let ((proc (module-ref
	552	(resolve-interface module)
	553	'cuirass-jobs)))
	554	(proc store arguments)))
	555	modules))
61a11653 MO	556	(('channels . channels)
	557	;; Build only the packages from CHANNELS.
	558	(let ((all (all-packages)))
	559	(filter-map
	560	(lambda (package)
cbfcbb79 MO	561	(any (lambda (channel)
	562	(and (member (channel-name channel) channels)
	563	(package->job store package system)))
	564	(package-channels package)))
61a11653	565	all)))
76bea3f8 MO	566	(('packages . rest)
	567	;; Build selected list of packages only.
	568	(let ((packages (map specification->package rest)))
	569	(map (lambda (package)
	570	(package-job store (job-name package)
	571	package system))
	572	packages)))
	573	(('manifests . rest)
	574	;; Build packages in the list of manifests.
	575	(let* ((manifests (arguments->manifests rest channels))
	576	(packages (manifests->packages store manifests)))
	577	(map (lambda (package)
	578	(package-job store (job-name package)
	579	package system))
	580	packages)))
	581	(else
	582	(error "unknown subset" subset))))
	583	systems)))