[bug#61930] [PATCH] import: factorising git->origin in guix/import/utils.scm.

[Nicolas Graves]

---
 guix/import/elpa.scm     | 44 +++++++++++--------------------------
 guix/import/go.scm       | 47 +++++++++-------------------------------
 guix/import/minetest.scm | 28 ++----------------------
 guix/import/utils.scm    | 36 ++++++++++++++++++++++++++++++
 tests/minetest.scm       | 11 ++--------
 5 files changed, 63 insertions(+), 103 deletions(-)

diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index f9e9f2de53..cfd149a697 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -45,7 +46,6 @@ (define-module (guix import elpa)
   #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix store)
   #:use-module (guix ui)
-  #:use-module (guix base32)
   #:use-module (guix upstream)
   #:use-module (guix packages)
   #:use-module (guix memoization)
@@ -210,11 +210,6 @@ (define* (fetch-elpa-package name #:optional (repo 'gnu))
                             url)))
       (_ #f))))
 
-(define* (download-git-repository url ref)
-  "Fetch the given REF from the Git repository at URL."
-  (with-store store
-    (latest-repository-commit store url #:ref ref)))
-
 (define (package-name->melpa-recipe package-name)
   "Fetch the MELPA recipe for PACKAGE-NAME, represented as an alist from
 keywords to values."
@@ -234,28 +229,15 @@ (define (data->recipe data)
     (close-port port)
     (data->recipe (cons ':name data))))
 
-(define (git-repository->origin recipe url)
-  "Fetch origin details from the Git repository at URL for the provided MELPA
-RECIPE."
-  (define ref
-    (cond
-     ((assoc-ref recipe #:branch)
-      => (lambda (branch) (cons 'branch branch)))
-     ((assoc-ref recipe #:commit)
-      => (lambda (commit) (cons 'commit commit)))
-     (else
-      '())))
-
-  (let-values (((directory commit) (download-git-repository url ref)))
-    `(origin
-       (method git-fetch)
-       (uri (git-reference
-             (url ,url)
-             (commit ,commit)))
-       (sha256
-        (base32
-         ,(bytevector->nix-base32-string
-           (file-hash* directory #:recursive? #true)))))))
+(define (ref recipe)
+  "Create REF from MELPA RECIPE."
+  (cond
+   ((assoc-ref recipe #:branch)
+    => (lambda (branch) (cons 'branch branch)))
+   ((assoc-ref recipe #:commit)
+    => (lambda (commit) (cons 'commit commit)))
+   (else
+    '())))
 
 (define* (melpa-recipe->origin recipe)
   "Fetch origin details from the MELPA recipe and associated repository for
@@ -266,9 +248,9 @@ (define (gitlab-repo->url repo)
     (string-append "https://gitlab.com/"; repo ".git"))
 
   (match (assq-ref recipe ':fetcher)
-    ('github (git-repository->origin recipe (github-repo->url (assq-ref recipe 
':repo))))
-    ('gitlab (git-repository->origin recipe (gitlab-repo->url (assq-ref recipe 
':repo))))
-    ('git    (git-repository->origin recipe (assq-ref recipe ':url)))
+    ('github (git->origin (github-repo->url (assq-ref recipe ':repo)) (ref 
recipe)))
+    ('gitlab (git->origin (gitlab-repo->url (assq-ref recipe ':repo)) (ref 
recipe)))
+    ('git    (git->origin (assq-ref recipe ':url) (ref recipe)))
     (#f #f)   ; if we're not using melpa then this stops us printing a warning
     (_ (warning (G_ "Unsupported MELPA fetcher: ~a, falling back to unstable 
MELPA source.~%")
                 (assq-ref recipe ':fetcher))
diff --git a/guix/import/go.scm b/guix/import/go.scm
index 90d4c8931d..c8ee16fd39 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -501,49 +502,21 @@ (define (module-meta-data-repo-url meta-data goproxy)
       goproxy
       (module-meta-repo-root meta-data)))
 
-(define* (git-checkout-hash url reference algorithm)
-  "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or
-tag."
-  (define cache
-    (string-append (or (getenv "TMPDIR") "/tmp")
-                   "/guix-import-go-"
-                   (passwd:name (getpwuid (getuid)))))
-
-  ;; Use a custom cache to avoid cluttering the default one under
-  ;; ~/.cache/guix, but choose one under /tmp so that it's persistent across
-  ;; subsequent "guix import" invocations.
-  (mkdir-p cache)
-  (chmod cache #o700)
-  (let-values (((checkout commit _)
-                (parameterize ((%repository-cache-directory cache))
-                  (update-cached-checkout url
-                                          #:ref
-                                          `(tag-or-commit . ,reference)))))
-    (file-hash* checkout #:algorithm algorithm #:recursive? #true)))
+;; This is done because the version field of the package, which the generated
+;; quoted expression refers to, has been stripped of any 'v' prefixed.
+(define (transform-version version)
+  (let ((plain-version? (string=? version (go-version->git-ref version)))
+        (v-prefixed?    (string-prefix? "v" version)))
+    ,(if (and plain-version? v-prefixed?)
+         '(string-append "v" version)
+         '(go-version->git-ref version))))
 
 (define (vcs->origin vcs-type vcs-repo-url version)
   "Generate the `origin' block of a package depending on what type of source
 control system is being used."
   (case vcs-type
     ((git)
-     (let ((plain-version? (string=? version (go-version->git-ref version)))
-           (v-prefixed?    (string-prefix? "v" version)))
-       `(origin
-          (method git-fetch)
-          (uri (git-reference
-                (url ,vcs-repo-url)
-                ;; This is done because the version field of the package,
-                ;; which the generated quoted expression refers to, has been
-                ;; stripped of any 'v' prefixed.
-                (commit ,(if (and plain-version? v-prefixed?)
-                             '(string-append "v" version)
-                             '(go-version->git-ref version)))))
-          (file-name (git-file-name name version))
-          (sha256
-           (base32
-            ,(bytevector->nix-base32-string
-              (git-checkout-hash vcs-repo-url (go-version->git-ref version)
-                                 (hash-algorithm sha256))))))))
+     (git->origin vcs-repo-url `(tag-or-commit . ,version) transform-version))
     ((hg)
      `(origin
         (method hg-fetch)
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index e5775e2fa9..f080539bda 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,7 +39,6 @@ (define-module (guix import minetest)
   #:use-module (guix import json)
   #:use-module ((gcrypt hash) #:select (open-sha256-port port-sha256))
   #:use-module (json)
-  #:use-module (guix base32)
   #:use-module (guix git)
   #:use-module ((guix git-download) #:prefix download:)
   #:use-module (guix hash)
@@ -283,12 +283,6 @@ (define url (string-append (%contentdb-api) 
"packages/?type=" type
 
 
 
-;; XXX copied from (guix import elpa)
-(define* (download-git-repository url ref)
-  "Fetch the given REF from the Git repository at URL."
-  (with-store store
-    (latest-repository-commit store url #:ref ref)))
-
 (define (make-minetest-sexp author/name version repository commit
                             inputs home-page synopsis
                             description media-license license)
@@ -298,25 +292,7 @@ (define (make-minetest-sexp author/name version repository 
commit
   `(package
      (name ,(contentdb->package-name author/name))
      (version ,version)
-     (source
-       (origin
-         (method git-fetch)
-         (uri (git-reference
-                (url ,repository)
-                (commit ,commit)))
-         (sha256
-          (base32
-           ;; The git commit is not always available.
-           ,(and commit
-                 (bytevector->nix-base32-string
-                  (file-hash*
-                   (download-git-repository repository
-                                            `(commit . ,commit))
-                   ;; 'download-git-repository' already filtered out the '.git'
-                   ;; directory.
-                   #:select? (const #true)
-                   #:recursive? #true)))))
-         (file-name (git-file-name name version))))
+     (source ,(git->origin repository `(tag-or-commit . ,commit)))
      (build-system minetest-mod-build-system)
      ,@(maybe-propagated-inputs (map contentdb->package-name inputs))
      (home-page ,home-page)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 72795d2c61..3b31338e00 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -13,6 +13,7 @@
 ;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr>
 ;;; Copyright © 2022 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,6 +41,8 @@ (define-module (guix import utils)
   #:use-module (guix discovery)
   #:use-module (guix build-system)
   #:use-module (guix gexp)
+  #:use-module (guix git)
+  #:use-module (guix hash)
   #:use-module ((guix i18n) #:select (G_))
   #:use-module (guix store)
   #:use-module (guix download)
@@ -63,6 +66,7 @@ (define-module (guix import utils)
 
             url-fetch
             guix-hash-url
+            git->origin
 
             package-names->package-inputs
             maybe-inputs
@@ -153,6 +157,38 @@ (define (guix-hash-url filename)
   "Return the hash of FILENAME in nix-base32 format."
   (bytevector->nix-base32-string (file-sha256 filename)))
 
+(define* (git->origin repo-url ref #:optional ref->commit)
+  "Generate the `origin' block of a package depending on the git source
+control system. REPO-URL or REF can be null."
+  (let-values (((directory commit)
+                (with-store store
+                  (latest-repository-commit store repo-url #:ref ref))))
+    (let* ((version (if (pair? ref)
+                        (cdr ref)
+                        #f))
+           (vcommit (match ref->commit
+                      (#t
+                       commit)
+                      (null?
+                       version)
+                      (_
+                       (ref->commit version)))))
+      `(origin
+         (method git-fetch)
+         (uri (git-reference
+               (url ,(and (not (eq? repo-url 'null)) repo-url))
+               (commit ,vcommit)))
+         (file-name (git-file-name name version))
+         (sha256
+          (base32
+           ,(if (pair? ref)
+                (bytevector->nix-base32-string
+                 (file-hash* directory
+                             ;; 'git-fetch' already filtered out the '.git' 
directory.
+                             #:select? (const #true)
+                             #:recursive? #true))
+                #f)))))))
+
 (define %spdx-license-identifiers
   ;; https://spdx.org/licenses/
   ;; The gfl1.0, nmap, repoze
diff --git a/tests/minetest.scm b/tests/minetest.scm
index cbb9e83889..c03f731845 100644
--- a/tests/minetest.scm
+++ b/tests/minetest.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,15 +58,7 @@ (define* (make-package-sexp #:key
   `(package
      (name ,guix-name)
      (version ,version)
-     (source
-      (origin
-        (method git-fetch)
-        (uri (git-reference
-              (url ,(and (not (eq? repo 'null)) repo))
-              (commit #f)))
-        (sha256
-         (base32 #f))
-        (file-name (git-file-name name version))))
+     (source (git->origin repo #f))
      (build-system minetest-mod-build-system)
      ,@(maybe-propagated-inputs inputs)
      (home-page ,home-page)
-- 
2.39.1