[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 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.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 config)
  #:use-module (guix store)
  #:use-module (guix grafts)
  #:use-module (guix profiles)
  #:use-module (guix packages)
  #:use-module (guix channels)
  #: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 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 vm)
  #:use-module (gnu system install)
  #:use-module (gnu tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (%cross-targets
            channel-source->package
            hydra-jobs))

;;; Commentary:
;;;
;;; This file defines build jobs for the Hydra and Cuirass continuation
;;; integration tools.
;;;
;;; Code:

(define* (package->alist store package system
                         #: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

(define (package-job store job-name package system)
  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  (let ((job-name (symbol-append job-name (string->symbol ".")
                                 (string->symbol system))))
    `(,job-name . ,(cut package->alist store package system))))

(define (package-cross-job store job-name package target system)
  "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM."
  `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
                    (string->symbol ".") (string->symbol system)) .
    ,(cute package->alist store package system
           (lambda* (store package system #:key graft?)
             (package-cross-derivation store package target system
                                       #:graft? graft?)))))

(define %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-4.8 gcc-4.9 gcc-5 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"
    "mips64el-linux-gnuabi64"
    "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 %guixsd-supported-systems
  '("x86_64-linux" "i686-linux" "armhf-linux"))

(define %u-boot-systems
  '("armhf-linux"))

(define (qemu-jobs store system)
  "Return a list of jobs that build QEMU images for SYSTEM."
  (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
system.")
      (license . ,(license-name gpl3+))
      (max-silent-time . 600)
      (timeout . 3600)
      (home-page . ,%guix-home-page-url)
      (maintainers . ("bug-guix@gnu.org"))))

  (define (->job name drv)
    (let ((name (symbol-append name (string->symbol ".")
                               (string->symbol system))))
      `(,name . ,(lambda ()
                   (parameterize ((%graft? #f))
                     (->alist drv))))))

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

(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 (test->thunk test)
    (lambda ()
      (define drv
        (run-with-store store
          (mbegin %store-monad
            (set-current-system system)
            (set-grafting #f)
            (set-guile-for-build (default-guile))
            (system-test-value test))))

      `((derivation . ,(derivation-file-name drv))
        (description . ,(format #f "Guix '~a' system test"
                                (system-test-name test)))
        (long-description . ,(system-test-description test))
        (license . ,(license-name gpl3+))
        (max-silent-time . 600)
        (timeout . 3600)
        (home-page . ,%guix-home-page-url)
        (maintainers . ("bug-guix@gnu.org")))))

  (define (->job test)
    (let ((name (string->symbol
                 (string-append "test." (system-test-name 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")))
      ;; 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 Hydra jobs to build the self-contained Guix binary tarball."
  (define (->alist drv)
    `((derivation . ,(derivation-file-name drv))
      (description . "Stand-alone binary Guix tarball")
      (long-description . "This is a tarball containing binaries of Guix and
all its dependencies, and ready to be installed on \"foreign\" distributions.")
      (license . ,(license-name gpl3+))
      (home-page . ,%guix-home-page-url)
      (maintainers . ("bug-guix@gnu.org"))))

  (define (->job name drv)
    (let ((name (symbol-append name (string->symbol ".")
                               (string->symbol system))))
      `(,name . ,(lambda ()
                   (parameterize ((%graft? #f))
                     (->alist 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
                                                  #:localstatedir? #t
                                                  #:compressor
                                                  (lookup-compressor "xz")))))
                 #:system system))))

(define job-name
  ;; Return the name of a package's job.
  (compose string->symbol
           (cut package-full-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 (symbol-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)
  "Return the list of manifests extracted from ARGUMENTS."
  (map (match-lambda
         ((input-name . relative-path)
          (let* ((checkout (assq-ref arguments (string->symbol input-name)))
                 (base (assq-ref checkout 'file-name)))
            (in-vicinity base relative-path))))
       (assq-ref arguments 'manifests)))

(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 (find-current-checkout arguments)
  "Find the first checkout of ARGUMENTS that provided the current file.
Return #f if no such checkout is found."
  (let ((current-root
         (canonicalize-path
          (string-append (dirname (current-filename)) "/.."))))
    (find (lambda (argument)
            (and=> (assq-ref argument 'file-name)
                   (lambda (name)
                     (string=? name current-root)))) arguments)))

\f
;;;
;;; Hydra entry point.
;;;

(define (hydra-jobs store arguments)
  "Return Hydra jobs."
  (define subset
    (match (assoc-ref arguments 'subset)
      ("core" 'core)                              ; only build core packages
      ("hello" 'hello)                            ; only build hello
      (((? string?) (? string?) ...) 'list)       ; only build selected list of packages
      ("manifests" 'manifests)                    ; only build packages in the list of manifests
      (_ 'all)))                                  ; build everything

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

  (define checkout
    (or (find-current-checkout arguments)
        (assq-ref arguments 'superior-guix-checkout)))

  (define commit
    (assq-ref checkout 'revision))

  (define source
    (assq-ref checkout 'file-name))

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