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