[bug#53144] [PATCH 11/13] git: Support resolving references without cloning.

[Maxime Devos]

* guix/git.scm (remote-refs): Split off some logic to ...
  (call-with-detached-remote): ... this new procedure.
  (lookup-reference): New procedure.
* tests/git.scm ("lookup-reference: branch and HEAD"): New test.
---
 guix/git.scm  | 57 +++++++++++++++++++++++++++++++++++++++------------
 tests/git.scm | 22 +++++++++++++++++++-
 2 files changed, 65 insertions(+), 14 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 43e85a5026..1c07eba584 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -62,6 +62,7 @@ (define-module (guix git)
             commit-relation
 
             remote-refs
+            lookup-reference
 
             git-checkout
             git-checkout?
@@ -628,6 +629,22 @@ (define (commit-relation old new)
 ;;; Remote operations.
 ;;;
 
+;; TODO: it would be nice to use 'remote-create-detached' here,
+;; but that procedure isn't in any released version of guile-git yet.
+(define (call-with-detached-remote url proc)
+  "Call PROC with a remote for URL.  The remote is closed after PROC returns."
+  (call-with-temporary-directory
+   (lambda (cache-directory)
+     (let* ((repository (repository-init cache-directory))
+            ;; Create an in-memory remote so we don't touch disk.
+            (remote (remote-create-anonymous repository url)))
+       (remote-connect remote)
+       (let-values ((result (proc remote)))
+         ;; Wait until we're finished with the repository before closing it.
+         (remote-disconnect remote)
+         (repository-close! repository)
+         (apply values result))))))
+
 (define* (remote-refs url #:key tags?)
   "Return the list of references advertised at Git repository URL.  If TAGS?
 is true, limit to only refs/tags."
@@ -649,19 +666,33 @@ (define (remote-head->ref remote)
            name)))
 
   (with-libgit2
-   (call-with-temporary-directory
-    (lambda (cache-directory)
-      (let* ((repository (repository-init cache-directory))
-             ;; Create an in-memory remote so we don't touch disk.
-             (remote (remote-create-anonymous repository url)))
-        (remote-connect remote)
-
-        (let* ((remote-heads (remote-ls remote))
-               (refs (filter-map remote-head->ref remote-heads)))
-          ;; Wait until we're finished with the repository before closing it.
-          (remote-disconnect remote)
-          (repository-close! repository)
-          refs))))))
+   (call-with-detached-remote
+    url
+    (lambda (remote)
+      (define remote-heads (remote-ls remote))
+      (filter-map remote-head->ref remote-heads)))))
+
+(define* (lookup-reference url reference-name)
+  "Lookup the reference named REFERENCE-NAME advertised at the Git repository
+at URL and return the commit string.  If the reference was not found, return
+#false instead."
+  (define (oid->commit oid)
+    (define str (oid->string oid))
+    ;; FIXME: why is the result of oid->string prefixed by 8 zeroes
+    ;; when remote-ls is used?  To make hash collisions harder, it would
+    ;; be nice if the commit was not abbreviated.
+    (if (string-prefix? "00000000" str)
+        (string-drop str 8)
+        str))
+  (define (match? remote-head)
+    (string=? reference-name (remote-head-name remote-head)))
+  (with-libgit2
+   (call-with-detached-remote
+    url
+    (lambda (remote)
+      (define remote-heads (remote-ls remote))
+      (define head (find match? remote-heads))
+      (and=> head (compose oid->commit remote-head-oid))))))
 
 
 ;;;
diff --git a/tests/git.scm b/tests/git.scm
index d0646bbc85..f8eaf9e93b 100644
--- a/tests/git.scm
+++ b/tests/git.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -189,4 +190,23 @@ (define-module (test-git)
         (tag "v1.1" "Release 1.1"))
     (remote-refs directory #:tags? #t)))
 
+(test-equal "lookup-reference: branch and HEAD"
+  '(#true #true)
+  (with-temporary-git-repository directory
+      '((add "a.txt" "A")
+        (commit "First commit")
+        (branch "a-branch")
+        (add "b.txt" "B")
+        (commit "Second commit"))
+    (with-repository directory repository
+      ;; See 'oid->commit' in (guix git) for why not string=?.
+      (list (string-prefix?
+             (lookup-reference directory "refs/heads/a-branch")
+             (oid->string
+              (commit-id (find-commit repository "First commit"))))
+            (string-prefix?
+             (lookup-reference directory "HEAD")
+             (oid->string
+              (commit-id (find-commit repository "Second commit"))))))))
+
 (test-end "git")
-- 
2.34.0