01/01: ci: Make sure the Guix checkout is the one providing Cuirass proc.

[guix-commits]

snape pushed a commit to branch master
in repository guix.

commit f71b0a0012d46bd30ead1a14ed58fd59647415e2
Author: Clément Lassieur <address@hidden>
Date:   Sun Nov 17 13:29:19 2019 +0100

    ci: Make sure the Guix checkout is the one providing Cuirass proc.
    
    Fixes <https://bugs.gnu.org/36378>.
    Reported by Reza Alizadeh Majd <address@hidden>.
    
    * 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 ++++++++++++++++++++++--------------
 gnu/ci.scm                     | 22 ++++++++++++++--------
 2 files changed, 36 insertions(+), 22 deletions(-)

diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index 775bbd9..f54302c 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 
<address@hidden>
 ;;; Copyright © 2017 Jan Nieuwenhuizen <address@hidden>
-;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2018, 2019 Clément Lassieur <address@hidden>
 ;;;
 ;;; 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))))))))
diff --git a/gnu/ci.scm b/gnu/ci.scm
index f24049e..d6eb2d0 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2017 Jan Nieuwenhuizen <address@hidden>
-;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2018, 2019 Clément Lassieur <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -374,6 +374,17 @@ valid."
                              load-manifest)
                     manifests))))
 
+(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)))
+
 
 ;;;
 ;;; Hydra entry point.
@@ -396,13 +407,8 @@ valid."
       ((? string? str) (call-with-input-string str read))))
 
   (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))
+    (or (find-current-checkout arguments)
+        (assq-ref arguments 'superior-guix-checkout)))
 
   (define commit
     (assq-ref checkout 'revision))