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