[bug#73833] [PATCH] guix: import: composer: Improve composer-fetch.

[bug#73833] [PATCH] guix: import: composer: Improve composer-fetch.

[Nicolas Graves via Guix-patches via]

* guix/import/composer.scm (composer-fetch): Handle a case where
packages are #f. This improves composer-fetch behavior, which was
sometimes buggy.
---
 guix/import/composer.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index abc9023be4..febde97791 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -111,7 +111,7 @@ (define* (composer-fetch name #:key (version #f))
                             (let ((pkgs (assoc-ref pkg "packages")))
                               (or (assoc-ref pkgs name) pkg))))))
     (if packages
-        (json->composer-package
+        (and=>
          (if version
              (assoc-ref packages version)
              (cdr
@@ -125,7 +125,8 @@ (define* (composer-fetch name #:key (version #f))
                         cur-max))
                    (_ cur-max)))
                (cons* "0.0.0" #f)
-               packages))))
+               packages)))
+         json->composer-package)
         #f)))
 
 (define (php-package-name name)
-- 
2.46.0

[bug#73833] [PATCH v2 0/5] Large improvements to import utils, composer import, and refresh.

[Nicolas Graves via Guix-patches via]

This patch series merges a lot of different worthwhile contributions
to the import system in Guix. Patches 1 and 2 are extracted from the
work I did on the Juliahub importer to homogeneize and factor out a
git->origin function. Patch 3 has a lot of various but transparent and
explained improvements to the composer import, which should be renamed
to "packagist" instead of "composer" by the way. Patch 4 is a fix to a
shortcoming in refresh. Patch 5 shows a way to use upstream-inputs to
update packages using requirement constraints from packagist.

Nicolas Graves (5):
  guix: import: utils: Add function git->origin.
  tests: go: Add mock-git->origin function.
  guix: import: composer: Improve importer.
  guix: refresh: Keep the version field of each update specification.
  guix: refresh: Implement basic upstream-source-inputs rich updates.

 guix/import/composer.scm | 236 ++++++++++++++++++++++-----------------
 guix/import/elpa.scm     |  44 +++-----
 guix/import/go.scm       |  57 +++-------
 guix/import/minetest.scm |  28 +----
 guix/import/utils.scm    |  39 +++++++
 guix/scripts/refresh.scm |  59 ++++++++--
 tests/composer.scm       |   2 +-
 tests/go.scm             |  30 +++--
 tests/minetest.scm       |  15 +--
 9 files changed, 280 insertions(+), 230 deletions(-)

-- 
2.46.0

[bug#73833] [PATCH v2 1/5] guix: import: utils: Add function git->origin.

[Nicolas Graves via Guix-patches via]

* 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 | 85 ++++++++++++++--------------------------
 guix/import/elpa.scm     | 44 ++++++---------------
 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 abc9023be4..a6a482021f 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -19,12 +19,9 @@
 (define-module (guix import composer)
   #:use-module (ice-9 match)
   #:use-module (json)
-  #: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 diagnostics) #:select (warning))
+  #:use-module ((guix download) #:select (download-to-store))
   #:use-module (guix hash)
   #:use-module (guix i18n)
   #:use-module (guix import json)
@@ -32,11 +29,10 @@ (define-module (guix import composer)
   #: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
@@ -143,55 +139,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 46b6dc98a2..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,29 +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)))
-       (file-name (git-file-name name version))
-       (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
@@ -265,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 b7756fcc40..8512e0d64c 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 f925c485c1..8402f3e978 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 bf1313ee22..94e93c64bf 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.46.0

[bug#73833] [PATCH v2 2/5] tests: go: Add mock-git->origin function.

[Nicolas Graves via Guix-patches via]

* tests/go.scm
(mock-git->origin): Add function.
(go-module->guix-package test): Use mock-git->origin.
---
 tests/go.scm | 41 +++++++++++++++++++++--------------------
 1 file changed, 21 insertions(+), 20 deletions(-)

diff --git a/tests/go.scm b/tests/go.scm
index 8402f3e978..c08a73a850 100644
--- a/tests/go.scm
+++ b/tests/go.scm
@@ -371,6 +371,26 @@ (define (mock-http-get testcase)
           (values response-header body)
           (error "mocked http-get Unexpected URL: " url)))))
 
+;; Mock an empty directory by replacing hash.
+(define* (mock-git->origin 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")))))
+
 (test-equal "go-module->guix-package"
   '(package
      (name "go-github-com-go-check-check")
@@ -403,26 +423,7 @@ (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 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"))))))
+             (mock ((guix import utils) git->origin mock-git->origin)
                  (go-module->guix-package* "github.com/go-check/check")))))))
 
 (test-end "go")
-- 
2.46.0

[bug#73833] [PATCH v2 3/5] guix: import: composer: Improve importer.

[Nicolas Graves via Guix-patches via]

* guix/import/composer.scm
(%composer-base-url): Move from here...
(%packagist-base-url): ...to here.
(requirements->prefixes): Add variable to read and take advantage of
version info in composer package requirements and...
(json->require): ...use it here. Rewrite of the function.
(composer-source): Add a sanitizer for composer-source-url.
(select-version): Add variable to select the most recent availble
version that is above to a given min-version and...
(composer-fetch): ...use it here. Improve the function.
(make-php-sexp, composer->guix-package): Adapt to requirements being
alists now.
(php-package?): Handle the particular phpunit case.
(dependency->input): Add min-version and max-version information. This
is currently limited to the first dependency suggested by
requirements.
(import-release): Fix git urls case. This is better but still a bit
buggy (refreshing can replace the version by a commit).

* tests/composer.scm
(%composer-base-url): Move from here...
(%packagist-base-url): ...to here.
---
 guix/import/composer.scm | 151 +++++++++++++++++++++++++++------------
 tests/composer.scm       |   2 +-
 2 files changed, 105 insertions(+), 48 deletions(-)

diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index a6a482021f..d6af50da8c 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2023, 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +22,8 @@ (define-module (guix import composer)
   #:use-module (json)
   #:use-module (guix build-system composer)
   #:use-module ((guix diagnostics) #:select (warning))
+  #:use-module ((guix import git) #:select (latest-git-tag-version))
+  #:use-module ((guix git-download) #:select (git-reference))
   #:use-module ((guix download) #:select (download-to-store))
   #:use-module (guix hash)
   #:use-module (guix i18n)
@@ -34,13 +37,14 @@ (define-module (guix import composer)
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
   #:export (composer->guix-package
             %composer-updater
             composer-recursive-import
 
-            %composer-base-url))
+            %packagist-base-url))
 
-(define %composer-base-url
+(define %packagist-base-url
   (make-parameter "https://repo.packagist.org"))
 
 (define (fix-version version)
@@ -54,26 +58,40 @@ (define (fix-version version)
      (substring version 1))
     (else version)))
 
-(define (latest-version versions)
-  (fold (lambda (a b) (if (version>? (fix-version a) (fix-version b)) a b))
-        (car versions) versions))
+(define (requirements->prefixes str)
+  (let* ((processed-str (string-replace-substring str " || " "|"))
+         (prefix-strs (string-split processed-str #\|)))
+    (filter-map (match-lambda
+                  ;; SemVer: ^ indicates major+minor match, not a whole match.
+                  ((? (cut string-prefix? "^" <>) prefix)
+                   (let ((pfx (string-drop prefix 1)))
+                     (if (eq? 2 (string-count prefix #\.))
+                         (string-take pfx (string-rindex pfx #\.))
+                         pfx)))
+                  ((? (cut string-suffix? ".*" <>) prefix)
+                   (string-drop-right prefix 2))
+                  (_ #f))
+         prefix-strs)))
 
 (define (json->require dict)
-  (if dict
-      (let loop ((result '()) (require dict))
-        (match require
-          (() result)
-          ((((? (cut string-contains <> "/") name) . _)
-             require ...)
-           (loop (cons name result) require))
-          ((_ require ...) (loop result require))
-          (_ result)))
+  (if (and dict (not (unspecified? dict)))
+      (filter-map
+       (match-lambda
+         (((? (cut string-contains <> "/") name) . requirements)
+          (list name (requirements->prefixes requirements)))
+         (_
+          #f))
+       dict)
       '()))
 
 (define-json-mapping <composer-source> make-composer-source composer-source?
   json->composer-source
   (type      composer-source-type)
-  (url       composer-source-url)
+  (url       composer-source-url "url"
+             (lambda (uri)
+               (if (string-suffix? ".git" uri)
+                   (string-drop-right uri 4)
+                   uri)))
   (reference composer-source-reference))
 
 (define-json-mapping <composer-package> make-composer-package composer-package?
@@ -98,31 +116,44 @@ (define (valid-version? v)
          (not (string-contains d "beta"))
          (not (string-contains d "rc")))))
 
+(define* (select-version packages #:key (min-version #f))
+  "Select the most recent available version in the PACKAGES list
+that is above or equal to MIN-VERSION. MIN-VERSION can be incomplete
+(e.g. version-major only)."
+  (let* ((points (and min-version (string-count min-version #\.)))
+         (min-prefix (and min-version
+                          (match points
+                            ((or 0 1) (fix-version min-version))
+                            (_ #f)))))
+    (cdr
+     (fold
+      (lambda (new cur-max)
+        (match new
+          (((? valid-version? version) . tail)
+           (let ((valid-version (fix-version version)))
+             (if (and (version>? valid-version (fix-version (car cur-max)))
+                      (or (not min-prefix)
+                          (version-prefix? min-prefix valid-version)))
+                 (cons* version tail)
+                 cur-max)))
+          (_ cur-max)))
+      (cons* "0.0.0" #f)
+      packages))))
+
 (define* (composer-fetch name #:key (version #f))
   "Return a composer-package representation of the Composer metadata for the
 package NAME with optional VERSION, or #f on failure."
-  (let* ((url (string-append (%composer-base-url) "/p/" name ".json"))
+  (let* ((url (string-append (%packagist-base-url) "/p/" name ".json"))
          (packages (and=> (json-fetch url)
                           (lambda (pkg)
                             (let ((pkgs (assoc-ref pkg "packages")))
                               (or (assoc-ref pkgs name) pkg))))))
-    (if packages
-        (json->composer-package
-         (if version
-             (assoc-ref packages version)
-             (cdr
-              (fold
-               (lambda (new cur-max)
-                 (match new
-                   (((? valid-version? version) . tail)
-                    (if (version>? (fix-version version)
-                                   (fix-version (car cur-max)))
-                        (cons* version tail)
-                        cur-max))
-                   (_ cur-max)))
-               (cons* "0.0.0" #f)
-               packages))))
-        #f)))
+    (and packages
+        (let ((v (assoc-ref packages version)))
+          (and=>
+           (or (and v (not (unspecified? v)) v)
+               (select-version packages #:min-version version))
+         json->composer-package)))))
 
 (define (php-package-name name)
   "Given the NAME of a package on Packagist, return a Guix-compliant name for
@@ -136,9 +167,9 @@ (define (make-php-sexp composer-package)
   "Return the `package' s-expression for a PHP package for the given
 COMPOSER-PACKAGE."
   (let* ((source (composer-package-source composer-package))
-         (dependencies (map php-package-name
+         (dependencies (map (compose php-package-name car)
                             (composer-package-require composer-package)))
-         (dev-dependencies (map php-package-name
+         (dev-dependencies (map (compose php-package-name car)
                                 (composer-package-dev-require composer-package))))
     `(package
        (name ,(composer-package-name composer-package))
@@ -176,10 +207,14 @@ (define composer->guix-package
 dependencies, or #f and the empty list on failure."
      (let ((package (composer-fetch package-name #:version version)))
        (if package
-           (let* ((dependencies-names (composer-package-require package))
-                  (dev-dependencies-names (composer-package-dev-require package)))
-             (values (make-php-sexp package)
-                     (append dependencies-names dev-dependencies-names)))
+           (values (make-php-sexp package)
+                   (append-map
+                    (match-lambda
+                      ((head . tail)
+                       (cons head (car tail)))
+                      (_ #f))
+                    (list (composer-package-require package)
+                          (composer-package-dev-require package))))
            (values #f '()))))))
 
 (define (guix-name->composer-name name)
@@ -213,24 +248,46 @@ (define (php-package? package)
   "Return true if PACKAGE is a PHP package from Packagist."
   (and
    (eq? (package-build-system package) composer-build-system)
-   (string-prefix? "php-" (package-name package))))
+   (or (string-prefix? "php-" (package-name package))
+       (string=? "phpunit" (package-name package)))))
 
 (define (dependency->input dependency type)
-  (upstream-input
-   (name dependency)
-   (downstream-name (php-package-name dependency))
-   (type type)))
+  (let* ((version (fix-version (caadr dependency)))
+         (points (and version (string-count version #\.)))
+         (max "99"))
+    (upstream-input
+     (name (car dependency))
+     (downstream-name (php-package-name (car dependency)))
+     (type type)
+     (min-version (match points
+                    (0 (string-append version ".0.0"))
+                    (1 (string-append version ".0"))
+                    (2 version)
+                    (_ 'any)))
+     (max-version (match points
+                    (0 (string-append version "." max "." max))
+                    (1 (string-append version "." max))
+                    (2 version)
+                    (_ 'any))))))
 
 (define* (import-release package #:key (version #f))
   "Return an <upstream-source> for VERSION or the latest release of PACKAGE."
   (let* ((php-name (guix-package->composer-name package))
-         (composer-package (composer-fetch php-name #:version version)))
+         (composer-package (composer-fetch php-name #:version version))
+         (new-version new-version-tag
+                      (latest-git-tag-version package #:version version)))
     (if composer-package
         (upstream-source
          (package (composer-package-name composer-package))
          (version (composer-package-version composer-package))
-         (urls (list (composer-source-url
-                      (composer-package-source composer-package))))
+         (urls
+          (let ((source (composer-package-source composer-package)))
+            (if (string=? (composer-source-type source) "git")
+                (git-reference
+                 (url (composer-source-url source))
+                 (commit (or new-version-tag
+                             (composer-source-reference source))))
+                (list (composer-source-url source)))))
          (inputs (append
                   (map (cut dependency->input <> 'regular)
                        (composer-package-require composer-package))
diff --git a/tests/composer.scm b/tests/composer.scm
index 9114fef19e..355ebab67c 100644
--- a/tests/composer.scm
+++ b/tests/composer.scm
@@ -61,7 +61,7 @@ (define test-source
   ;; Replace network resources with sample data.
   (with-http-server `((200 ,test-json)
                       (200 ,test-source))
-    (parameterize ((%composer-base-url (%local-url))
+    (parameterize ((%packagist-base-url (%local-url))
                    (current-http-proxy (%local-url)))
       (match (composer->guix-package "foo/bar")
         (`(package
-- 
2.46.0

[bug#73833] [PATCH v2 4/5] guix: refresh: Keep the version field of each update specification.

[Nicolas Graves via Guix-patches via]

* guix/scripts/refresh.scm (options->update-specs)[update-specs]: Keep
the version field of each update specification.  This is done using a
variable to cache package names and then filter out unwanted candidates.
---
 guix/scripts/refresh.scm | 23 +++++++++++++++++------
 1 file changed, 17 insertions(+), 6 deletions(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index ec7d38c22a..810c33c786 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -310,12 +310,23 @@ (define update-specs
        some)))
 
   (if (assoc-ref opts 'recursive?)
-      (mlet* %store-monad ((edges (node-edges %bag-node-type (all-packages)))
-                           (packages -> (node-transitive-edges
-                                         (map update-spec-package update-specs)
-                                         edges)))
-        ;; FIXME: The 'version' field of each update spec is lost.
-        (return (map update-spec packages)))
+      (mlet* %store-monad
+          ((edges (node-edges %bag-node-type (all-packages)))
+           (strict-spec-pkgs -> (map update-spec-package update-specs))
+           (strict-spec-pkg-names -> (map package-name strict-spec-pkgs))
+           (packages -> (node-transitive-edges strict-spec-pkgs edges))
+           (transitive-specs -> (map update-spec packages)))
+        (return (append update-specs
+                        (filter-map (match-lambda
+                                      ((? update? spec)
+                                       (if (member (package-name
+                                                    (update-spec-package spec))
+                                                   strict-spec-pkg-names)
+                                           spec
+                                           #f))
+                                      (_
+                                       #f))
+                                    transitive-specs))))
       (with-monad %store-monad
         (return update-specs))))
 
-- 
2.46.0

[bug#73833] [PATCH v2 5/5] guix: refresh: Implement basic upstream-source-inputs rich updates.

[Nicolas Graves via Guix-patches via]

* guix/scripts/refresh.scm (options->user-updaters): Add variable.
(options->update-specs)[input->update-spec]: Restrained default where
the min-version and max-version have the same major+minor version.
[update-specs]: Adapt user-specified packages to be aware of
upstream-source-inputs version in this restrained default.

This should allow to update dependent packages to the right version
as opposed to the latest version. Tested in some capacity, but very
alpha.

This also implies that the upstream-updater-import is able to provide
versions on top of packages, that the updater is able to read
incomplete semver versions (such as 3.2 instead of 3.2.1), and that
the upstream-inputs have their min-version and max-version set.
---
 guix/scripts/refresh.scm | 36 ++++++++++++++++++++++++++++++------
 1 file changed, 30 insertions(+), 6 deletions(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 810c33c786..70685ddbc1 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -229,6 +229,14 @@ (define (update-specification->update-spec spec fallback-version)
     (idx (update-spec (specification->package (substring spec 0 idx))
                       (substring spec (1+ idx))))))
 
+(define (options->user-updaters opts)
+  ;; Return the list of user-specified updaters.
+  (filter-map (match-lambda
+                (('updaters . names)
+                 (map lookup-updater-by-name names))
+                (_ #f))
+              opts))
+
 (define (options->update-specs opts)
   "Return the list of <update-spec> records requested by OPTS, honoring
 options like '--recursive'."
@@ -269,6 +277,14 @@ (define (keep-newest package lst)
         (_
          (cons package lst)))))
 
+  (define (input->update-spec input)
+    (%update-spec
+     (specification->package (upstream-input-downstream-name input))
+     (if (string=? (version-major+minor (upstream-input-max-version input))
+                   (version-major+minor (upstream-input-min-version input)))
+         (version-major+minor (upstream-input-max-version input))
+         #f)))
+
   (define update-specs
     ;; Update specs explicitly passed as command-line arguments.
     (match (append-map (match-lambda
@@ -307,7 +323,19 @@ (define update-specs
                              '()
                              modules))))
       (some                                       ;user-specified packages
-       some)))
+       ;; When the user specifies updaters, and these updaters support
+       ;; min/max versions, updates specs so that they account for this
+       ;; updater.
+       (let ((user-updaters (options->user-updaters opts)))
+         (if (and user-updaters (not (unspecified? user-updaters))
+                  (not (null? user-updaters)))
+             (let* ((import (upstream-updater-import (caar user-updaters)))
+                    (package (update-spec-package (car some)))
+                    (version (update-spec-version (car some)))
+                    (source (import package #:version version))
+                    (upstream-inputs (upstream-source-inputs source)))
+               (append some (map input->update-spec upstream-inputs)))
+             some)))))
 
   (if (assoc-ref opts 'recursive?)
       (mlet* %store-monad
@@ -571,11 +599,7 @@ (define (parse-options)
 
   (define (options->updaters opts)
     ;; Return the list of updaters to use.
-    (match (filter-map (match-lambda
-                         (('updaters . names)
-                          (map lookup-updater-by-name names))
-                         (_ #f))
-                       opts)
+    (match (options->user-updaters opts)
       (()
        ;; Use the default updaters.
        (force %updaters))
-- 
2.46.0