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