From 70b9cb2bb389f3e5f9dcc75a44d7d60c28f997bc Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Tue, 29 Oct 2019 08:07:38 +0100
Subject: [PATCH 01/34] 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.
---
Makefile.am | 3 +
doc/guix.texi | 11 ++
guix/import/composer.scm | 270 +++++++++++++++++++++++++++++++
guix/scripts/import.scm | 2 +-
guix/scripts/import/composer.scm | 107 ++++++++++++
tests/composer.scm | 92 +++++++++++
6 files changed, 484 insertions(+), 1 deletion(-)
create mode 100644 guix/import/composer.scm
create mode 100644 guix/scripts/import/composer.scm
create mode 100644 tests/composer.scm
@@ -223,6 +223,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 \
@@ -269,6 +270,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 \
@@ -402,6 +404,7 @@ SCM_TESTS = \
tests/challenge.scm \
tests/channels.scm \
tests/combinators.scm \
+ tests/composer.scm \
tests/containers.scm \
tests/cpan.scm \
tests/cpio.scm \
@@ -10164,6 +10164,17 @@ in Guix.
@cindex OCaml
Import metadata from the @uref{https://opam.ocaml.org/, OPAM} package
repository used by the OCaml community.
+
+@item composer
+@cindex Composer
+@cindex PHP
+Import metadat 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
+
@end table
The structure of the @command{guix import} code is modular. It would be
new file mode 100644
@@ -0,0 +1,270 @@
+;;; 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)
+ #: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"))
+
+;; 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
+ ((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))))
+ '()))
+
+(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)
+ (map string->license (vector->list vector)))))
+
+(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))
+ #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 ,(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
+ (,'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 ,(composer-package-description composer-package))
+ (home-page ,(composer-package-homepage composer-package))
+ (license ,(match (composer-package-license composer-package)
+ (() #f)
+ ((license) license)
+ (_ license)))))))))
+
+(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* ((package (json->composer-package package))
+ (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))))))
+
+(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))
+ (package (json->composer-package metadata))
+ (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?)
+ (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))
@@ -77,7 +77,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
new file mode 100644
@@ -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~%"))))))
new file mode 100644
@@ -0,0 +1,92 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 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 (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")
+
+;; Avoid collisions with other tests.
+(%http-server-port 10450)
+
+(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
+ ('quasiquote
+ (("php-phpunit-phpunit" ('unquote '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")
--
2.28.0