build-aux/hydra/gnu-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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 packages)
  42              (guix derivations)
  43              (guix monads)
  44              ((guix licenses) #:select (gpl3+))
  45              ((guix utils) #:select (%current-system))
  46              ((guix scripts system) #:select (read-operating-system))
  47              (gnu packages)
  48              (gnu packages gcc)
  49              (gnu packages base)
  50              (gnu packages gawk)
  51              (gnu packages guile)
  52              (gnu packages gettext)
  53              (gnu packages compression)
  54              (gnu packages multiprecision)
  55              (gnu packages make-bootstrap)
  56              (gnu packages commencement)
  57              (gnu packages package-management)
  58              (gnu system)
  59              (gnu system vm)
  60              (gnu system install)
  61              (srfi srfi-1)
  62              (srfi srfi-26)
  63              (ice-9 match))
  64
  65 ;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
  66 ;; port to the bit bucket, let us write to the error port instead.
  67 (setvbuf (current-error-port) _IOLBF)
  68 (set-current-output-port (current-error-port))
  69
  70 (define* (package->alist store package system
  71                          #:optional (package-derivation package-derivation))
  72   "Convert PACKAGE to an alist suitable for Hydra."
  73   `((derivation . ,(derivation-file-name
  74                     (package-derivation store package system
  75                                         #:graft? #f)))
  76     (description . ,(package-synopsis package))
  77     (long-description . ,(package-description package))
  78     (license . ,(package-license package))
  79     (home-page . ,(package-home-page package))
  80     (maintainers . ("bug-guix@gnu.org"))
  81
  82     ;; Work around versions of 'hydra-eval-guile-jobs' before Hydra commit
  83     ;; 61448ca (27 Feb. 2014) which used a default timeout of 2h.
  84     (timeout . 72000)))
  85
  86 (define (package-job store job-name package system)
  87   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  88   (let ((job-name (symbol-append job-name (string->symbol ".")
  89                                  (string->symbol system))))
  90     `(,job-name . ,(cut package->alist store package system))))
  91
  92 (define (package-cross-job store job-name package target system)
  93   "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
  94 SYSTEM."
  95   `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
  96                     (string->symbol ".") (string->symbol system)) .
  97     ,(cute package->alist store package system
  98            (lambda* (store package system #:key graft?)
  99              (package-cross-derivation store package target system
 100                                        #:graft? graft?)))))
 101
 102 (define %core-packages
 103   ;; Note: Don't put the '-final' package variants because (1) that's
 104   ;; implicit, and (2) they cannot be cross-built (due to the explicit input
 105   ;; chain.)
 106   (list gcc-4.8 gcc-4.7 glibc binutils
 107         gmp mpfr mpc coreutils findutils diffutils patch sed grep
 108         gawk gnu-gettext hello guile-2.0 zlib gzip xz
 109         %bootstrap-binaries-tarball
 110         %binutils-bootstrap-tarball
 111         %glibc-bootstrap-tarball
 112         %gcc-bootstrap-tarball
 113         %guile-bootstrap-tarball
 114         %bootstrap-tarballs))
 115
 116 (define %packages-to-cross-build
 117   %core-packages)
 118
 119 (define %cross-targets
 120   '("mips64el-linux-gnu"
 121     "mips64el-linux-gnuabi64"))
 122
 123 (define (demo-os)
 124   "Return the \"demo\" 'operating-system' structure."
 125   (let* ((dir  (dirname (assoc-ref (current-source-location) 'filename)))
 126          (file (string-append dir "/demo-os.scm")))
 127     (read-operating-system file)))
 128
 129 (define (qemu-jobs store system)
 130   "Return a list of jobs that build QEMU images for SYSTEM."
 131   (define (->alist drv)
 132     `((derivation . ,(derivation-file-name drv))
 133       (description . "Stand-alone QEMU image of the GNU system")
 134       (long-description . "This is a demo stand-alone QEMU image of the GNU
 135 system.")
 136       (license . ,gpl3+)
 137       (home-page . ,%guix-home-page-url)
 138       (maintainers . ("bug-guix@gnu.org"))))
 139
 140   (define (->job name drv)
 141     (let ((name (symbol-append name (string->symbol ".")
 142                                (string->symbol system))))
 143       `(,name . ,(cut ->alist drv))))
 144
 145   (define MiB
 146     (expt 2 20))
 147
 148   (if (member system '("x86_64-linux" "i686-linux"))
 149       (list (->job 'qemu-image
 150                    (run-with-store store
 151                      (mbegin %store-monad
 152                        (set-guile-for-build (default-guile))
 153                        (system-qemu-image (demo-os)
 154                                           #:disk-image-size
 155                                           (* 1400 MiB))))) ; 1.4 GiB
 156             (->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                                           (* 850 MiB))))))
 163       '()))
 164
 165 (define (tarball-jobs store system)
 166   "Return Hydra jobs to build the self-contained Guix binary tarball."
 167   (define (->alist drv)
 168     `((derivation . ,(derivation-file-name drv))
 169       (description . "Stand-alone binary Guix tarball")
 170       (long-description . "This is a tarball containing binaries of Guix and
 171 all its dependencies, and ready to be installed on non-GuixSD distributions.")
 172       (license . ,gpl3+)
 173       (home-page . ,%guix-home-page-url)
 174       (maintainers . ("bug-guix@gnu.org"))))
 175
 176   (define (->job name drv)
 177     (let ((name (symbol-append name (string->symbol ".")
 178                                (string->symbol system))))
 179       `(,name . ,(cut ->alist drv))))
 180
 181   ;; XXX: Add a job for the stable Guix?
 182   (list (->job 'binary-tarball
 183                (run-with-store store
 184                  (mbegin %store-monad
 185                    (set-guile-for-build (default-guile))
 186                    (self-contained-tarball))
 187                  #:system system))))
 188
 189 (define job-name
 190   ;; Return the name of a package's job.
 191   (compose string->symbol package-full-name))
 192
 193 (define package->job
 194   (let ((base-packages
 195          (delete-duplicates
 196           (append-map (match-lambda
 197                        ((_ package _ ...)
 198                         (match (package-transitive-inputs package)
 199                           (((_ inputs _ ...) ...)
 200                            inputs))))
 201                       %final-inputs))))
 202     (lambda (store package system)
 203       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
 204 valid."
 205       (cond ((member package base-packages)
 206              #f)
 207             ((supported-package? package system)
 208              (package-job store (job-name package) package system))
 209             (else
 210              #f)))))
 211
 212 \f
 213 (define %hydra-supported-systems
 214   ;; This is the list of system types for which build slaves are available.
 215   '("x86_64-linux" "i686-linux" "mips64el-linux"))
 216
 217 ;;;
 218 ;;; Hydra entry point.
 219 ;;;
 220
 221 (define (hydra-jobs store arguments)
 222   "Return Hydra jobs."
 223   (define subset
 224     (match (assoc-ref arguments 'subset)
 225       ("core" 'core)                              ; only build core packages
 226       (_ 'all)))                                  ; build everything
 227
 228   (define (cross-jobs system)
 229     (define (from-32-to-64? target)
 230       ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.
 231       ;; This hacks prevents known-to-fail cross-builds from i686-linux to
 232       ;; mips64el-linux-gnuabi64.
 233       (and (string-prefix? "i686-" system)
 234            (string-suffix? "64" target)))
 235
 236     (define (same? target)
 237       ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
 238       ;; don't try to cross-compile to 'mips64el-linux-gnu' from
 239       ;; 'mips64el-linux'.
 240       (string-contains target system))
 241
 242     (define (either proc1 proc2)
 243       (lambda (x)
 244         (or (proc1 x) (proc2 x))))
 245
 246     (append-map (lambda (target)
 247                   (map (lambda (package)
 248                          (package-cross-job store (job-name package)
 249                                             package target system))
 250                        %packages-to-cross-build))
 251                 (remove (either from-32-to-64? same?) %cross-targets)))
 252
 253   ;; Return one job for each package, except bootstrap packages.
 254   (append-map (lambda (system)
 255                 (case subset
 256                   ((all)
 257                    ;; Build everything.
 258                    (fold-packages (lambda (package result)
 259                                     (let ((job (package->job store package
 260                                                              system)))
 261                                       (if job
 262                                           (cons job result)
 263                                           result)))
 264                                   (append (qemu-jobs store system)
 265                                           (tarball-jobs store system)
 266                                           (cross-jobs system))))
 267                   ((core)
 268                    ;; Build core packages only.
 269                    (append (map (lambda (package)
 270                                   (package-job store (job-name package)
 271                                                package system))
 272                                 %core-packages)
 273                            (cross-jobs system)))
 274                   (else
 275                    (error "unknown subset" subset))))
 276               %hydra-supported-systems))