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

From: Nicolas Graves <[email-masked]>
Date: Fri, 18 Oct 2024 00:25:59 +0200

* 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 <[email-masked]>
+;;; Copyright © 2023, 2024 Nicolas Graves <[email-masked]>
 ;;;
 ;;; 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