[bug#42338] [PATCH 01/34] guix: import: Add composer importer.

[Julien Lepiller]

* guix/import/composer.scm: New file.
* guix/scripts/import/composer.scm: New file.
* Makefile.am: Add them.
* guix/scripts/import.scm: Add composer importer.
---
 Makefile.am                      |   2 +
 guix/import/composer.scm         | 252 +++++++++++++++++++++++++++++++
 guix/scripts/import.scm          |   2 +-
 guix/scripts/import/composer.scm | 107 +++++++++++++
 4 files changed, 362 insertions(+), 1 deletion(-)
 create mode 100644 guix/import/composer.scm
 create mode 100644 guix/scripts/import/composer.scm

diff --git a/Makefile.am b/Makefile.am
index 20d43cd130..623ddf32b2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -219,6 +219,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                                \
@@ -265,6 +266,7 @@ MODULES =                                   \
   guix/scripts/system/reconfigure.scm          \
   guix/scripts/lint.scm                                \
   guix/scripts/challenge.scm                   \
+  guix/scripts/import/composer.scm             \
   guix/scripts/import/crate.scm                        \
   guix/scripts/import/cran.scm                 \
   guix/scripts/import/elpa.scm                 \
diff --git a/guix/import/composer.scm b/guix/import/composer.scm
new file mode 100644
index 0000000000..0e17eb0487
--- /dev/null
+++ b/guix/import/composer.scm
@@ -0,0 +1,252 @@
+;;; 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 (gcrypt hash)
+  #:use-module (guix base32)
+  #:use-module (guix build git)
+  #:use-module (guix build utils)
+  #:use-module (guix build-system)
+  #:use-module (guix import json)
+  #:use-module (guix import utils)
+  #:use-module ((guix licenses) #:prefix license:)
+  #: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)
+  #:export (composer->guix-package
+            %composer-updater
+            composer-recursive-import))
+
+;; 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 (latest-version versions)
+  (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
+
+(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* (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 "https://repo.packagist.org/p/"; name 
".json"))))
+    (if package
+        (let* ((packages (assoc-ref package "packages"))
+               (package (assoc-ref packages name))
+               (versions (filter
+                           (lambda (version)
+                             (and (not (string-contains version "dev"))
+                                  (not (string-contains version "beta"))))
+                           (map car package)))
+               (versions (map
+                           (lambda (version)
+                             (cons (fix-version version) version))
+                           versions))
+               (version (or (if (null? version) #f version)
+                            (latest-version (map car versions)))))
+          (assoc-ref package (assoc-ref versions version)))
+        #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 name version home-page description dependencies
+                       dev-dependencies licenses source)
+  "Return the `package' s-expression for a PHP package with the given NAME,
+VERSION, HOME-PAGE, DESCRIPTION, DEPENDENCIES, LICENSES and SOURCE."
+  (let ((git? (equal? (assoc-ref source "type") "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 (assoc-ref source "url")
+                             (assoc-ref source "reference")
+                             temp))
+                (url-fetch (assoc-ref source "url") temp))
+            `(package
+               (name ,(php-package-name name))
+               (version ,version)
+               (source (origin
+                         ,@(if git?
+                               `((method git-fetch)
+                                 (uri (git-reference
+                                        (url ,(assoc-ref source "url"))
+                                        (commit ,(assoc-ref source 
"reference"))))
+                                 (file-name (git-file-name name version))
+                                 (sha256
+                                   (base32
+                                     ,(bytevector->nix-base32-string
+                                       (file-hash temp (negate vcs-file?) 
#t)))))
+                               `((method url-fetch)
+                                 (uri ,(assoc-ref source "url"))
+                                 (sha256 (base32 ,(guix-hash-url temp)))))))
+               (build-system composer-build-system)
+               ,@(if (null? dependencies)
+                     '()
+                     `((inputs
+                        (,'quasiquote
+                         ,(map (lambda (name)
+                                 `(,name
+                                   (,'unquote
+                                    ,(string->symbol name))))
+                               dependencies)))))
+               ,@(if (null? dev-dependencies)
+                     '()
+                     `((native-inputs
+                        (,'quasiquote
+                         ,(map (lambda (name)
+                                 `(,name
+                                   (,'unquote
+                                    ,(string->symbol name))))
+                               dev-dependencies)))))
+               (synopsis "")
+               (description ,description)
+               (home-page ,home-page)
+               (license ,(match licenses
+                           (() #f)
+                           ((license) (license->symbol license))
+                           (_ `(list ,@(map license->symbol licenses)))))))))))
+
+(define* (composer->guix-package package-name #:optional version)
+  "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)))
+    (and package
+         (let* ((name         (assoc-ref package "name"))
+                (version      (fix-version (assoc-ref package "version")))
+                (description  (beautify-description
+                               (assoc-ref package "description")))
+                (home-page    (assoc-ref package "homepage"))
+                (dependencies-names (filter
+                                      (lambda (dep)
+                                        (string-contains dep "/"))
+                                      (map car (assoc-ref package "require"))))
+                (dependencies (map php-package-name dependencies-names))
+                (require-dev (assoc-ref package "require-dev"))
+                (dev-dependencies-names
+                  (if require-dev
+                      (filter
+                        (lambda (dep)
+                          (string-contains dep "/"))
+                        (map car require-dev))
+                      '()))
+                (dev-dependencies (map php-package-name 
dev-dependencies-names))
+                (licenses     (map string->license
+                                   (vector->list
+                                    (assoc-ref package "license")))))
+           (values (make-php-sexp name version home-page description 
dependencies
+                                  dev-dependencies licenses (assoc-ref package 
"source"))
+                   (append dependencies-names dev-dependencies-names))))))
+
+(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."
+  (match str
+    ("GNU LGPL" license:lgpl2.0)
+    ("GPL" license:gpl3)
+    ((or "BSD" "BSD License" "BSD-3-Clause") 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)
+    (_ #f)))
+
+(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))))
+
+(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))
+         (version (fix-version (assoc-ref metadata "version")))
+         (url (assoc-ref (assoc-ref metadata "source") "url")))
+    (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?)
+   (latest latest-release)))
+
+(define* (composer-recursive-import package-name #:optional version)
+  (recursive-import package-name '()
+                    #:repo->guix-package composer->guix-package
+                    #:guix-name php-package-name))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index c6cc93fad8..4c91627283 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -76,7 +76,7 @@ rather than \\n."
 ;;;
 
 (define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
-                    "cran" "crate" "texlive" "json" "opam"))
+                    "cran" "crate" "texlive" "json" "opam" "composer"))
 
 (define (resolve-importer name)
   (let ((module (resolve-interface
diff --git a/guix/scripts/import/composer.scm b/guix/scripts/import/composer.scm
new file mode 100644
index 0000000000..412bae6318
--- /dev/null
+++ b/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~%"))))))
-- 
2.27.0