From c5a3d8f6469f9fb4d47e2d4c84980ab04aedb398 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 5 Mar 2020 14:54:17 +0100
Subject: tests: "make check-system" includes the current commit ID, if any.

* build-aux/run-system-tests.scm (source-commit): New procedure.
(tests-for-current-guix): Add 'commit' parameter and pass it to
'channel-source->package'.
(run-system-tests): Call 'source-commit' and pass the result to
'tests-for-current-guix'.
---
 build-aux/run-system-tests.scm | 31 ++++++++++++++++++++++++++-----
 1 file changed, 26 insertions(+), 5 deletions(-)

diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
index a4c019ab0b..b5403e0ece 100644
--- a/build-aux/run-system-tests.scm
+++ b/build-aux/run-system-tests.scm
@@ -29,6 +29,7 @@ (define-module (run-system-tests)
   #:use-module ((guix git-download) #:select (git-predicate))
   #:use-module (guix utils)
   #:use-module (guix ui)
+  #:use-module (git)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
@@ -52,7 +53,24 @@ (define (filterm mproc lst)                       ;XXX: move to (guix monads)
                 lst)
          (lift1 reverse %store-monad))))
 
-(define (tests-for-current-guix source)
+(define (source-commit directory)
+  "Return the commit of the head of DIRECTORY or #f if it could not be
+determined."
+  (let ((repository #f))
+    (catch 'git-error
+      (lambda ()
+        (set! repository (repository-open directory))
+        (let* ((head   (repository-head repository))
+               (target (reference-target head))
+               (commit (oid->string target)))
+          (repository-close! repository)
+          commit))
+      (lambda _
+        (when repository
+          (repository-close! repository))
+        #f))))
+
+(define (tests-for-current-guix source commit)
   "Return a list of tests for perform, using Guix built from SOURCE, a channel
 instance."
   ;; Honor the 'TESTS' environment variable so that one can select a subset
@@ -60,7 +78,7 @@ (define (tests-for-current-guix source)
   ;;
   ;;   make check-system TESTS=installed-os
   (parameterize ((current-guix-package
-                  (channel-source->package source)))
+                  (channel-source->package source #:commit commit)))
     (match (getenv "TESTS")
       (#f
        (all-system-tests))
@@ -69,12 +87,15 @@ (define (tests-for-current-guix source)
                  (member (system-test-name test) tests))
                (all-system-tests))))))
 
-
-
 (define (run-system-tests . args)
   (define source
     (string-append (current-source-directory) "/.."))
 
+  (define commit
+    ;; Fetch the current commit ID so we can potentially build the same
+    ;; derivation as ci.guix.gnu.org.
+    (source-commit source))
+
   (with-store store
     (with-status-verbosity 2
       (run-with-store store
@@ -86,7 +107,7 @@ (define source
                                                     #:select?
                                                     (or (git-predicate source)
                                                         (const #t))))
-                             (tests ->  (tests-for-current-guix source))
+                             (tests ->  (tests-for-current-guix source commit))
                              (drv (mapm %store-monad system-test-value tests))
                              (out -> (map derivation->output-path drv)))
           (format (current-error-port) "Running ~a system tests...~%"
-- 
cgit v1.2.3