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