build-aux/hydra/gnu-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;; Copyright © 2018, 2019 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) 'line)
  35 (set-current-output-port (current-error-port))
  36
  37 (define (find-current-checkout arguments)
  38   "Find the first checkout of ARGUMENTS that provided the current file.
  39 Return #f if no such checkout is found."
  40   (let ((current-root
  41          (canonicalize-path
  42           (string-append (dirname (current-filename)) "/../.."))))
  43     (find (lambda (argument)
  44             (and=> (assq-ref argument 'file-name)
  45                    (lambda (name)
  46                      (string=? name current-root)))) arguments)))
  47
  48 (define (hydra-jobs store arguments)
  49   "Return a list of jobs where each job is a NAME/THUNK pair."
  50
  51   (define checkout
  52     (find-current-checkout arguments))
  53
  54   (define commit
  55     (assq-ref checkout 'revision))
  56
  57   (define source
  58     (assq-ref checkout 'file-name))
  59
  60   (define instance
  61     (checkout->channel-instance source #:commit commit))
  62
  63   (define derivation
  64     ;; Compute the derivation of Guix for COMMIT.
  65     (run-with-store store
  66       (channel-instances->derivation (list instance))))
  67
  68   ;; TODO: Remove 'show-what-to-build' call when Cuirass' 'evaluate' scripts
  69   ;; uses 'with-build-handler'.
  70   (show-what-to-build store (list derivation))
  71   (build-derivations store (list derivation))
  72
  73   ;; Open an inferior for the just-built Guix.
  74   (let ((inferior (open-inferior (derivation->output-path derivation))))
  75     (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
  76
  77     (map (match-lambda
  78            ((name . fields)
  79             ;; Hydra expects a thunk, so here it is.
  80             (cons name (lambda () fields))))
  81          (inferior-eval-with-store
  82           inferior store
  83           `(lambda (store)
  84              (map (match-lambda
  85                     ((name . thunk)
  86                      (cons name (thunk))))
  87                   (hydra-jobs store '((superior-guix-checkout . ,checkout)
  88                                       ,@arguments))))))))