diff --git a/Makefile.am b/Makefile.am index 3c22a77f1e..a1a87c09fe 100644 --- a/Makefile.am +++ b/Makefile.am @@ -75,7 +75,9 @@ MODULES = \ guix/build/syscalls.scm \ guix/build/emacs-utils.scm \ guix/packages.scm \ - guix/snix.scm \ + guix/import/utils.scm \ + guix/import/snix.scm \ + guix/import/pypi.scm \ guix/scripts/download.scm \ guix/scripts/build.scm \ guix/scripts/archive.scm \ @@ -89,6 +91,8 @@ MODULES = \ guix/scripts/refresh.scm \ guix/scripts/system.scm \ guix/scripts/lint.scm \ + guix/scripts/import/nix.scm \ + guix/scripts/import/pypi.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) @@ -162,6 +166,12 @@ SCM_TESTS = \ tests/syscalls.scm \ tests/lint.scm +if HAVE_GUILE_JSON + +SCM_TESTS += tests/pypi.scm + +endif + SH_TESTS = \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/configure.ac b/configure.ac index e516fa57b7..9c000912cc 100644 --- a/configure.ac +++ b/configure.ac @@ -61,6 +61,10 @@ if test "x$GUILD" = "x"; then AC_MSG_ERROR(['guild' binary not found; please check your guile-2.x installation.]) fi +dnl guile-json is used for the PyPI package importer +GUILE_MODULE_AVAILABLE([have_guile_json], [(json)]) +AM_CONDITIONAL([HAVE_GUILE_JSON], [test "x$have_guile_json" = "xyes"]) + dnl Make sure we have a full-fledged Guile. GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm new file mode 100644 index 0000000000..d0e776ef94 --- /dev/null +++ b/guix/import/pypi.scm @@ -0,0 +1,169 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; +;;; 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 . + +(define-module (guix import pypi) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) + #:use-module (json) + #:use-module (web uri) + #:use-module (guix utils) + #:use-module (guix import utils) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix packages) + #:use-module (guix licenses) + #:use-module (guix build-system python) + #:use-module ((guix build download) #:prefix build:) + #:use-module (gnu packages python) + #:export (pypi->guix-package)) + +(define (hash-table->alist table) + "Return an alist represenation of TABLE." + (map (match-lambda + ((key . (lst ...)) + (cons key + (map (lambda (x) + (if (hash-table? x) + (hash-table->alist x) + x)) + lst))) + ((key . (? hash-table? table)) + (cons key (hash-table->alist table))) + (pair pair)) + (hash-map->list cons table))) + +(define (flatten lst) + "Return a list that recursively concatenates all sub-lists of LIST." + (fold-right + (match-lambda* + (((sub-list ...) memo) + (append (flatten sub-list) memo)) + ((elem memo) + (cons elem memo))) + '() lst)) + +(define (join lst delimiter) + "Return a list that contains the elements of LST, each separated by +DELIMETER." + (match lst + (() '()) + ((elem) + (list elem)) + ((elem . rest) + (cons* elem delimiter (join rest delimiter))))) + +(define (assoc-ref* alist key . rest) + "Return the value for KEY from ALIST. For each additional key specified, +recursively apply the procedure to the sub-list." + (if (null? rest) + (assoc-ref alist key) + (apply assoc-ref* (assoc-ref alist key) rest))) + +(define string->license + (match-lambda + ("GNU LGPL" lgpl2.0) + ("GPL" gpl3) + ((or "BSD" "BSD License") bsd-3) + ((or "MIT" "MIT license" "Expat license") expat) + ("Public domain" public-domain) + (_ #f))) + +(define (url-fetch url file-name) + "Save the contents of URL to FILE-NAME." + (parameterize ((current-output-port (current-error-port))) + (build:url-fetch url file-name))) + +(define (json-fetch url) + "Return an alist representation of the JSON resource URL." + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch url temp) + (hash-table->alist + (call-with-input-file temp json->scm)))))) + +(define (pypi-fetch name) + "Return an alist representation of the PyPI metadata for the package NAME." + (json-fetch (string-append "https://pypi.python.org/pypi/" name "/json"))) + +(define (latest-source-release pypi-package) + "Return the latest source release for PYPI-PACKAGE." + (let ((releases (assoc-ref* pypi-package "releases" + (assoc-ref* pypi-package "info" "version")))) + (or (find (lambda (release) + (string=? "sdist" (assoc-ref release "packagetype"))) + releases) + (error "No source release found for pypi package: " + (assoc-ref* pypi-package "info" "name") + (assoc-ref* pypi-package "info" "version"))))) + +(define (snake-case str) + "Return a downcased version of the string STR where dashes are replaced with +underscores." + (string-join (string-split (string-downcase str) #\_) "-")) + +(define (guix-hash-url url) + "Download the resource at URL and return the hash in nix-base32 format." + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch url temp) + (bytevector->nix-base32-string + (call-with-input-file temp port-sha256)))))) + +(define (make-pypi-sexp name version source-url home-page synopsis + description license) + "Return the `package' s-expression for a python package with the given NAME, +VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + `(package + (name ,(string-append "python-" (snake-case name))) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(guix-hash-url source-url))))) + (build-system python-build-system) + (inputs + `(("python-setuptools" ,python-setuptools))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(assoc-ref `((,lgpl2.0 . lgpl2.0) + (,gpl3 . gpl3) + (,bsd-3 . bsd-3) + (,expat . expat) + (,public-domain . public-domain)) + license)))) + +(define (pypi->guix-package package-name) + "Fetch the metadata for PACKAGE-NAME from pypi.python.org, and return the +`package' s-expression corresponding to that package." + (let ((package (pypi-fetch package-name))) + (let ((name (assoc-ref* package "info" "name")) + (version (assoc-ref* package "info" "version")) + (release (assoc-ref (latest-source-release package) "url")) + (synopsis (assoc-ref* package "info" "summary")) + (description (assoc-ref* package "info" "summary")) + (home-page (assoc-ref* package "info" "home_page")) + (license (string->license (assoc-ref* package "info" "license")))) + (make-pypi-sexp name version release home-page synopsis + description license)))) diff --git a/guix/snix.scm b/guix/import/snix.scm similarity index 93% rename from guix/snix.scm rename to guix/import/snix.scm index a77433bdc3..bcc4d6b7a6 100644 --- a/guix/snix.scm +++ b/guix/import/snix.scm @@ -16,7 +16,7 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . -(define-module (guix snix) +(define-module (guix import snix) #:use-module (sxml ssax) #:use-module (ice-9 popen) #:use-module (ice-9 match) @@ -32,6 +32,7 @@ (define-module (guix snix) #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (guix utils) + #:use-module (guix import utils) #:use-module (guix base32) #:use-module (guix config) #:use-module (guix gnu-maintenance) @@ -318,34 +319,6 @@ (define (package-source-output-path package) ;;; Conversion of "Nix expressions" to "Guix expressions". ;;; -(define (factorize-uri uri version) - "Factorize URI, a package tarball URI as a string, such that any occurrences -of the string VERSION is replaced by the symbol 'version." - (let ((version-rx (make-regexp (regexp-quote version)))) - (match (regexp-exec version-rx uri) - (#f - uri) - (_ - (let ((indices (fold-matches version-rx uri - '((0)) - (lambda (m result) - (match result - (((start) rest ...) - `((,(match:end m)) - (,start . ,(match:start m)) - ,@rest))))))) - (fold (lambda (index result) - (match index - ((start) - (cons (substring uri start) - result)) - ((start . end) - (cons* (substring uri start end) - 'version - result)))) - '() - indices)))))) - (define (snix-derivation->guix-package derivation) "Return the `package' s-expression corresponding to SNix DERIVATION, a Nixpkgs `stdenv.mkDerivation'-style derivation, and the original source diff --git a/guix/import/utils.scm b/guix/import/utils.scm new file mode 100644 index 0000000000..062cfc54f3 --- /dev/null +++ b/guix/import/utils.scm @@ -0,0 +1,51 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix import utils) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:export (factorize-uri)) + +(define (factorize-uri uri version) + "Factorize URI, a package tarball URI as a string, such that any occurrences +of the string VERSION is replaced by the symbol 'version." + (let ((version-rx (make-regexp (regexp-quote version)))) + (match (regexp-exec version-rx uri) + (#f + uri) + (_ + (let ((indices (fold-matches version-rx uri + '((0)) + (lambda (m result) + (match result + (((start) rest ...) + `((,(match:end m)) + (,start . ,(match:start m)) + ,@rest))))))) + (fold (lambda (index result) + (match index + ((start) + (cons (substring uri start) + result)) + ((start . end) + (cons* (substring uri start end) + 'version + result)))) + '() + indices)))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 6f75017d6e..e9576bad8c 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2014 David Thompson ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,15 +19,16 @@ (define-module (guix scripts import) #:use-module (guix ui) - #:use-module (guix snix) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) - #:export (guix-import)) + #:export (%standard-import-options + guix-import)) ;;; @@ -61,15 +63,30 @@ (define (write-string str) ;;; -;;; Command-line options. +;;; Command line options. ;;; -(define %default-options - '()) +(define %standard-import-options '()) + + +;;; +;;; Entry point. +;;; + +(define importers '("nix" "pypi")) + +(define (resolve-importer name) + (let ((module (resolve-interface + `(guix scripts import ,(string->symbol name)))) + (proc (string->symbol (string-append "guix-import-" name)))) + (module-ref module proc))) (define (show-help) - (display (_ "Usage: guix import NIXPKGS ATTRIBUTE -Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) + (display (_ "Usage: guix import IMPORTER ARGS ... +Run IMPORTER with ARGS.\n")) + (newline) + (display (_ "IMPORTER must be one of the importers listed below:\n")) + (format #t "~{ ~a~%~}" importers) (display (_ " -h, --help display this help and exit")) (display (_ " @@ -77,43 +94,19 @@ (define (show-help) (newline) (show-bug-report-information)) -(define %options - ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix import"))))) - - -;;; -;;; Entry point. -;;; - (define (guix-import . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~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 - ((nixpkgs attribute) - (let-values (((expr loc) - (nixpkgs->guix-package nixpkgs attribute))) - (format #t ";; converted from ~a:~a~%~%" - (location-file loc) (location-line loc)) - (pretty-print expr (newline-rewriting-port (current-output-port))))) - (_ - (leave (_ "wrong number of arguments~%")))))) + (match args + (() + (format (current-error-port) + (_ "guix import: missing importer name~%"))) + ((or ("-h") ("--help")) + (show-help) + (exit 0)) + (("--version") + (show-version-and-exit "guix import")) + ((importer args ...) + (if (member importer importers) + (let ((expr (apply (resolve-importer importer) args))) + (pretty-print expr (newline-rewriting-port (current-output-port)))) + (format (current-error-port) + (_ "guix import: invalid importer~%")))))) diff --git a/guix/scripts/import/nix.scm b/guix/scripts/import/nix.scm new file mode 100644 index 0000000000..2dc2677c54 --- /dev/null +++ b/guix/scripts/import/nix.scm @@ -0,0 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2014 David Thompson +;;; +;;; 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 . + +(define-module (guix scripts import nix) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import snix) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-import-nix)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import nix NIXPKGS ATTRIBUTE +Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (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 nix"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-nix . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~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 + ((nixpkgs attribute) + (let-values (((expr loc) + (nixpkgs->guix-package nixpkgs attribute))) + (format #t ";; converted from ~a:~a~%~%" + (location-file loc) (location-line loc)) + expr)) + (_ + (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm new file mode 100644 index 0000000000..0aaa23a158 --- /dev/null +++ b/guix/scripts/import/pypi.scm @@ -0,0 +1,83 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; +;;; 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 . + +(define-module (guix scripts import pypi) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import pypi) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-pypi)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import pypi PACKAGE-NAME +Import and convert the PyPI package for PACKAGE-NAME.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (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 pypi"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-pypi . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~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) + (pypi->guix-package package-name))))) diff --git a/tests/pypi.scm b/tests/pypi.scm new file mode 100644 index 0000000000..124c512d54 --- /dev/null +++ b/tests/pypi.scm @@ -0,0 +1,102 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; +;;; 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 . + +(define-module (test-pypi) + #:use-module (guix import pypi) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(define-syntax-rule (mock (module proc replacement) body ...) + (let* ((m (resolve-module 'module)) + (original (module-ref m 'proc))) + (dynamic-wind + (lambda () (module-set! m 'proc replacement)) + (lambda () body ...) + (lambda () (module-set! m 'proc original))))) + +(define test-json + "{ + \"info\": { + \"version\": \"1.0.0\", + \"name\": \"foo\", + \"license\": \"GNU LGPL\", + \"summary\": \"summary\", + \"home_page\": \"http://example.com\", + }, + \"releases\": { + \"1.0.0\": [ + { + \"url\": \"https://example.com/foo-1.0.0.egg\", + \"packagetype\": \"bdist_egg\", + }, { + \"url\": \"https://example.com/foo-1.0.0.tar.gz\", + \"packagetype\": \"sdist\", + } + ] + } +}") + +(define test-source + "foobar") + +(test-begin "pypi") + +(test-assert "pypi->guix-package" + ;; Replace network resources with sample data. + (mock ((guix import pypi) url-fetch + (lambda (url file-name) + (with-output-to-file file-name + (lambda () + (display + (match url + ("https://pypi.python.org/pypi/foo/json" + test-json) + ("https://example.com/foo-1.0.0.tar.gz" + test-source) + (_ (error "Unexpected URL: " url)))))))) + (match (pypi->guix-package "foo") + (('package + ('name "python-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri ('string-append "https://example.com/foo-" + 'version ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'python-build-system) + ('inputs + ('quasiquote + (("python-setuptools" ('unquote 'python-setuptools))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license 'lgpl2.0)) + (string=? (bytevector->nix-base32-string + (call-with-input-string test-source port-sha256)) + hash)) + (x + (pk 'fail x #f))))) + +(test-end "pypi") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/snix.scm b/tests/snix.scm index 9d692e9c02..2318780d3d 100644 --- a/tests/snix.scm +++ b/tests/snix.scm @@ -17,14 +17,14 @@ ;;; along with GNU Guix. If not, see . (define-module (test-snix) - #:use-module (guix snix) + #:use-module (guix import snix) #:use-module ((guix utils) #:select (%nixpkgs-directory)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) (define factorize-uri - (@@ (guix snix) factorize-uri)) + (@@ (guix import snix) factorize-uri)) (define-syntax-rule (every? proc lists ...) (not (not (every proc lists ...))))