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