build-aux/hydra/gnu-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016 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     "i686-w64-mingw32"))
 128
 129 (define %guixsd-supported-systems
 130   '("x86_64-linux" "i686-linux"))
 131
 132 (define (qemu-jobs store system)
 133   "Return a list of jobs that build QEMU images for SYSTEM."
 134   (define (->alist drv)
 135     `((derivation . ,(derivation-file-name drv))
 136       (description . "Stand-alone QEMU image of the GNU system")
 137       (long-description . "This is a demo stand-alone QEMU image of the GNU
 138 system.")
 139       (license . ,gpl3+)
 140       (home-page . ,%guix-home-page-url)
 141       (maintainers . ("bug-guix@gnu.org"))))
 142
 143   (define (->job name drv)
 144     (let ((name (symbol-append name (string->symbol ".")
 145                                (string->symbol system))))
 146       `(,name . ,(lambda ()
 147                    (parameterize ((%graft? #f))
 148                      (->alist drv))))))
 149
 150   (define MiB
 151     (expt 2 20))
 152
 153   (if (member system %guixsd-supported-systems)
 154       (list (->job 'usb-image
 155                    (run-with-store store
 156                      (mbegin %store-monad
 157                        (set-guile-for-build (default-guile))
 158                        (system-disk-image installation-os
 159                                           #:disk-image-size
 160                                           (* 1024 MiB))))))
 161       '()))
 162
 163 (define (system-test-jobs store system)
 164   "Return a list of jobs for the system tests."
 165   (define (test->thunk test)
 166     (lambda ()
 167       (define drv
 168         (run-with-store store
 169           (mbegin %store-monad
 170             (set-current-system system)
 171             (set-grafting #f)
 172             (set-guile-for-build (default-guile))
 173             (system-test-value test))))
 174
 175       `((derivation . ,(derivation-file-name drv))
 176         (description . ,(format #f "GuixSD '~a' system test"
 177                                 (system-test-name test)))
 178         (long-description . ,(system-test-description test))
 179         (license . ,gpl3+)
 180         (home-page . ,%guix-home-page-url)
 181         (maintainers . ("bug-guix@gnu.org")))))
 182
 183   (define (->job test)
 184     (let ((name (string->symbol
 185                  (string-append "test." (system-test-name test)
 186                                 "." system))))
 187       (cons name (test->thunk test))))
 188
 189   (if (member system %guixsd-supported-systems)
 190       (map ->job (all-system-tests))
 191       '()))
 192
 193 (define (tarball-jobs store system)
 194   "Return Hydra jobs to build the self-contained Guix binary tarball."
 195   (define (->alist drv)
 196     `((derivation . ,(derivation-file-name drv))
 197       (description . "Stand-alone binary Guix tarball")
 198       (long-description . "This is a tarball containing binaries of Guix and
 199 all its dependencies, and ready to be installed on non-GuixSD distributions.")
 200       (license . ,gpl3+)
 201       (home-page . ,%guix-home-page-url)
 202       (maintainers . ("bug-guix@gnu.org"))))
 203
 204   (define (->job name drv)
 205     (let ((name (symbol-append name (string->symbol ".")
 206                                (string->symbol system))))
 207       `(,name . ,(lambda ()
 208                    (parameterize ((%graft? #f))
 209                      (->alist drv))))))
 210
 211   ;; XXX: Add a job for the stable Guix?
 212   (list (->job 'binary-tarball
 213                (run-with-store store
 214                  (mbegin %store-monad
 215                    (set-guile-for-build (default-guile))
 216                    (self-contained-tarball))
 217                  #:system system))))
 218
 219 (define job-name
 220   ;; Return the name of a package's job.
 221   (compose string->symbol package-full-name))
 222
 223 (define package->job
 224   (let ((base-packages
 225          (delete-duplicates
 226           (append-map (match-lambda
 227                        ((_ package _ ...)
 228                         (match (package-transitive-inputs package)
 229                           (((_ inputs _ ...) ...)
 230                            inputs))))
 231                       (%final-inputs)))))
 232     (lambda (store package system)
 233       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
 234 valid."
 235       (cond ((member package base-packages)
 236              #f)
 237             ((supported-package? package system)
 238              (package-job store (job-name package) package system))
 239             (else
 240              #f)))))
 241
 242 \f
 243 ;;;
 244 ;;; Hydra entry point.
 245 ;;;
 246
 247 (define (hydra-jobs store arguments)
 248   "Return Hydra jobs."
 249   (define subset
 250     (match (assoc-ref arguments 'subset)
 251       ("core" 'core)                              ; only build core packages
 252       (_ 'all)))                                  ; build everything
 253
 254   (define (cross-jobs system)
 255     (define (from-32-to-64? target)
 256       ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
 257       ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
 258       ;; mips64el-linux-gnuabi64.
 259       (and (or (string-prefix? "i686-" system)
 260                (string-prefix? "armhf-" system))
 261            (string-suffix? "64" target)))
 262
 263     (define (same? target)
 264       ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
 265       ;; don't try to cross-compile to 'mips64el-linux-gnu' from
 266       ;; 'mips64el-linux'.
 267       (string-contains target system))
 268
 269     (define (pointless? target)
 270       ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
 271       (and (string-contains target "mingw")
 272            (not (string=? "x86_64-linux" system))))
 273
 274     (define (either proc1 proc2 proc3)
 275       (lambda (x)
 276         (or (proc1 x) (proc2 x) (proc3 x))))
 277
 278     (append-map (lambda (target)
 279                   (map (lambda (package)
 280                          (package-cross-job store (job-name package)
 281                                             package target system))
 282                        %packages-to-cross-build))
 283                 (remove (either from-32-to-64? same? pointless?)
 284                         %cross-targets)))
 285
 286   ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
 287   (parameterize ((%graft? #f))
 288     ;; Return one job for each package, except bootstrap packages.
 289     (append-map (lambda (system)
 290                   (case subset
 291                     ((all)
 292                      ;; Build everything, including replacements.
 293                      (let ((all (fold-packages
 294                                  (lambda (package result)
 295                                    (if (package-replacement package)
 296                                        (cons* package
 297                                               (package-replacement package)
 298                                               result)
 299                                        (cons package result)))
 300                                  '()))
 301                            (job (lambda (package)
 302                                   (package->job store package
 303                                                 system))))
 304                        (append (filter-map job all)
 305                                (qemu-jobs store system)
 306                                (system-test-jobs store system)
 307                                (tarball-jobs store system)
 308                                (cross-jobs system))))
 309                     ((core)
 310                      ;; Build core packages only.
 311                      (append (map (lambda (package)
 312                                     (package-job store (job-name package)
 313                                                  package system))
 314                                   %core-packages)
 315                              (cross-jobs system)))
 316                     (else
 317                      (error "unknown subset" subset))))
 318                 %hydra-supported-systems)))