build-aux/hydra/gnu-system.scm

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