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     "powerpc64le-linux-gnu"
 160     "riscv64-linux-gnu"
 161     "i586-pc-gnu"                                 ;aka. GNU/Hurd
 162     "i686-w64-mingw32"
 163     "x86_64-w64-mingw32"))
 164
 165 (define (cross-jobs store system)
 166   "Return a list of cross-compilation jobs for SYSTEM."
 167   (define (from-32-to-64? target)
 168     ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
 169     ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
 170     ;; mips64el-linux-gnuabi64.
 171     (and (or (string-prefix? "i686-" system)
 172              (string-prefix? "i586-" system)
 173              (string-prefix? "armhf-" system))
 174          (string-contains target "64")))    ;x86_64, mips64el, aarch64, etc.
 175
 176   (define (same? target)
 177     ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
 178     ;; don't try to cross-compile to 'mips64el-linux-gnu' from
 179     ;; 'mips64el-linux'.
 180     (or (string-contains target system)
 181         (and (string-prefix? "armhf" system)    ;armhf-linux
 182              (string-prefix? "arm" target))))   ;arm-linux-gnueabihf
 183
 184   (define (pointless? target)
 185     ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
 186     (match system
 187       ((or "x86_64-linux" "i686-linux")
 188        (if (string-contains target "mingw")
 189            (not (string=? "x86_64-linux" system))
 190            #f))
 191       (_
 192        ;; Don't try to cross-compile from non-Intel platforms: this isn't
 193        ;; very useful and these are often brittle configurations.
 194        #t)))
 195
 196   (define (either proc1 proc2 proc3)
 197     (lambda (x)
 198       (or (proc1 x) (proc2 x) (proc3 x))))
 199
 200   (append-map (lambda (target)
 201                 (map (lambda (package)
 202                        (package-cross-job store (job-name package)
 203                                           package target system))
 204                      (packages-to-cross-build target)))
 205               (remove (either from-32-to-64? same? pointless?)
 206                       %cross-targets)))
 207
 208 (define* (guix-jobs store systems #:key source commit)
 209   "Return a list of jobs for Guix itself."
 210   (define build
 211     (primitive-load (string-append source "/build-aux/build-self.scm")))
 212
 213   (map
 214    (lambda (system)
 215      (let ((name (string->symbol
 216                   (string-append "guix." system)))
 217            (drv (run-with-store store
 218                   (build source #:version commit #:system system
 219                          #:pull-version 1
 220                          #:guile-version "2.2"))))
 221        (derivation->job name drv)))
 222    systems))
 223
 224 ;; Architectures that are able to build or cross-build Guix System images.
 225 ;; This does not mean that other architectures are not supported, only that
 226 ;; they are often not fast enough to support Guix System images building.
 227 (define %guix-system-supported-systems
 228   '("x86_64-linux" "i686-linux"))
 229
 230 (define %guix-system-images
 231   (list hurd-barebones-qcow2-image
 232         pine64-barebones-raw-image
 233         pinebook-pro-barebones-raw-image
 234         novena-barebones-raw-image))
 235
 236 (define (hours hours)
 237   (* 3600 hours))
 238
 239 (define (image-jobs store system)
 240   "Return a list of jobs that build images for SYSTEM.  Those jobs are
 241 expensive in storage and I/O operations, hence their periodicity is limited by
 242 passing the PERIOD argument."
 243   (define (->job name drv)
 244     (let ((name (string-append name "." system)))
 245       (parameterize ((%graft? #f))
 246         (derivation->job name drv
 247                          #:period (hours 48)))))
 248
 249   (define (build-image image)
 250     (run-with-store store
 251       (mbegin %store-monad
 252         (set-guile-for-build (default-guile))
 253         (lower-object (system-image image)))))
 254
 255   (define MiB
 256     (expt 2 20))
 257
 258   (if (member system %guix-system-supported-systems)
 259       `(,(->job "usb-image"
 260                 (build-image
 261                  (image
 262                   (inherit efi-disk-image)
 263                   (operating-system installation-os))))
 264         ,(->job "iso9660-image"
 265                 (build-image
 266                  (image
 267                   (inherit (image-with-label
 268                             iso9660-image
 269                             (string-append "GUIX_" system "_"
 270                                            (if (> (string-length %guix-version) 7)
 271                                                (substring %guix-version 0 7)
 272                                                %guix-version))))
 273                   (operating-system installation-os))))
 274         ;; Only cross-compile Guix System images from x86_64-linux for now.
 275         ,@(if (string=? system "x86_64-linux")
 276               (map (lambda (image)
 277                      (->job (symbol->string (image-name image))
 278                             (build-image image)))
 279                    %guix-system-images)
 280               '()))
 281       '()))
 282
 283 (define channel-build-system
 284   ;; Build system used to "convert" a channel instance to a package.
 285   (let* ((build (lambda* (store name inputs
 286                                 #:key source commit system
 287                                 #:allow-other-keys)
 288                   (run-with-store store
 289                     ;; SOURCE can be a lowerable object such as <local-file>
 290                     ;; or a file name.  Adjust accordingly.
 291                     (mlet* %store-monad ((source (if (string? source)
 292                                                      (return source)
 293                                                      (lower-object source)))
 294                                          (instance
 295                                           -> (checkout->channel-instance
 296                                               source #:commit commit)))
 297                       (channel-instances->derivation (list instance)))
 298                     #:system system)))
 299          (lower (lambda* (name #:key system source commit
 300                                #:allow-other-keys)
 301                   (bag
 302                     (name name)
 303                     (system system)
 304                     (build build)
 305                     (arguments `(#:source ,source
 306                                  #:commit ,commit))))))
 307     (build-system (name 'channel)
 308                   (description "Turn a channel instance into a package.")
 309                   (lower lower))))
 310
 311 (define* (channel-source->package source #:key commit)
 312   "Return a package for the given channel SOURCE, a lowerable object."
 313   (package
 314     (inherit guix)
 315     (version (string-append (package-version guix) "+"))
 316     (build-system channel-build-system)
 317     (arguments `(#:source ,source
 318                  #:commit ,commit))
 319     (inputs '())
 320     (native-inputs '())
 321     (propagated-inputs '())))
 322
 323 (define* (system-test-jobs store system
 324                            #:key source commit)
 325   "Return a list of jobs for the system tests."
 326   (define (->job test)
 327     (parameterize ((current-guix-package
 328                     (channel-source->package source #:commit commit)))
 329       (let ((name (string-append "test." (system-test-name test)
 330                                  "." system))
 331             (drv (run-with-store store
 332                    (mbegin %store-monad
 333                      (set-current-system system)
 334                      (set-grafting #f)
 335                      (set-guile-for-build (default-guile))
 336                      (system-test-value test)))))
 337
 338         ;; Those tests are extremely expensive in I/O operations and storage
 339         ;; size, use the "period" attribute to run them with a period of at
 340         ;; least 48 hours.
 341         (derivation->job name drv
 342                          #:period (hours 24)))))
 343
 344   (if (member system %guix-system-supported-systems)
 345       ;; Override the value of 'current-guix' used by system tests.  Using a
 346       ;; channel instance makes tests that rely on 'current-guix' less
 347       ;; expensive.  It also makes sure we get a valid Guix package when this
 348       ;; code is not running from a checkout.
 349       (map ->job (all-system-tests))
 350       '()))
 351
 352 (define (tarball-jobs store system)
 353   "Return jobs to build the self-contained Guix binary tarball."
 354   (define (->job name drv)
 355     (let ((name (string-append name "." system)))
 356       (parameterize ((%graft? #f))
 357         (derivation->job name drv
 358                          #:period (hours 24)))))
 359
 360   ;; XXX: Add a job for the stable Guix?
 361   (list
 362    (->job "binary-tarball"
 363           (run-with-store store
 364             (mbegin %store-monad
 365               (set-guile-for-build (default-guile))
 366               (>>= (profile-derivation (packages->manifest (list guix)))
 367                    (lambda (profile)
 368                      (self-contained-tarball "guix-binary" profile
 369                                              #:localstatedir? #t
 370                                              #:compressor
 371                                              (lookup-compressor "xz")))))
 372             #:system system))))
 373
 374 (define job-name
 375   ;; Return the name of a package's job.
 376   package-name)
 377
 378 (define package->job
 379   (let ((base-packages
 380          (delete-duplicates
 381           (append-map (match-lambda
 382                         ((_ package _ ...)
 383                          (match (package-transitive-inputs package)
 384                            (((_ inputs _ ...) ...)
 385                             inputs))))
 386                       (%final-inputs)))))
 387     (lambda (store package system)
 388       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
 389 valid."
 390       (cond ((member package base-packages)
 391              (package-job store (string-append "base." (job-name package))
 392                           package system))
 393             ((supported-package? package system)
 394              (let ((drv (package-derivation store package system
 395                                             #:graft? #f)))
 396                (and (substitutable-derivation? drv)
 397                     (package-job store (job-name package)
 398                                  package system))))
 399             (else
 400              #f)))))
 401
 402 (define (all-packages)
 403   "Return the list of packages to build."
 404   (define (adjust package result)
 405     (cond ((package-replacement package)
 406            ;; XXX: If PACKAGE and its replacement have the same name/version,
 407            ;; then both Cuirass jobs will have the same name, which
 408            ;; effectively means that the second one will be ignored.  Thus,
 409            ;; return the replacement first.
 410            (cons* (package-replacement package)   ;build both
 411                   package
 412                   result))
 413           ((package-superseded package)
 414            result)                                ;don't build it
 415           (else
 416            (cons package result))))
 417
 418   (fold-packages adjust
 419                  (fold adjust '()                 ;include base packages
 420                        (match (%final-inputs)
 421                          (((labels packages _ ...) ...)
 422                           packages)))
 423                  #:select? (const #t)))           ;include hidden packages
 424
 425 (define (arguments->manifests arguments channels)
 426   "Return the list of manifests extracted from ARGUMENTS."
 427   (map (lambda (manifest)
 428          (any (lambda (checkout)
 429                 (let ((path (in-vicinity checkout manifest)))
 430                   (and (file-exists? path)
 431                        path)))
 432               (map channel-url channels)))
 433        arguments))
 434
 435 (define (manifests->packages store manifests)
 436   "Return the list of packages found in MANIFESTS."
 437   (define (load-manifest manifest)
 438     (save-module-excursion
 439      (lambda ()
 440        (set-current-module (make-user-module '((guix profiles) (gnu))))
 441        (primitive-load manifest))))
 442
 443   (delete-duplicates!
 444    (map manifest-entry-item
 445         (append-map (compose manifest-entries
 446                              load-manifest)
 447                     manifests))))
 448
 449 \f
 450 ;;;
 451 ;;; Cuirass entry point.
 452 ;;;
 453
 454 (define (cuirass-jobs store arguments)
 455   "Register Cuirass jobs."
 456   (define subset
 457     (assoc-ref arguments 'subset))
 458
 459   (define systems
 460     (match (assoc-ref arguments 'systems)
 461       (#f              %cuirass-supported-systems)
 462       ((lst ...)       lst)
 463       ((? string? str) (call-with-input-string str read))))
 464
 465   (define channels
 466     (let ((channels (assq-ref arguments 'channels)))
 467       (map sexp->channel channels)))
 468
 469   (define guix
 470     (find guix-channel? channels))
 471
 472   (define commit
 473     (channel-commit guix))
 474
 475   (define source
 476     (channel-url guix))
 477
 478   ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
 479   (parameterize ((%graft? #f))
 480     ;; Return one job for each package, except bootstrap packages.
 481     (append-map
 482      (lambda (system)
 483        (format (current-error-port)
 484                "evaluating for '~a' (heap size: ~a MiB)...~%"
 485                system
 486                (round
 487                 (/ (assoc-ref (gc-stats) 'heap-size)
 488                    (expt 2. 20))))
 489        (invalidate-derivation-caches!)
 490        (match subset
 491          ('all
 492           ;; Build everything, including replacements.
 493           (let ((all (all-packages))
 494                 (job (lambda (package)
 495                        (package->job store package system))))
 496             (append
 497              (filter-map job all)
 498              (image-jobs store system)
 499              (system-test-jobs store system
 500                                #:source source
 501                                #:commit commit)
 502              (tarball-jobs store system)
 503              (cross-jobs store system))))
 504          ('core
 505           ;; Build core packages only.
 506           (append
 507            (map (lambda (package)
 508                   (package-job store (job-name package)
 509                                package system))
 510                 %core-packages)
 511            (cross-jobs store system)))
 512          ('guix
 513           ;; Build Guix modules only.
 514           (guix-jobs store systems
 515                      #:source source
 516                      #:commit commit))
 517          ('hello
 518           ;; Build hello package only.
 519           (let ((hello (specification->package "hello")))
 520             (list (package-job store (job-name hello)
 521                                hello system))))
 522          (('channels . channels)
 523           ;; Build only the packages from CHANNELS.
 524           (let ((all (all-packages)))
 525             (filter-map
 526              (lambda (package)
 527                (any (lambda (channel)
 528                       (and (member (channel-name channel) channels)
 529                            (package->job store package system)))
 530                     (package-channels package)))
 531              all)))
 532          (('packages . rest)
 533           ;; Build selected list of packages only.
 534           (let ((packages (map specification->package rest)))
 535             (map (lambda (package)
 536                    (package-job store (job-name package)
 537                                 package system))
 538                  packages)))
 539          (('manifests . rest)
 540           ;; Build packages in the list of manifests.
 541           (let* ((manifests (arguments->manifests rest channels))
 542                  (packages (manifests->packages store manifests)))
 543             (map (lambda (package)
 544                    (package-job store (job-name package)
 545                                 package system))
 546                  packages)))
 547          (else
 548           (error "unknown subset" subset))))
 549      systems)))