build-aux/hydra/gnu-system.scm

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