[bug#62202] [PATCH v4 1/6] import: utils: Add function git->origin.

[Nicolas Graves via Guix-patches via <guix-patches@gnu.org>]

* guix/import/utils.scm: (git->origin): Add function.

* guix/import/elpa.scm
(download-git-repository): Remove function download-git-repository.
(git-repository->origin): Remove function git-repository->origin.
(ref): Add function ref.
(melpa-recipe->origin): Use functions git->origin and ref.

* guix/import/go.scm
(git-checkout-hash): Remove function git-checkout-hash.
(transform-version): Add function transform-version.
(vcs->origin): Use functions git->origin and transform-version. Add
optional argument transform-version.

* tests/import/go.scm
(go-module->guix-package): Adapt test case to changes in guix/import/go.scm.

* guix/import/minetest.scm
(download-git-repository): Remove function download-git-repository.
(make-minetest-sexp): Use function git->origin.

* tests/minetest.scm
(make-package-sexp): Use function git->origin.
(example-package): Adapt test-case to git->origin.

* guix/import/composer.scm
(make-php-sexp): Use function git->origin.

Change-Id: Ied05a63bdd60fbafe26fbbb4e115ff6f0bb9db3c
---
 guix/import/composer.scm | 86 ++++++++++++++--------------------------
 guix/import/elpa.scm     | 43 ++++++--------------
 guix/import/go.scm       | 57 ++++++++------------------
 guix/import/minetest.scm | 28 ++-----------
 guix/import/utils.scm    | 39 ++++++++++++++++++
 tests/go.scm             | 29 ++++++++++----
 tests/minetest.scm       | 15 ++-----
 7 files changed, 127 insertions(+), 170 deletions(-)

diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index 1ad608964b..dabc5423ed 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -19,22 +19,17 @@
 (define-module (guix import composer)
   #:use-module (ice-9 match)
   #:use-module (json)
-  #:use-module (guix hash)
-  #:use-module (guix base32)
-  #:use-module (guix build git)
-  #:use-module (guix build utils)
-  #:use-module (guix build-system)
   #:use-module (guix build-system composer)
+  #:use-module ((guix download) #:select (download-to-store))
   #:use-module (guix import json)
   #:use-module (guix import utils)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix memoization)
   #:use-module (guix packages)
-  #:use-module (guix serialization)
+  #:use-module (guix store)
   #:use-module (guix upstream)
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:export (composer->guix-package
             %composer-updater
@@ -141,55 +136,34 @@ (define (make-php-sexp composer-package)
          (dependencies (map php-package-name
                             (composer-package-require composer-package)))
          (dev-dependencies (map php-package-name
-                                (composer-package-dev-require composer-package)))
-         (git? (equal? (composer-source-type source) "git")))
-    ((if git? call-with-temporary-directory call-with-temporary-output-file)
-     (lambda* (temp #:optional port)
-       (and (if git?
-               (begin
-                 (mkdir-p temp)
-                 (git-fetch (composer-source-url source)
-                            (composer-source-reference source)
-                            temp))
-               (url-fetch (composer-source-url source) temp))
-            `(package
-               (name ,(composer-package-name composer-package))
-               (version ,(composer-package-version composer-package))
-               (source
-                (origin
-                  ,@(if git?
-                        `((method git-fetch)
-                          (uri (git-reference
-                                (url ,(if (string-suffix?
-                                           ".git"
-                                           (composer-source-url source))
-                                          (string-drop-right
-                                           (composer-source-url source)
-                                           (string-length ".git"))
-                                          (composer-source-url source)))
-                                (commit ,(composer-source-reference source))))
-                          (file-name (git-file-name name version))
-                          (sha256
-                           (base32
-                            ,(bytevector->nix-base32-string
-                              (file-hash* temp)))))
-                        `((method url-fetch)
-                          (uri ,(composer-source-url source))
-                          (sha256 (base32 ,(guix-hash-url temp)))))))
-               (build-system composer-build-system)
-               ,@(if (null? dependencies)
-                     '()
-                     `((inputs
-                        (list ,@(map string->symbol dependencies)))))
-               ,@(if (null? dev-dependencies)
-                     '()
-                     `((native-inputs
-                        (list ,@(map string->symbol dev-dependencies)))))
-               (synopsis "")
-               (description ,(composer-package-description composer-package))
-               (home-page ,(composer-package-homepage composer-package))
-               (license ,(or (composer-package-license composer-package)
-                             'unknown-license!))))))))
+                                (composer-package-dev-require composer-package))))
+    `(package
+       (name ,(composer-package-name composer-package))
+       (version ,(composer-package-version composer-package))
+       (source
+        ,(if (string= (composer-source-type source) "git")
+             (git->origin (composer-source-url source)
+                          `(tag-or-commit . ,(composer-source-reference source)))
+             (let* ((source (composer-source-url source))
+                    (tarball (with-store store (download-to-store store source))))
+               `(origin
+                  (method url-fetch)
+                  (uri ,source)
+                  (sha256 (base32 ,(guix-hash-url tarball)))))))
+       (build-system composer-build-system)
+       ,@(if (null? dependencies)
+             '()
+             `((inputs
+                (list ,@(map string->symbol dependencies)))))
+       ,@(if (null? dev-dependencies)
+             '()
+             `((native-inputs
+                (list ,@(map string->symbol dev-dependencies)))))
+       (synopsis "")
+       (description ,(composer-package-description composer-package))
+       (home-page ,(composer-package-homepage composer-package))
+       (license ,(or (composer-package-license composer-package)
+                     'unknown-license!)))))
 
 (define composer->guix-package
   (memoize
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index d1855b3698..a755387242 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.
 ;;;
@@ -208,11 +209,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."
@@ -232,28 +228,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
@@ -264,9 +247,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 dd9298808d..6e2ce2ed00 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -514,49 +515,24 @@ (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)))))
+;; 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))))
 
-  ;; 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)))
-
-(define (vcs->origin vcs-type vcs-repo-url version)
+(define* (vcs->origin vcs-type vcs-repo-url version
+                      #:key (transform-version #f))
   "Generate the `origin' block of a package depending on what type of source
-control system is being used."
+control system is being used. Optionally use the function TRANSFORM-VERSION
+which takes version as an input."
   (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)
+                  #:ref->commit transform-version))
     ((hg)
      `(origin
         (method hg-fetch)
@@ -649,7 +625,8 @@ (define* (go-module->guix-package module-path #:key
         (name ,guix-name)
         (version ,(strip-v-prefix version*))
         (source
-         ,(vcs->origin vcs-type vcs-repo-url version*))
+         ,(vcs->origin vcs-type vcs-repo-url version*
+                       #:transform-version transform-version))
         (build-system go-build-system)
         (arguments
          (list ,@(if (version>? min-go-version (package-version (go-package)))
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index 5ea6e023ce..65ef242431 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.
 ;;;
@@ -32,7 +33,6 @@ (define-module (guix import minetest)
   #:use-module (guix import utils)
   #:use-module (guix import json)
   #:use-module (json)
-  #:use-module (guix base32)
   #:use-module (guix git)
   #:use-module ((guix git-download) #:prefix download:)
   #:use-module (guix hash)
@@ -277,12 +277,6 @@ (define url (string-append (%contentdb-api) "packages/?type=" type
 
 \f
 
-;; 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)
@@ -293,24 +287,8 @@ (define (make-minetest-sexp author/name version repository commit
      (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))))
+      ,(git->origin
+        repository `(tag-or-commit . ,commit) #:ref->commit #t))
      (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 0cf52cdbde..47254539a1 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.
 ;;;
@@ -39,6 +40,8 @@ (define-module (guix import utils)
   #:use-module (guix packages)
   #:use-module (guix discovery)
   #:use-module (guix build-system)
+  #: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
@@ -161,6 +165,41 @@ (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 #:key (ref->commit #f))
+  "Returns a generated `origin' block of a package depending on the git source
+control system, and the directory in the store where the package has been
+downloaded, in case further processing is necessary.  REPO-URL or REF can be
+null. REF->COMMIT can be a function or #t, in which case the commit matching
+ref is used. If REF->COMMIT is not used, the value inside REF is used."
+  (let* ((version (and (pair? ref) (cdr ref)))
+         (directory commit
+                    (if version
+                        (with-store store
+                          (latest-repository-commit store repo-url
+                                                    #:ref (if version ref '())))
+                        (values #f #f)))
+         (vcommit (match ref->commit
+                    (#t    commit)
+                    (#f    version)
+                    ((? procedure?) (ref->commit version))
+                    (_     #f))))
+    (values
+     `(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
+          ,(and version  ; Version or commit is not always available.
+                (bytevector->nix-base32-string
+                 (file-hash* directory
+                             ;; 'git-fetch' already filtered out '.git'.
+                             #:select? (const #true)
+                             #:recursive? #true))))))
+     directory)))
+
 (define %spdx-license-identifiers
   ;; https://spdx.org/licenses/
   ;; The gfl1.0, nmap, repoze
diff --git a/tests/go.scm b/tests/go.scm
index d2e8846b30..4644e1bd1c 100644
--- a/tests/go.scm
+++ b/tests/go.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,7 +25,6 @@ (define-module (tests-import-go)
   #:use-module (guix base32)
   #:use-module (guix build-system go)
   #:use-module (guix import go)
-  #:use-module (guix base32)
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (guix tests)
   #:use-module (ice-9 match)
@@ -403,13 +403,26 @@ (define (mock-http-get testcase)
             (mock-http-get fixtures-go-check-test))
          (mock ((guix http-client) http-fetch
                 (mock-http-fetch fixtures-go-check-test))
-             (mock ((guix git) update-cached-checkout
-                    (lambda* (url #:key ref)
-                      ;; Return an empty directory and its hash.
-                      (values checkout
-                              (nix-base32-string->bytevector
-                               "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")
-                              #f)))
+             (mock ((guix import utils) git->origin
+                    ;; Mock an empty directory by replacing hash.
+                    (lambda* (repo-url ref #:key (ref->commit #f))
+                      (let* ((version (if (pair? ref)
+                                          (cdr ref)
+                                          #f))
+                             (vcommit (match ref->commit
+                                        (#t    commit)
+                                        (#f    version)
+                                        ((? procedure?) (ref->commit version))
+                                        (_     #f))))
+                        `(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
+                             "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5"))))))
                  (go-module->guix-package* "github.com/go-check/check")))))))
 
 (test-end "go")
diff --git a/tests/minetest.scm b/tests/minetest.scm
index 78469bf95b..7ff72dbfdc 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)
@@ -419,8 +412,8 @@ (define* (example-package #:key
            (uri (git-reference
                  (url repo)
                  (commit commit #;"808f9ffbd3106da4c92d2367b118b98196c9e81e")))
-           (sha256 #f) ; not important for the following tests
-           (file-name (git-file-name name version)))
+           (file-name (git-file-name name version))
+           (sha256 #f)) ; not important for the following tests
          source))
     (build-system minetest-mod-build-system)
     (license #f)
-- 
2.41.0