From f71b0a0012d46bd30ead1a14ed58fd59647415e2 Mon Sep 17 00:00:00 2001 From: Clément Lassieur Date: Sun, 17 Nov 2019 13:29:19 +0100 Subject: ci: Make sure the Guix checkout is the one providing Cuirass proc. Fixes . Reported by Reza Alizadeh Majd . * build-aux/hydra/gnu-system.scm (find-current-checkout): New procedure. (hydra-jobs): Use FIND-CURRENT-CHECKOUT to define CHECKOUT. Pass it to the inferior Guix as an extra argument whose key is 'superior-guix-checkout'. * gnu/ci.scm (find-current-checkout): New procedure. (hydra-jobs): Use FIND-CURRENT-CHECKOUT to define CHECKOUT. This will return '#f' if the current Guix is an inferior. In that case, use the 'superior-guix-checkout' argument provided by the superior Guix. --- build-aux/hydra/gnu-system.scm | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) (limited to 'build-aux/hydra') diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index 775bbd9db2..f54302cf63 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2017 Jan Nieuwenhuizen -;;; Copyright © 2018 Clément Lassieur +;;; Copyright © 2018, 2019 Clément Lassieur ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,16 +34,22 @@ (setvbuf (current-error-port) _IOLBF) (set-current-output-port (current-error-port)) +(define (find-current-checkout arguments) + "Find the first checkout of ARGUMENTS that provided the current file. +Return #f if no such checkout is found." + (let ((current-root + (canonicalize-path + (string-append (dirname (current-filename)) "/../..")))) + (find (lambda (argument) + (and=> (assq-ref argument 'file-name) + (lambda (name) + (string=? name current-root)))) arguments))) + (define (hydra-jobs store arguments) "Return a list of jobs where each job is a NAME/THUNK pair." + (define checkout - ;; Extract metadata about the 'guix' checkout. Its key in ARGUMENTS may - ;; vary, so pick up the first one that's neither 'subset' nor 'systems'. - (any (match-lambda - ((key . value) - (and (not (memq key '(systems subset))) - value))) - arguments)) + (find-current-checkout arguments)) (define commit (assq-ref checkout 'revision)) @@ -70,9 +76,11 @@ ((name . fields) ;; Hydra expects a thunk, so here it is. (cons name (lambda () fields)))) - (inferior-eval-with-store inferior store - `(lambda (store) - (map (match-lambda - ((name . thunk) - (cons name (thunk)))) - (hydra-jobs store ',arguments))))))) + (inferior-eval-with-store + inferior store + `(lambda (store) + (map (match-lambda + ((name . thunk) + (cons name (thunk)))) + (hydra-jobs store '((superior-guix-checkout . ,checkout) + ,@arguments)))))))) -- cgit 1.4.1