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