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 store)
  40              (guix packages)
  41              (guix derivations)
  42              ((guix utils) #:select (%current-system))
  43              (gnu packages)
  44              (gnu packages base)
  45              (gnu packages gawk)
  46              (gnu packages guile)
  47              (gnu packages gettext)
  48              (gnu packages compression)
  49              (gnu packages multiprecision)
  50              (gnu packages make-bootstrap)
  51              (srfi srfi-1)
  52              (srfi srfi-26)
  53              (ice-9 match))
  54
  55 ;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
  56 ;; port to the bit bucket, let us write to the error port instead.
  57 (setvbuf (current-error-port) _IOLBF)
  58 (set-current-output-port (current-error-port))
  59
  60 (define* (package->alist store package system
  61                          #:optional (package-derivation package-derivation))
  62   "Convert PACKAGE to an alist suitable for Hydra."
  63   `((derivation . ,(derivation-file-name
  64                     (package-derivation store package system)))
  65     (description . ,(package-synopsis package))
  66     (long-description . ,(package-description package))
  67     (license . ,(package-license package))
  68     (home-page . ,(package-home-page package))
  69     (maintainers . ("bug-guix@gnu.org"))
  70
  71     ;; Work around versions of 'hydra-eval-guile-jobs' before Hydra commit
  72     ;; 61448ca (27 Feb. 2014) which used a default timeout of 2h.
  73     (timeout . 72000)))
  74
  75 (define (package-job store job-name package system)
  76   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  77   (let ((job-name (symbol-append job-name (string->symbol ".")
  78                                  (string->symbol system))))
  79     `(,job-name . ,(cut package->alist store package system))))
  80
  81 (define (package-cross-job store job-name package target system)
  82   "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
  83 SYSTEM."
  84   `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
  85                     (string->symbol ".") (string->symbol system)) .
  86     ,(cute package->alist store package system
  87            (cut package-cross-derivation <> <> target <>))))
  88
  89 (define %core-packages
  90   ;; Note: Don't put the '-final' package variants because (1) that's
  91   ;; implicit, and (2) they cannot be cross-built (due to the explicit input
  92   ;; chain.)
  93   (list gcc glibc binutils
  94         gmp mpfr mpc coreutils findutils diffutils patch sed grep
  95         gawk gnu-gettext hello guile-2.0 zlib gzip xz
  96         %bootstrap-binaries-tarball
  97         %binutils-bootstrap-tarball
  98         %glibc-bootstrap-tarball
  99         %gcc-bootstrap-tarball
 100         %guile-bootstrap-tarball
 101         %bootstrap-tarballs))
 102
 103 (define %packages-to-cross-build
 104   %core-packages)
 105
 106 (define %cross-targets
 107   '("mips64el-linux-gnu"
 108     "mips64el-linux-gnuabi64"))
 109
 110 (define (hydra-jobs store arguments)
 111   "Return Hydra jobs."
 112   (define systems
 113     (match (filter-map (match-lambda
 114                         (('system . value)
 115                          value)
 116                         (_ #f))
 117                        arguments)
 118       ((lst ..1)
 119        lst)
 120       (_
 121        (list (%current-system)))))
 122
 123   (define subset
 124     (match (assoc-ref arguments 'subset)
 125       ("core" 'core)                              ; only build core packages
 126       (_ 'all)))                                  ; build everything
 127
 128   (define job-name
 129     (compose string->symbol package-full-name))
 130
 131   (define (cross-jobs system)
 132     (append-map (lambda (target)
 133                   (map (lambda (package)
 134                          (package-cross-job store (job-name package)
 135                                             package target system))
 136                        %packages-to-cross-build))
 137                 %cross-targets))
 138
 139   ;; Return one job for each package, except bootstrap packages.
 140   (let ((base-packages (delete-duplicates
 141                         (append-map (match-lambda
 142                                      ((_ package _ ...)
 143                                       (match (package-transitive-inputs
 144                                               package)
 145                                         (((_ inputs _ ...) ...)
 146                                          inputs))))
 147                                     %final-inputs))))
 148     (append-map (lambda (system)
 149                   (case subset
 150                     ((all)
 151                      ;; Build everything.
 152                      (fold-packages (lambda (package result)
 153                                       (if (member package base-packages)
 154                                           result
 155                                           (cons (package-job store (job-name package)
 156                                                              package system)
 157                                                 result)))
 158                                     (cross-jobs system)))
 159                     ((core)
 160                      ;; Build core packages only.
 161                      (append (map (lambda (package)
 162                                     (package-job store (job-name package)
 163                                                  package system))
 164                                   %core-packages)
 165                              (cross-jobs system)))
 166                     (else
 167                      (error "unknown subset" subset))))
 168                 systems)))