guix: import: Add composer importer.

* guix/import/composer.scm: New file.
* guix/scripts/import/composer.scm: New file.
* guix/tests/composer.scm: New file.
* Makefile.am: Add them.
* guix/scripts/import.scm: Add composer importer.
* doc/guix.texi (Invoking guix import): Mention it.

Change-Id: I44a89b8cc80ef5b4a3cd15e8fbba4a18c1cea0b1

Co-authored-by: Julien Lepiller <julien@lepiller.eu>
Co-authored-by: Ludovic Courtès <ludo@gnu.org>

Makefile.am

@@ -283,6 +283,7 @@ MODULES =					\
   guix/search-paths.scm				\
   guix/packages.scm				\
   guix/import/cabal.scm				\
+  guix/import/composer.scm			\
   guix/import/cpan.scm				\
   guix/import/cran.scm				\
   guix/import/crate.scm				\
@@ -341,6 +342,7 @@ MODULES =					\
   guix/scripts/home/import.scm			\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
+  guix/scripts/import/composer.scm		\
   guix/scripts/import/crate.scm			\
   guix/scripts/import/cpan.scm			\
   guix/scripts/import/cran.scm			\
@@ -509,6 +511,7 @@ SCM_TESTS =					\
   tests/challenge.scm				\
   tests/channels.scm				\
   tests/combinators.scm			\
+  tests/composer.scm				\
   tests/containers.scm				\
   tests/cpan.scm				\
   tests/cpio.scm				\

doc/guix.texi

@@ -14533,6 +14533,26 @@ repository used by the OCaml community.
 
 Additional options include:
 
+@table @code
+@item --recursive
+@itemx -r
+Traverse the dependency graph of the given upstream package recursively
+and generate package expressions for all those packages that are not yet
+in Guix.
+@end table
+
+@item composer
+@cindex Composer
+@cindex PHP
+Import metadata from the @uref{https://getcomposer.org/, Composer} package
+archive used by the PHP community, as in this example:
+
+@example
+guix import composer phpunit/phpunit
+@end example
+
+Additional options include:
+
 @table @code
 @item --recursive
 @itemx -r

guix/import/composer.scm

@@ -0,0 +1,268 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(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 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 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
+            composer-recursive-import
+
+            %composer-base-url))
+
+(define %composer-base-url
+  (make-parameter "https://repo.packagist.org"))
+
+(define (fix-version version)
+  "Return a fixed version from a version string.  For instance, v10.1 -> 10.1"
+  (cond
+    ((string-prefix? "version" version)
+     (if (char-set-contains? char-set:digit (string-ref version 7))
+         (substring version 7)
+         (substring version 8)))
+    ((string-prefix? "v" 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 (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)))
+      '()))
+
+(define-json-mapping <composer-source> make-composer-source composer-source?
+  json->composer-source
+  (type      composer-source-type)
+  (url       composer-source-url)
+  (reference composer-source-reference))
+
+(define-json-mapping <composer-package> make-composer-package composer-package?
+  json->composer-package
+  (description composer-package-description)
+  (homepage    composer-package-homepage)
+  (source      composer-package-source "source" json->composer-source)
+  (name        composer-package-name "name" php-package-name)
+  (version     composer-package-version "version" fix-version)
+  (require     composer-package-require "require" json->require)
+  (dev-require composer-package-dev-require "require-dev" json->require)
+  (license     composer-package-license "license"
+               (lambda (vector)
+                 (let ((l (map string->license (vector->list vector))))
+                   (if (eq? (length l) 1)
+                       (car l)
+                       `(list ,@l))))))
+
+(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)
+  "Given the NAME of a package on Packagist, return a Guix-compliant name for
+the package."
+  (let ((name (string-join (string-split name #\/) "-")))
+    (if (string-prefix? "php-" name)
+        (snake-case name)
+        (string-append "php-" (snake-case name)))))
+
+(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
+                            (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!))))))))
+
+(define composer->guix-package
+  (memoize
+   (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 and its list of
+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 #f '()))))))
+
+(define (guix-name->composer-name name)
+  "Given a guix package name, return the name of the package in Packagist."
+  (if (string-prefix? "php-" name)
+      (let ((components (string-split (substring name 4) #\-)))
+        (match components
+          ((namespace name ...)
+           (string-append namespace "/" (string-join name "-")))))
+      name))
+
+(define (guix-package->composer-name package)
+  "Given a Composer PACKAGE built from Packagist, return the name of the
+package in Packagist."
+  (let ((upstream-name (assoc-ref
+                         (package-properties package)
+                         'upstream-name))
+        (name (package-name package)))
+    (if upstream-name
+      upstream-name
+      (guix-name->composer-name name))))
+
+(define (string->license str)
+  "Convert the string STR into a license object."
+  (or (spdx-string->license str)
+      (match str
+        ("GNU LGPL" 'license:lgpl2.0)
+        ("GPL" 'license:gpl3)
+        ((or "BSD" "BSD License") 'license:bsd-3)
+        ((or "MIT" "MIT license" "Expat license") 'license:expat)
+        ("Public domain" 'license:public-domain)
+        ((or "Apache License, Version 2.0" "Apache 2.0") 'license:asl2.0)
+        (_ 'unknown-license!))))
+
+(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))))
+
+(define (latest-release package)
+  "Return an <upstream-source> for the latest release of PACKAGE."
+  (let* ((php-name (guix-package->composer-name package))
+         (package (composer-fetch php-name))
+         (version (composer-package-version package))
+         (url (composer-source-url (composer-package-source package))))
+    (upstream-source
+     (package (package-name package))
+     (version version)
+     (urls (list url)))))
+
+(define %composer-updater
+  (upstream-updater
+   (name 'composer)
+   (description "Updater for Composer packages")
+   (pred php-package?)
+   (import latest-release)))
+
+(define* (composer-recursive-import package-name #:optional version)
+  (recursive-import package-name
+                    #:version version
+                    #:repo->guix-package composer->guix-package
+                    #:guix-name php-package-name))

guix/scripts/import.scm

@@ -47,7 +47,7 @@ (define %standard-import-options '())
 
 (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa"
                     "gem" "go" "cran" "crate" "texlive" "json" "opam"
-                    "minetest" "elm" "hexpm"))
+                    "minetest" "elm" "hexpm" "composer"))
 
 (define (resolve-importer name)
   (let ((module (resolve-interface

guix/scripts/import/composer.scm

@@ -0,0 +1,107 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts import composer)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix scripts)
+  #:use-module (guix import composer)
+  #:use-module (guix scripts import)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-41)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:export (guix-import-composer))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  '())
+
+(define (show-help)
+  (display (G_ "Usage: guix import composer PACKAGE-NAME
+Import and convert the Composer package for PACKAGE-NAME.\n"))
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (display (G_ "
+  -r, --recursive        generate package expressions for all Composer packages\
+ that are not yet in Guix"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  (cons* (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix import composer")))
+         (option '(#\r "recursive") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'recursive #t result)))
+         %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-composer . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold* args %options
+                (lambda (opt name arg result)
+                  (leave (G_ "~A: unrecognized option~%") name))
+                (lambda (arg result)
+                  (alist-cons 'argument arg result))
+                %default-options))
+
+  (let* ((opts (parse-options))
+         (args (filter-map (match-lambda
+                            (('argument . value)
+                             value)
+                            (_ #f))
+                           (reverse opts))))
+    (match args
+      ((package-name)
+       (if (assoc-ref opts 'recursive)
+           (map (match-lambda
+                  ((and ('package ('name name) . rest) pkg)
+                   `(define-public ,(string->symbol name)
+                      ,pkg))
+                  (_ #f))
+                (composer-recursive-import package-name))
+           (let ((sexp (composer->guix-package package-name)))
+             (unless sexp
+               (leave (G_ "failed to download meta-data for package '~a'~%")
+                      package-name))
+             sexp)))
+      (()
+       (leave (G_ "too few arguments~%")))
+      ((many ...)
+       (leave (G_ "too many arguments~%"))))))

tests/composer.scm

@@ -0,0 +1,88 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-composer)
+  #:use-module (guix import composer)
+  #:use-module (guix base32)
+  #:use-module (gcrypt hash)
+  #:use-module (guix tests http)
+  #:use-module (guix grafts)
+  #:use-module (srfi srfi-64)
+  #:use-module (web client)
+  #:use-module (ice-9 match))
+
+;; Globally disable grafts because they can trigger early builds.
+(%graft? #f)
+
+(define test-json
+  "{
+  \"packages\": {
+    \"foo/bar\": {
+      \"0.1\": {
+        \"name\": \"foo/bar\",
+        \"description\": \"description\",
+        \"keywords\": [\"testing\"],
+        \"homepage\": \"http://example.com\",
+        \"version\": \"0.1\",
+        \"license\": [\"BSD-3-Clause\"],
+        \"source\": {
+          \"type\": \"url\",
+          \"url\": \"http://example.com/Bar-0.1.tar.gz\"
+        },
+        \"require\": {},
+        \"require-dev\": {\"phpunit/phpunit\": \"1.0.0\"}
+      }
+    }
+  }
+}")
+
+(define test-source
+  "foobar")
+
+(test-begin "composer")
+
+(test-assert "composer->guix-package"
+  ;; Replace network resources with sample data.
+  (with-http-server `((200 ,test-json)
+                      (200 ,test-source))
+    (parameterize ((%composer-base-url (%local-url))
+                   (current-http-proxy (%local-url)))
+      (match (composer->guix-package "foo/bar")
+        (`(package
+            (name "php-foo-bar")
+            (version "0.1")
+            (source (origin
+                      (method url-fetch)
+                      (uri "http://example.com/Bar-0.1.tar.gz")
+                      (sha256
+                       (base32
+                        ,(? string? hash)))))
+            (build-system composer-build-system)
+            (native-inputs (list php-phpunit-phpunit))
+            (synopsis "")
+            (description "description")
+            (home-page "http://example.com")
+            (license license:bsd-3))
+         (string=? (bytevector->nix-base32-string
+                    (call-with-input-string test-source port-sha256))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
+
+(test-end "composer")