03/04: ci: Use a valid 'current-guix'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 7e6d8d366a61f951936ed83371877ce006f679f6
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 20 00:20:34 2019 +0100

    ci: Use a valid 'current-guix'.
    
    This fixes a regression introduced in
    b5f8c2c88543158e8aca76aa98f9009f6b9e743a whereby 'current-guix' (needed
    by some of the system tests) would fail to build.
    Reported by Ricardo Wurmus <address@hidden>.
    
    It also speeds up compilation of 'current-guix' since the channel
    instance is already compiled or can be built quickly compared to the
    default 'current-guix'.
    
    * gnu/packages/package-management.scm (current-guix-package): New
    variable.
    (current-guix): Honor it.
    * gnu/ci.scm (channel-build-system): New variable.
    (channel-instances->derivation): New procedure.
    (system-test-jobs): Add #:source and #:commit parameters.
    Define 'instance' and parameterize CURRENT-GUIX-PACKAGE.
    (hydra-jobs)[checkout, commit, source]: New variables.
    Pass #:source and #:commit to 'system-test-jobs'.
---
 gnu/ci.scm                          | 65 ++++++++++++++++++++++++++++++++++---
 gnu/packages/package-management.scm | 19 +++++++----
 2 files changed, 74 insertions(+), 10 deletions(-)

diff --git a/gnu/ci.scm b/gnu/ci.scm
index c071f21..943fbb6 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
+;;; 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>
 ;;;
@@ -24,7 +24,9 @@
   #:use-module (guix grafts)
   #:use-module (guix profiles)
   #:use-module (guix packages)
+  #:use-module (guix channels)
   #:use-module (guix derivations)
+  #:use-module (guix build-system)
   #:use-module (guix monads)
   #:use-module (guix ui)
   #:use-module ((guix licenses)
@@ -188,8 +190,40 @@ system.")
                                               "iso9660"))))))
       '()))
 
-(define (system-test-jobs store system)
+(define channel-build-system
+  ;; Build system used to "convert" a channel instance to a package.
+  (let* ((build (lambda* (store name inputs
+                                #:key instance #:allow-other-keys)
+                  (run-with-store store
+                    (channel-instances->derivation (list instance)))))
+         (lower (lambda* (name #:key system instance #:allow-other-keys)
+                  (bag
+                    (name name)
+                    (system system)
+                    (build build)
+                    (arguments `(#:instance ,instance))))))
+    (build-system (name 'channel)
+                  (description "Turn a channel instance into a package.")
+                  (lower lower))))
+
+(define (channel-instance->package instance)
+  "Return a package for the given channel INSTANCE."
+  (package
+    (inherit guix)
+    (version (or (string-take (channel-instance-commit instance) 7)
+                 (string-append (package-version guix) "+")))
+    (build-system channel-build-system)
+    (arguments `(#:instance ,instance))
+    (inputs '())
+    (native-inputs '())
+    (propagated-inputs '())))
+
+(define* (system-test-jobs store system
+                           #:key source commit)
   "Return a list of jobs for the system tests."
+  (define instance
+    (checkout->channel-instance source #:commit commit))
+
   (define (test->thunk test)
     (lambda ()
       (define drv
@@ -217,7 +251,13 @@ system.")
       (cons name (test->thunk test))))
 
   (if (member system %guixsd-supported-systems)
-      (map ->job (all-system-tests))
+      ;; Override the value of 'current-guix' used by system tests.  Using a
+      ;; channel instance makes tests that rely on 'current-guix' less
+      ;; expensive.  It also makes sure we get a valid Guix package when this
+      ;; code is not running from a checkout.
+      (parameterize ((current-guix-package
+                      (channel-instance->package instance)))
+        (map ->job (all-system-tests)))
       '()))
 
 (define (tarball-jobs store system)
@@ -343,6 +383,21 @@ valid."
       ((lst ...)       lst)
       ((? 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))
+
+  (define commit
+    (assq-ref checkout 'revision))
+
+  (define source
+    (assq-ref checkout 'file-name))
+
   (define (cross-jobs system)
     (define (from-32-to-64? target)
       ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
@@ -405,7 +460,9 @@ valid."
                                                 system))))
                        (append (filter-map job all)
                                (qemu-jobs store system)
-                               (system-test-jobs store system)
+                               (system-test-jobs store system
+                                                 #:source source
+                                                 #:commit commit)
                                (tarball-jobs store system)
                                (cross-jobs system))))
                     ((core)
diff --git a/gnu/packages/package-management.scm 
b/gnu/packages/package-management.scm
index 2a33a93..05da819 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -399,6 +399,12 @@ generated file."
     (_
      #t)))
 
+(define-public current-guix-package
+  ;; This parameter allows callers to override the package that 'current-guix'
+  ;; returns.  This is useful when 'current-guix' cannot compute it by itself,
+  ;; for instance because it's not running from a source code checkout.
+  (make-parameter #f))
+
 (define-public current-guix
   (let* ((repository-root (canonicalize-path
                            (string-append (current-source-directory)
@@ -409,12 +415,13 @@ generated file."
       "Return a package representing Guix built from the current source tree.
 This works by adding the current source tree to the store (after filtering it
 out) and returning a package that uses that as its 'source'."
-      (package
-        (inherit guix)
-        (version (string-append (package-version guix) "+"))
-        (source (local-file repository-root "guix-current"
-                            #:recursive? #t
-                            #:select? (force select?)))))))
+      (or (current-guix-package)
+          (package
+            (inherit guix)
+            (version (string-append (package-version guix) "+"))
+            (source (local-file repository-root "guix-current"
+                                #:recursive? #t
+                                #:select? (force select?))))))))
 
 
 ;;;