build-aux/hydra/gnu-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;;
  22 ;;; This file defines build jobs for the Hydra continuation integration
  23 ;;; tool.
  24 ;;;
  25
  26 (use-modules (guix inferior) (guix channels)
  27              (guix)
  28              (guix ui)
  29              (srfi srfi-1)
  30              (ice-9 match))
  31
  32 ;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
  33 ;; port to the bit bucket, let us write to the error port instead.
  34 (setvbuf (current-error-port) _IOLBF)
  35 (set-current-output-port (current-error-port))
  36
  37 (define (hydra-jobs store arguments)
  38   "Return a list of jobs where each job is a NAME/THUNK pair."
  39   (define checkout
  40     ;; Extract metadata about the 'guix' checkout.  Its key in ARGUMENTS may
  41     ;; vary, so pick up the first one that's neither 'subset' nor 'systems'.
  42     (any (match-lambda
  43            ((key . value)
  44             (and (not (memq key '(systems subset)))
  45                  value)))
  46          arguments))
  47
  48   (define commit
  49     (assq-ref checkout 'revision))
  50
  51   (define source
  52     (assq-ref checkout 'file-name))
  53
  54   (define instance
  55     (checkout->channel-instance source #:commit commit))
  56
  57   (define derivation
  58     ;; Compute the derivation of Guix for COMMIT.
  59     (run-with-store store
  60       (channel-instances->derivation (list instance))))
  61
  62   (show-what-to-build store (list derivation))
  63   (build-derivations store (list derivation))
  64
  65   ;; Open an inferior for the just-built Guix.
  66   (let ((inferior (open-inferior (derivation->output-path derivation))))
  67     (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
  68
  69     (map (match-lambda
  70            ((name . fields)
  71             ;; Hydra expects a thunk, so here it is.
  72             (cons name (lambda () fields))))
  73          (inferior-eval-with-store inferior store
  74                                    `(lambda (store)
  75                                       (map (match-lambda
  76                                              ((name . thunk)
  77                                               (cons name (thunk))))
  78                                            (hydra-jobs store ',arguments)))))))