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