[bug#42338] [PATCH 8/9] guix: import: composer: Full rewrite composer-fetch.

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

Change-Id: I1c01c242cefe0bc4cfc9bd9a5717d10a61dd575e
---
 guix/import/composer.scm | 154 +++++++++++++++++++--------------------
 1 file changed, 77 insertions(+), 77 deletions(-)

diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index 89c8ea9113..2cc8861bdd 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -19,7 +19,7 @@
 (define-module (guix import composer)
   #:use-module (ice-9 match)
   #:use-module (json)
-  #:use-module (gcrypt hash)
+  #:use-module (guix hash)
   #:use-module (guix base32)
   #:use-module (guix build git)
   #:use-module (guix build utils)
@@ -44,27 +44,6 @@ (define-module (guix import composer)
 (define %composer-base-url
   (make-parameter "https://repo.packagist.org"))
 
-;; XXX adapted from (guix scripts hash)
-(define (file-hash file select? recursive?)
-  ;; Compute the hash of FILE.
-  (if recursive?
-      (let-values (((port get-hash) (open-sha256-port)))
-        (write-file file port #:select? select?)
-        (force-output port)
-        (get-hash))
-      (call-with-input-file file port-sha256)))
-
-;; XXX taken from (guix scripts hash)
-(define (vcs-file? file stat)
-  (case (stat:type stat)
-    ((directory)
-     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-    ((regular)
-     ;; Git sub-modules have a '.git' file that is a regular text file.
-     (string=? (basename file) ".git"))
-    (else
-     #f)))
-
 (define (fix-version version)
   "Return a fixed version from a version string.  For instance, v10.1 -> 10.1"
   (cond
@@ -114,22 +93,36 @@ (define-json-mapping <composer-package> make-composer-package composer-package?
                        (car l)
                        `(list ,@l))))))
 
-(define* (composer-fetch name #:optional version)
-  "Return an alist representation of the Composer metadata for the package NAME,
-or #f on failure."
-  (let ((package (json-fetch
-                   (string-append (%composer-base-url) "/p/" name ".json"))))
-    (if package
-        (let* ((packages (assoc-ref package "packages"))
-               (package (or (assoc-ref packages name) package))
-               (versions (filter
-                           (lambda (version)
-                             (and (not (string-contains version "dev"))
-                                  (not (string-contains version "beta"))))
-                           (map car package)))
-               (version (or (if (null? version) #f version)
-                            (latest-version versions))))
-          (assoc-ref package version))
+(define (valid-version? v)
+  (let ((d (string-downcase v)))
+    (and (not (string-contains d "dev"))
+         (not (string-contains d "beta"))
+         (not (string-contains d "rc")))))
+
+(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"))
+         (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
+              (reduce
+               (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)))
 
 (define (php-package-name name)
@@ -158,47 +151,55 @@ (define (make-php-sexp composer-package)
                              (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 ,(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 (negate vcs-file?) #t)))))
-                               `((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!))))))))
+            `(define-public ,(string->symbol
+                              (composer-package-name composer-package))
+               (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!)))))))))
 
 (define composer->guix-package
   (memoize
-   (lambda* (package-name #:key version #:allow-other-keys)
+   (lambda* (package-name #:key (version #f) #:allow-other-keys)
      "Fetch the metadata for PACKAGE-NAME from packagist.org, and return the
 `package' s-expression corresponding to that package, or #f on failure."
-     (let ((package (composer-fetch package-name version)))
+     (let ((package (composer-fetch package-name #:version version)))
        (and package
-            (let* ((package (json->composer-package package))
-                   (dependencies-names (composer-package-require 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))))))))
@@ -238,14 +239,13 @@ (define (string->license str)
 (define (php-package? package)
   "Return true if PACKAGE is a PHP package from Packagist."
   (and
-    (eq? (build-system-name (package-build-system package)) 'composer)
-    (string-prefix? "php-" (package-name package))))
+   (eq? (package-build-system package) composer-build-system)
+   (string-prefix? "php-" (package-name package))))
 
 (define (latest-release package)
   "Return an <upstream-source> for the latest release of PACKAGE."
   (let* ((php-name (guix-package->composer-name package))
-         (metadata (composer-fetch php-name))
-         (package (json->composer-package metadata))
+         (package (composer-fetch php-name))
          (version (composer-package-version package))
          (url (composer-source-url (composer-package-source package))))
     (upstream-source
-- 
2.41.0