05/06: import: cpan: Rewrite to use 'define-json-mapping'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 69f132554c6bd23df4610a21e636bde5f0578174
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Jan 15 18:05:26 2020 +0100

    import: cpan: Rewrite to use 'define-json-mapping'.
    
    * guix/import/cpan.scm (<cpan-dependency>, <cpan-release>): New
    JSON-mapped record types.
    (metacpan-url->mirror-url): New procedure.
    (cpan-source-url): Rewrite in terms of it.
    (cpan-version): Remove.
    (cpan-module->sexp): Rewrite to take a <cpan-release> instead of an
    alist, and rename 'meta' to 'release'.
    [convert-inputs]: Rewrite to use 'cpan-release-dependencies'.
    Update calls to 'convert-inputs' to pass a list of symbols.
    Replace 'assoc-ref' calls with the appropriate field accessors.
    (cpan->guix-package): Rename 'module-meta' to 'release'.
    (latest-release): Likewise, and use the appropriate accessors.
    * tests/cpan.scm (test-json): Remove "prereqs" record; add "dependency"
    list.
    ("source-url-http", "source-url-https"): Remove.
    ("metacpan-url->mirror-url, http")
    ("metacpan-url->mirror-url, https"): New tests.
---
 guix/import/cpan.scm | 151 ++++++++++++++++++++++++++++++++++-----------------
 tests/cpan.scm       |  33 ++++++-----
 2 files changed, 116 insertions(+), 68 deletions(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index ec86f11..4320f94 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2015 Mark H Weaver <address@hidden>
 ;;; Copyright © 2016 Alex Sassmannshausen <address@hidden>
 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <address@hidden>
+;;; Copyright © 2020 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,19 +28,39 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (json)
+  #:use-module (guix json)
   #:use-module (gcrypt hash)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix base32)
   #:use-module (guix ui)
   #:use-module ((guix download) #:select (download-to-store url-fetch))
-  #:use-module ((guix import utils) #:select (factorize-uri
-                                              flatten assoc-ref*))
+  #:use-module ((guix import utils) #:select (factorize-uri))
   #:use-module (guix import json)
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module (guix derivations)
-  #:export (cpan->guix-package
+  #:export (cpan-dependency?
+            cpan-dependency-relationship
+            cpan-dependency-phase
+            cpan-dependency-module
+            cpan-dependency-version
+
+            cpan-release?
+            cpan-release-license
+            cpan-release-author
+            cpan-release-version
+            cpan-release-modle
+            cpan-release-distribution
+            cpan-release-download-url
+            cpan-release-abstract
+            cpan-release-home-page
+            cpan-release-dependencies
+            json->cpan-release
+
+            cpan-fetch
+            cpan->guix-package
+            metacpan-url->mirror-url
             %cpan-updater))
 
 ;;; Commentary:
@@ -49,6 +70,45 @@
 ;;;
 ;;; Code:
 
+;; Dependency of a "release".
+(define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency?
+  json->cpan-dependency
+  (relationship cpan-dependency-relationship "relationship"
+                string->symbol)                   ;requires | suggests
+  (phase        cpan-dependency-phase "phase"
+                string->symbol)          ;develop | configure | test | runtime
+  (module       cpan-dependency-module)           ;string
+  (version      cpan-dependency-version))         ;string
+
+;; Release as returned by <https://fastapi.metacpan.org/v1/release/PKG>.
+(define-json-mapping <cpan-release> make-cpan-release cpan-release?
+  json->cpan-release
+  (license      cpan-release-license)
+  (author       cpan-release-author)
+  (version      cpan-release-version "version"
+                (match-lambda
+                  ((? number? version)
+                   ;; Version is sometimes not quoted in the module json, so
+                   ;; it gets imported into Guile as a number, so convert it
+                   ;; to a string (example: "X11-Protocol-Other").
+                   (number->string version))
+                  ((? string? version)
+                   ;; Sometimes we get a "v" prefix.  Strip it.
+                   (if (string-prefix? "v" version)
+                       (string-drop version 1)
+                       version))))
+  (module       cpan-release-module "main_module") ;e.g., "Test::Script"
+  (distribution cpan-release-distribution)         ;e.g., "Test-Script"
+  (download-url cpan-release-download-url "download_url")
+  (abstract     cpan-release-abstract "abstract")
+  (home-page    cpan-release-home-page "resources"
+                (match-lambda
+                  (#f #f)
+                  ((lst ...) (assoc-ref lst "homepage"))))
+  (dependencies cpan-release-dependencies "dependency"
+                (lambda (vector)
+                  (map json->cpan-dependency (vector->list vector)))))
+
 (define string->license
   (match-lambda
    ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
@@ -111,32 +171,25 @@ return \"Test-Simple\""
           (_ #f)))))
 
 (define (cpan-fetch name)
-  "Return an alist representation of the CPAN metadata for the perl module 
MODULE,
-or #f on failure.  MODULE should be e.g. \"Test::Script\""
+  "Return a <cpan-release> record for Perl module MODULE,
+or #f on failure.  MODULE should be the distribution name, such as
+\"Test-Script\" for the \"Test::Script\" module."
   ;; This API always returns the latest release of the module.
-  (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/"; name)))
+  (json->cpan-release
+   (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/";
+                              name))))
 
 (define (cpan-home name)
   (string-append "https://metacpan.org/release/"; name))
 
-(define (cpan-source-url meta)
-  "Return the download URL for a module's source tarball."
+(define (metacpan-url->mirror-url url)
+  "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'."
   (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
-                            (assoc-ref meta "download_url")
+                            url
                             'pre "mirror://cpan" 'post))
 
-(define (cpan-version meta)
-  "Return the version number from META."
-  (match (assoc-ref meta "version")
-    ((? number? version)
-     ;; version is sometimes not quoted in the module json, so it gets
-     ;; imported into Guile as a number, so convert it to a string.
-     (number->string version))
-    (version
-     ;; Sometimes we get a "v" prefix.  Strip it.
-     (if (string-prefix? "v" version)
-         (string-drop version 1)
-         version))))
+(define cpan-source-url
+  (compose metacpan-url->mirror-url cpan-release-download-url))
 
 (define (perl-package)
   "Return the 'perl' package.  This is a lazy reference so that we don't
@@ -179,42 +232,38 @@ depend on (gnu packages perl)."
                                        first perl-version last))))
                            (loop)))))))))))
 
-(define (cpan-module->sexp meta)
-  "Return the `package' s-expression for a CPAN module from the metadata in
-META."
+(define (cpan-module->sexp release)
+  "Return the 'package' s-expression for a CPAN module from the release data
+in RELEASE, a <cpan-release> record."
   (define name
-    (assoc-ref meta "distribution"))
+    (cpan-release-distribution release))
 
   (define (guix-name name)
     (if (string-prefix? "perl-" name)
         (string-downcase name)
         (string-append "perl-" (string-downcase name))))
 
-  (define version (cpan-version meta))
-  (define source-url (cpan-source-url meta))
+  (define version (cpan-release-version release))
+  (define source-url (cpan-source-url release))
 
   (define (convert-inputs phases)
     ;; Convert phase dependencies into a list of name/variable pairs.
-    (match (flatten
-            (map (lambda (ph)
-                   (filter-map (lambda (t)
-                                 (assoc-ref* meta "metadata" "prereqs" ph t))
-                               '("requires" "recommends" "suggests")))
-                 phases))
-      (#f
-       '())
+    (match (filter-map (lambda (dependency)
+                         (and (memq (cpan-dependency-phase dependency)
+                                    phases)
+                              (cpan-dependency-module dependency)))
+                       (cpan-release-dependencies release))
       ((inputs ...)
        (sort
         (delete-duplicates
          ;; Listed dependencies may include core modules.  Filter those out.
          (filter-map (match-lambda
-                      (("perl" . _)     ;implicit dependency
-                       #f)
-                      ((module . _)
-                       (and (not (core-module? module))
-                            (let ((name (guix-name (module->dist-name 
module))))
-                              (list name
-                                    (list 'unquote (string->symbol name)))))))
+                       ("perl" #f)                ;implicit dependency
+                       ((? core-module?) #f)
+                       (module
+                         (let ((name (guix-name (module->dist-name module))))
+                           (list name
+                                 (list 'unquote (string->symbol name))))))
                      inputs))
         (lambda args
           (match args
@@ -247,19 +296,19 @@ META."
                        ;; which says they are required during building.  We
                        ;; have not yet had a need for cross-compiled perl
                        ;; modules, however, so we leave it out.
-                       (convert-inputs '("configure" "build" "test")))
+                       (convert-inputs '(configure build test)))
        ,@(maybe-inputs 'propagated-inputs
-                       (convert-inputs '("runtime")))
+                       (convert-inputs '(runtime)))
        (home-page ,(cpan-home name))
-       (synopsis ,(assoc-ref meta "abstract"))
+       (synopsis ,(cpan-release-abstract release))
        (description fill-in-yourself!)
-       (license ,(string->license (assoc-ref meta "license"))))))
+       (license ,(string->license (cpan-release-license release))))))
 
 (define (cpan->guix-package module-name)
   "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
 `package' s-expression corresponding to that package, or #f on failure."
-  (let ((module-meta (cpan-fetch (module->name module-name))))
-    (and=> module-meta cpan-module->sexp)))
+  (let ((release (cpan-fetch (module->name module-name))))
+    (and=> release cpan-module->sexp)))
 
 (define (cpan-package? package)
   "Return #t if PACKAGE is a package from CPAN."
@@ -285,7 +334,7 @@ META."
   "Return an <upstream-source> for the latest release of PACKAGE."
   (match (cpan-fetch (package->upstream-name package))
     (#f #f)
-    (meta
+    (release
      (let ((core-inputs
             (match (package-direct-inputs package)
               (((_ inputs _ ...) ...)
@@ -303,8 +352,8 @@ META."
                      (warning (G_ "input '~a' of ~a is in Perl core~%")
                               module (package-name package)))
                    core-inputs)))
-     (let ((version (cpan-version meta))
-           (url (cpan-source-url meta)))
+     (let ((version (cpan-release-version release))
+           (url     (cpan-source-url release)))
        (upstream-source
         (package (package-name package))
         (version version)
diff --git a/tests/cpan.scm b/tests/cpan.scm
index 189dd02..043d401 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Eric Bavier <address@hidden>
 ;;; Copyright © 2016 Alex Sassmannshausen <address@hidden>
+;;; Copyright © 2020 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,13 +33,6 @@
 (define test-json
   "{
   \"metadata\" : {
-    \"prereqs\" : {
-      \"runtime\" : {
-        \"requires\" : {
-          \"Test::Script\" : \"1.05\",
-        }
-      }
-    }
     \"name\" : \"Foo-Bar\",
     \"version\" : \"0.1\"
   }
@@ -47,6 +41,13 @@
   \"license\" : [
     \"perl_5\"
   ],
+  \"dependency\": [
+     { \"relationship\": \"requires\",
+       \"phase\": \"runtime\",
+       \"version\": \"1.05\",
+       \"module\": \"Test::Script\"
+     }
+  ],
   \"abstract\" : \"Fizzle Fuzz\",
   \"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\";,
   \"author\" : \"Guix\",
@@ -107,16 +108,14 @@
                 (x
                  (pk 'fail x #f))))))
 
-(test-equal "source-url-http"
-  ((@@ (guix import cpan) cpan-source-url)
-   `(("download_url" .
-      "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz";)))
-  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+(test-equal "metacpan-url->mirror-url, http"
+  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
+  (metacpan-url->mirror-url
+   "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz";))
 
-(test-equal "source-url-https"
-  ((@@ (guix import cpan) cpan-source-url)
-   `(("download_url" .
-      "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz";)))
-  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+(test-equal "metacpan-url->mirror-url, https"
+  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
+  (metacpan-url->mirror-url
+   "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz";))
 
 (test-end "cpan")