gnu/ci.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4 ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
   5 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
   6 ;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
   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)
  24   #:use-module (guix channels)
  25   #:use-module (guix config)
  26   #:use-module (guix describe)
  27   #:use-module (guix store)
  28   #:use-module (guix grafts)
  29   #:use-module (guix profiles)
  30   #:use-module (guix packages)
  31   #:use-module (guix channels)
  32   #:use-module (guix config)
  33   #:use-module (guix derivations)
  34   #:use-module (guix build-system)
  35   #:use-module (guix monads)
  36   #:use-module (guix gexp)
  37   #:use-module (guix ui)
  38   #:use-module ((guix licenses)
  39                 #:select (gpl3+ license? license-name))
  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)
  46   #:use-module (gnu image)
  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)
  58   #:use-module (gnu system image)
  59   #:use-module (gnu system vm)
  60   #:use-module (gnu system install)
  61   #:use-module (gnu system images hurd)
  62   #:use-module (gnu system images novena)
  63   #:use-module (gnu system images pine64)
  64   #:use-module (gnu system images pinebook-pro)
  65   #:use-module (gnu tests)
  66   #:use-module (srfi srfi-1)
  67   #:use-module (srfi srfi-26)
  68   #:use-module (ice-9 match)
  69   #:export (%core-packages
  70             %cross-targets
  71             channel-source->package
  72             cuirass-jobs))
  73
  74 ;;; Commentary:
  75 ;;;
  76 ;;; This file defines build jobs for Cuirass.
  77 ;;;
  78 ;;; Code:
  79
  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)
 107   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
 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)))))
 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."
 128   (let ((name (string-append target "." job-name "." system)))
 129     (package-job store name package system
 130                  #:cross? #t
 131                  #:target target)))
 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.)
 137   (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
 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
 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))
 153
 154 (define %cross-targets
 155   '("mips64el-linux-gnu"
 156     "arm-linux-gnueabihf"
 157     "aarch64-linux-gnu"
 158     "powerpc-linux-gnu"
 159     "riscv64-linux-gnu"
 160     "i586-pc-gnu"                                 ;aka. GNU/Hurd
 161     "i686-w64-mingw32"
 162     "x86_64-w64-mingw32"))
 163
 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))
 203                      (packages-to-cross-build target)))
 204               (remove (either from-32-to-64? same? pointless?)
 205                       %cross-targets)))
 206
 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
 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"))
 228
 229 (define %guix-system-images
 230   (list hurd-barebones-qcow2-image
 231         pine64-barebones-raw-image
 232         pinebook-pro-barebones-raw-image
 233         novena-barebones-raw-image))
 234
 235 (define (hours hours)
 236   (* 3600 hours))
 237
 238 (define (image-jobs store system)
 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."
 242   (define (->job name drv)
 243     (let ((name (string-append name "." system)))
 244       (parameterize ((%graft? #f))
 245         (derivation->job name drv
 246                          #:period (hours 48)))))
 247
 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
 254   (define MiB
 255     (expt 2 20))
 256
 257   (if (member system %guix-system-supported-systems)
 258       `(,(->job "usb-image"
 259                 (build-image
 260                  (image
 261                   (inherit efi-disk-image)
 262                   (operating-system installation-os))))
 263         ,(->job "iso9660-image"
 264                 (build-image
 265                  (image
 266                   (inherit (image-with-label
 267                             iso9660-image
 268                             (string-append "GUIX_" system "_"
 269                                            (if (> (string-length %guix-version) 7)
 270                                                (substring %guix-version 0 7)
 271                                                %guix-version))))
 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)
 276                      (->job (symbol->string (image-name image))
 277                             (build-image image)))
 278                    %guix-system-images)
 279               '()))
 280       '()))
 281
 282 (define channel-build-system
 283   ;; Build system used to "convert" a channel instance to a package.
 284   (let* ((build (lambda* (store name inputs
 285                                 #:key source commit system
 286                                 #:allow-other-keys)
 287                   (run-with-store store
 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)))
 293                                          (instance
 294                                           -> (checkout->channel-instance
 295                                               source #:commit commit)))
 296                       (channel-instances->derivation (list instance)))
 297                     #:system system)))
 298          (lower (lambda* (name #:key system source commit
 299                                #:allow-other-keys)
 300                   (bag
 301                     (name name)
 302                     (system system)
 303                     (build build)
 304                     (arguments `(#:source ,source
 305                                  #:commit ,commit))))))
 306     (build-system (name 'channel)
 307                   (description "Turn a channel instance into a package.")
 308                   (lower lower))))
 309
 310 (define* (channel-source->package source #:key commit)
 311   "Return a package for the given channel SOURCE, a lowerable object."
 312   (package
 313     (inherit guix)
 314     (version (string-append (package-version guix) "+"))
 315     (build-system channel-build-system)
 316     (arguments `(#:source ,source
 317                  #:commit ,commit))
 318     (inputs '())
 319     (native-inputs '())
 320     (propagated-inputs '())))
 321
 322 (define* (system-test-jobs store system
 323                            #:key source commit)
 324   "Return a list of jobs for the system tests."
 325   (define (->job test)
 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)))))
 342
 343   (if (member system %guix-system-supported-systems)
 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.
 348       (map ->job (all-system-tests))
 349       '()))
 350
 351 (define (tarball-jobs store system)
 352   "Return jobs to build the self-contained Guix binary tarball."
 353   (define (->job name drv)
 354     (let ((name (string-append name "." system)))
 355       (parameterize ((%graft? #f))
 356         (derivation->job name drv
 357                          #:period (hours 24)))))
 358
 359   ;; XXX: Add a job for the stable Guix?
 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))))
 372
 373 (define job-name
 374   ;; Return the name of a package's job.
 375   package-name)
 376
 377 (define package->job
 378   (let ((base-packages
 379          (delete-duplicates
 380           (append-map (match-lambda
 381                         ((_ package _ ...)
 382                          (match (package-transitive-inputs package)
 383                            (((_ inputs _ ...) ...)
 384                             inputs))))
 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)
 390              (package-job store (string-append "base." (job-name package))
 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)
 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
 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
 424 (define (arguments->manifests arguments channels)
 425   "Return the list of manifests extracted from ARGUMENTS."
 426   (map (lambda (manifest)
 427          (any (lambda (checkout)
 428                 (let ((path (in-vicinity checkout manifest)))
 429                   (and (file-exists? path)
 430                        path)))
 431               (map channel-url channels)))
 432        arguments))
 433
 434 (define (manifests->packages store manifests)
 435   "Return the list of packages found in MANIFESTS."
 436   (define (load-manifest manifest)
 437     (save-module-excursion
 438      (lambda ()
 439        (set-current-module (make-user-module '((guix profiles) (gnu))))
 440        (primitive-load manifest))))
 441
 442   (delete-duplicates!
 443    (map manifest-entry-item
 444         (append-map (compose manifest-entries
 445                              load-manifest)
 446                     manifests))))
 447
 448 \f
 449 ;;;
 450 ;;; Cuirass entry point.
 451 ;;;
 452
 453 (define (cuirass-jobs store arguments)
 454   "Register Cuirass jobs."
 455   (define subset
 456     (assoc-ref arguments 'subset))
 457
 458   (define systems
 459     (match (assoc-ref arguments 'systems)
 460       (#f              %cuirass-supported-systems)
 461       ((lst ...)       lst)
 462       ((? string? str) (call-with-input-string str read))))
 463
 464   (define channels
 465     (let ((channels (assq-ref arguments 'channels)))
 466       (map sexp->channel channels)))
 467
 468   (define guix
 469     (find guix-channel? channels))
 470
 471   (define commit
 472     (channel-commit guix))
 473
 474   (define source
 475     (channel-url guix))
 476
 477   ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
 478   (parameterize ((%graft? #f))
 479     ;; Return one job for each package, except bootstrap packages.
 480     (append-map
 481      (lambda (system)
 482        (format (current-error-port)
 483                "evaluating for '~a' (heap size: ~a MiB)...~%"
 484                system
 485                (round
 486                 (/ (assoc-ref (gc-stats) 'heap-size)
 487                    (expt 2. 20))))
 488        (invalidate-derivation-caches!)
 489        (match subset
 490          ('all
 491           ;; Build everything, including replacements.
 492           (let ((all (all-packages))
 493                 (job (lambda (package)
 494                        (package->job store package system))))
 495             (append
 496              (filter-map job all)
 497              (image-jobs store system)
 498              (system-test-jobs store system
 499                                #:source source
 500                                #:commit commit)
 501              (tarball-jobs store system)
 502              (cross-jobs store system))))
 503          ('core
 504           ;; Build core packages only.
 505           (append
 506            (map (lambda (package)
 507                   (package-job store (job-name package)
 508                                package system))
 509                 %core-packages)
 510            (cross-jobs store system)))
 511          ('guix
 512           ;; Build Guix modules only.
 513           (guix-jobs store systems
 514                      #:source source
 515                      #:commit commit))
 516          ('hello
 517           ;; Build hello package only.
 518           (let ((hello (specification->package "hello")))
 519             (list (package-job store (job-name hello)
 520                                hello system))))
 521          (('channels . channels)
 522           ;; Build only the packages from CHANNELS.
 523           (let ((all (all-packages)))
 524             (filter-map
 525              (lambda (package)
 526                (any (lambda (channel)
 527                       (and (member (channel-name channel) channels)
 528                            (package->job store package system)))
 529                     (package-channels package)))
 530              all)))
 531          (('packages . rest)
 532           ;; Build selected list of packages only.
 533           (let ((packages (map specification->package rest)))
 534             (map (lambda (package)
 535                    (package-job store (job-name package)
 536                                 package system))
 537                  packages)))
 538          (('manifests . rest)
 539           ;; Build packages in the list of manifests.
 540           (let* ((manifests (arguments->manifests rest channels))
 541                  (packages (manifests->packages store manifests)))
 542             (map (lambda (package)
 543                    (package-job store (job-name package)
 544                                 package system))
 545                  packages)))
 546          (else
 547           (error "unknown subset" subset))))
 548      systems)))