gnu/ci.scm

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