build-aux/hydra/gnu-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 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 utils) #:select (%current-system))
  42              (gnu packages)
  43              (gnu packages base)
  44              (gnu packages gawk)
  45              (gnu packages guile)
  46              (gnu packages gettext)
  47              (gnu packages multiprecision)
  48              (gnu packages make-bootstrap)
  49              (srfi srfi-1)
  50              (srfi srfi-26)
  51              (ice-9 match))
  52
  53 ;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
  54 ;; port to the bit bucket, let us write to the error port instead.
  55 (setvbuf (current-error-port) _IOLBF)
  56 (set-current-output-port (current-error-port))
  57
  58 (define* (package->alist store package system
  59                          #:optional (package-derivation package-derivation))
  60   "Convert PACKAGE to an alist suitable for Hydra."
  61   `((derivation . ,(package-derivation store package system))
  62     (description . ,(package-synopsis package))
  63     (long-description . ,(package-description package))
  64     (license . ,(package-license package))
  65     (home-page . ,(package-home-page package))
  66     (maintainers . ("bug-guix@gnu.org"))))
  67
  68 (define (package-job store job-name package system)
  69   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  70   `(,job-name . ,(cut package->alist store package system)))
  71
  72 (define (package-cross-job store job-name package target system)
  73   "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
  74 SYSTEM."
  75   `(,(symbol-append (string->symbol target) (string->symbol ".") job-name) .
  76     ,(cute package->alist store package system
  77            (cut package-cross-derivation <> <> target <>))))
  78
  79 (define %packages-to-cross-build
  80   (list gmp mpfr mpc coreutils findutils diffutils patch sed grep
  81         gawk gettext hello guile-2.0
  82         ;; %bootstrap-binaries-tarball
  83         ;; %binutils-bootstrap-tarball
  84         ;; %glibc-bootstrap-tarball
  85         ;; %gcc-bootstrap-tarball
  86         ;; %guile-bootstrap-tarball
  87         ))
  88
  89 (define %cross-targets
  90   '("mips64el-linux-gnu"))
  91
  92 (define (hydra-jobs store arguments)
  93   "Return Hydra jobs."
  94   (define system
  95     (or (assoc-ref arguments system)
  96         (%current-system)))
  97
  98   (define job-name
  99     (compose string->symbol package-full-name))
 100
 101   (define cross-jobs
 102     (append-map (lambda (target)
 103                   (map (lambda (package)
 104                          (package-cross-job store (job-name package)
 105                                             package target system))
 106                        %packages-to-cross-build))
 107                 %cross-targets))
 108
 109   ;; Return one job for each package, except bootstrap packages.
 110   (let ((base-packages (delete-duplicates
 111                         (append-map (match-lambda
 112                                      ((_ package _ ...)
 113                                       (match (package-transitive-inputs
 114                                               package)
 115                                         (((_ inputs _ ...) ...)
 116                                          inputs))))
 117                                     %final-inputs))))
 118     (fold-packages (lambda (package result)
 119                      (if (member package base-packages)
 120                          result
 121                          (cons (package-job store (job-name package)
 122                                             package system)
 123                                result)))
 124                    cross-jobs)))