From 05f0607bfc3d47ee493e12051272656db58fcd04 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Jan 2015 22:33:21 +0100 Subject: tests: Add missing copyright line. * tests/lint.scm: Add missing copyright line for commit 907c98ac and others. --- tests/lint.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'tests') diff --git a/tests/lint.scm b/tests/lint.scm index 2aebbffd0a..c6931329d6 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; -- cgit 1.4.1 From 1ff2619bc114aface6b7b9d818f7208f9af677df Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 Jan 2015 14:38:54 -0600 Subject: import: Factorize utility functions. * guix/import/pypi.scm (hash-table->alist, flatten, assoc-ref*, url-fetch, json-fetch): Pull procedures from here into... * guix/import/utils.scm: Here and... * guix/import/json.scm: Here. New file. * Makefile.am (MODULE)[HAVE_GUILE_JSON]: Add it. * guix/import/gnu.scm (file-sha256): Move from here to... * guix/hash.scm: Here. * tests/pypi.scm (pypi->guix-package): Update mock module reference. --- Makefile.am | 1 + guix/hash.scm | 5 +++++ guix/import/gnu.scm | 5 +---- guix/import/json.scm | 32 ++++++++++++++++++++++++++++++++ guix/import/pypi.scm | 47 +---------------------------------------------- guix/import/utils.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++++- tests/pypi.scm | 2 +- 7 files changed, 88 insertions(+), 52 deletions(-) create mode 100644 guix/import/json.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index bc0b95232e..c2bb1762ff 100644 --- a/Makefile.am +++ b/Makefile.am @@ -174,6 +174,7 @@ SCM_TESTS = \ if HAVE_GUILE_JSON MODULES += \ + guix/import/json.scm \ guix/import/pypi.scm \ guix/scripts/import/pypi.scm diff --git a/guix/hash.scm b/guix/hash.scm index fb85f47586..593c2e1aee 100644 --- a/guix/hash.scm +++ b/guix/hash.scm @@ -26,6 +26,7 @@ #:export (sha256 open-sha256-port port-sha256 + file-sha256 open-sha256-input-port)) ;;; Commentary: @@ -129,6 +130,10 @@ output port." (close-port out) (get))) +(define (file-sha256 file) + "Return the SHA256 hash (a bytevector) of FILE." + (call-with-input-file file port-sha256)) + (define (open-sha256-input-port port) "Return an input port that wraps PORT and a thunk to get the hash of all the data read from PORT. The thunk always returns the same value." diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index b5f67bd2d4..7160fcf7ba 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -18,6 +18,7 @@ (define-module (guix import gnu) #:use-module (guix gnu-maintenance) + #:use-module (guix import utils) #:use-module (guix utils) #:use-module (guix store) #:use-module (guix hash) @@ -38,10 +39,6 @@ ;;; ;;; Code: -(define (file-sha256 file) - "Return the SHA256 hash of FILE as a bytevector." - (call-with-input-file file port-sha256)) - (define (qualified-url url) "Return a fully-qualified URL based on URL." (if (string-prefix? "/" url) diff --git a/guix/import/json.scm b/guix/import/json.scm new file mode 100644 index 0000000000..c3092a5a9d --- /dev/null +++ b/guix/import/json.scm @@ -0,0 +1,32 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2015 Eric Bavier +;;; +;;; 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 json) + #:use-module (json) + #:use-module (guix utils) + #:use-module (guix import utils) + #:export (json-fetch)) + +(define (json-fetch url) + "Return an alist representation of the JSON resource URL, or #f on failure." + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch url temp) + (hash-table->alist + (call-with-input-file temp json->scm)))))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 88f4a8e896..8567cad79c 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -27,40 +27,15 @@ #:use-module (web uri) #:use-module (guix utils) #:use-module (guix import utils) + #:use-module (guix import json) #: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." @@ -71,13 +46,6 @@ DELIMETER." ((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) @@ -88,19 +56,6 @@ recursively apply the procedure to the sub-list." ("Apache License, Version 2.0" asl2.0) (_ #f))) -(define (url-fetch url file-name) - "Save the contents of URL to FILE-NAME. Return #f on failure." - (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, or #f on failure." - (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, or #f on failure." diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 062cfc54f3..969491d28d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -20,7 +20,16 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) - #:export (factorize-uri)) + #:use-module (guix hash) + #:use-module (guix utils) + #:use-module ((guix build download) #:prefix build:) + #:export (factorize-uri + + hash-table->alist + flatten + assoc-ref* + + url-fetch)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -49,3 +58,40 @@ of the string VERSION is replaced by the symbol 'version." result)))) '() indices)))))) + +(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 LST." + (fold-right + (match-lambda* + (((sub-list ...) memo) + (append (flatten sub-list) memo)) + ((elem memo) + (cons elem memo))) + '() lst)) + +(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 (url-fetch url file-name) + "Save the contents of URL to FILE-NAME. Return #f on failure." + (parameterize ((current-output-port (current-error-port))) + (build:url-fetch url file-name))) diff --git a/tests/pypi.scm b/tests/pypi.scm index 124c512d54..53c34d9e93 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -60,7 +60,7 @@ (test-assert "pypi->guix-package" ;; Replace network resources with sample data. - (mock ((guix import pypi) url-fetch + (mock ((guix import utils) url-fetch (lambda (url file-name) (with-output-to-file file-name (lambda () -- cgit 1.4.1 From 694b317c2dfac5f8b284a5831e20d89cc112bd6b Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 Jan 2015 14:41:15 -0600 Subject: tests: import: Factorize utility function. * tests/pypi.scm (mock): Move this... * guix/tests.scm: to here. --- guix/tests.scm | 11 +++++++++++ tests/pypi.scm | 9 +-------- 2 files changed, 12 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/guix/tests.scm b/guix/tests.scm index 82ae7e2084..36341cb4cc 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -27,6 +27,7 @@ #:export (open-connection-for-tests random-text random-bytevector + mock with-derivation-narinfo dummy-package)) @@ -70,6 +71,16 @@ (loop (1+ i))) bv)))) +(define-syntax-rule (mock (module proc replacement) body ...) + "Within BODY, replace the definition of PROC from MODULE with the definition +given by REPLACEMENT." + (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))))) + ;;; ;;; Narinfo files, as used by the substituter. diff --git a/tests/pypi.scm b/tests/pypi.scm index 53c34d9e93..45cf7cac4f 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -20,17 +20,10 @@ #:use-module (guix import pypi) #:use-module (guix base32) #:use-module (guix hash) + #:use-module (guix tests) #: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\": { -- cgit 1.4.1 From d45dc6da5c802024f31dba95919c06205c5e31e4 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 Jan 2015 14:51:13 -0600 Subject: import: Add CPAN importer. * guix/import/cpan.scm, guix/scripts/import/cpan.scm, tests/cpan.scm: New files. * Makefile.am (MODULE)[HAVE_GUILE_JSON]: Add them. * guix/scripts/import.scm (importers): Add cpan. * doc/guix.texi (Requirements): Mention `guix import cpan` as a user of guile-json. (Invoking guix import): Document new `guix import cpan` command. --- Makefile.am | 8 ++- doc/guix.texi | 24 +++++-- guix/import/cpan.scm | 167 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/cpan.scm | 91 +++++++++++++++++++++++ tests/cpan.scm | 107 +++++++++++++++++++++++++++ 6 files changed, 392 insertions(+), 7 deletions(-) create mode 100644 guix/import/cpan.scm create mode 100644 guix/scripts/import/cpan.scm create mode 100644 tests/cpan.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index c2bb1762ff..5ee743470b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -176,9 +176,13 @@ if HAVE_GUILE_JSON MODULES += \ guix/import/json.scm \ guix/import/pypi.scm \ - guix/scripts/import/pypi.scm + guix/scripts/import/pypi.scm \ + guix/import/cpan.scm \ + guix/scripts/import/cpan.scm -SCM_TESTS += tests/pypi.scm +SCM_TESTS += \ + tests/pypi.scm \ + tests/cpan.scm endif diff --git a/doc/guix.texi b/doc/guix.texi index 12a1808137..8341a707d0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -258,10 +258,10 @@ interest primarily for developers and not for casual users. @item Installing @uref{http://gnutls.org/, GnuTLS-Guile} will allow you to access @code{https} URLs with the @command{guix download} -command (@pxref{Invoking guix download}) and the @command{guix import -pypi} command. This is primarily of interest to developers. -@xref{Guile Preparations, how to install the GnuTLS bindings for Guile,, -gnutls-guile, GnuTLS-Guile}. +command (@pxref{Invoking guix download}), the @command{guix import pypi} +command, and the @command{guix import cpan} command. This is primarily +of interest to developers. @xref{Guile Preparations, how to install the +GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}. @end itemize Unless @code{--disable-daemon} was passed to @command{configure}, the @@ -2957,6 +2957,22 @@ package: guix import pypi itsdangerous @end example +@item cpan +@cindex CPAN +Import meta-data from @uref{https://www.metacpan.org/, MetaCPAN}. +Information is taken from the JSON-formatted meta-data provided through +@uref{https://api.metacpan.org/, MetaCPAN's API} and includes most +relevant information. License information should be checked closely. +Package dependencies are included but may in some cases needlessly +include core Perl modules. + +The command command below imports meta-data for the @code{Acme::Boolean} +Perl module: + +@example +guix import cpan Acme::Boolean +@end example + @item nix Import meta-data from a local copy of the source of the @uref{http://nixos.org/nixpkgs/, Nixpkgs distribution}@footnote{This diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm new file mode 100644 index 0000000000..5f4602a8d2 --- /dev/null +++ b/guix/import/cpan.scm @@ -0,0 +1,167 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; +;;; 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 cpan) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (json) + #:use-module (guix hash) + #:use-module (guix store) + #:use-module (guix base32) + #:use-module ((guix download) #:select (download-to-store)) + #:use-module (guix import utils) + #:use-module (guix import json) + #:export (cpan->guix-package)) + +;;; Commentary: +;;; +;;; Generate a package declaration template for the latest version of a CPAN +;;; module, using meta-data from metacpan.org. +;;; +;;; Code: + +(define string->license + (match-lambda + ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec. + ;; Some licenses are excluded based on their absense from (guix licenses). + ("agpl_3" 'agpl3) + ;; apache_1_1 + ("apache_2_0" 'asl2.0) + ;; artistic_1_0 + ;; artistic_2_0 + ("bsd" 'bsd-3) + ("freebsd" 'bsd-2) + ;; gfdl_1_2 + ("gfdl_1_3" 'fdl1.3+) + ("gpl_1" 'gpl1) + ("gpl_2" 'gpl2) + ("gpl_3" 'gpl3) + ("lgpl_2_1" 'lgpl2.1) + ("lgpl_3_0" 'lgpl3) + ("mit" 'x11) + ;; mozilla_1_0 + ("mozilla_1_1" 'mpl1.1) + ("openssl" 'openssl) + ("perl_5" 'gpl1+) ;and Artistic 1 + ("qpl_1_0" 'qpl) + ;; ssleay + ;; sun + ("zlib" 'zlib) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + +(define (module->name module) + "Transform a 'module' name into a 'release' name" + (regexp-substitute/global #f "::" module 'pre "-" 'post)) + +(define (cpan-fetch module) + "Return an alist representation of the CPAN metadata for the perl module MODULE, +or #f on failure. MODULE should be e.g. \"Test::Script\"" + ;; This API always returns the latest release of the module. + (json-fetch (string-append "http://api.metacpan.org/release/" + ;; XXX: The 'release' api requires the "release" + ;; name of the package. This substitution seems + ;; reasonably consistent across packages. + (module->name module)))) + +(define (cpan-home name) + (string-append "http://search.cpan.org/dist/" name)) + +(define (cpan-module->sexp meta) + "Return the `package' s-expression for a CPAN module from the metadata in +META." + (define name + (assoc-ref meta "distribution")) + + (define (guix-name name) + (if (string-prefix? "perl-" name) + (string-downcase name) + (string-append "perl-" (string-downcase name)))) + + (define version + (assoc-ref meta "version")) + + (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 + '()) + ((inputs ...) + (delete-duplicates + ;; Listed dependencies may include core modules. Filter those out. + (filter-map (match-lambda + ((or (module . "0") ("perl" . _)) + ;; TODO: A stronger test might to run MODULE through + ;; `corelist' from our perl package. This current test + ;; seems to be only a loose convention. + #f) + ((module . _) + (let ((name (guix-name (module->name module)))) + (list name + (list 'unquote (string->symbol name)))))) + inputs))))) + + (define (maybe-inputs guix-name inputs) + (match inputs + (() + '()) + ((inputs ...) + (list (list guix-name + (list 'quasiquote inputs)))))) + + (define source-url + (assoc-ref meta "download_url")) + + (let ((tarball (with-store store + (download-to-store store source-url)))) + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (build-system perl-build-system) + ,@(maybe-inputs 'native-inputs + ;; "runtime" and "test" may also be needed here. See + ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases, + ;; which says they are required during building. We + ;; have not yet had a need for cross-compiled perl + ;; modules, however, so we leave them out. + (convert-inputs '("configure" "build"))) + ,@(maybe-inputs 'inputs + (convert-inputs '("runtime"))) + (home-page ,(string-append "http://search.cpan.org/dist/" name)) + (synopsis ,(assoc-ref meta "abstract")) + (description fill-in-yourself!) + (license ,(string->license (assoc-ref meta "license")))))) + +(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))) + (and=> module-meta cpan-module->sexp))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 86ef05bc2c..7e75c10b3e 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi")) +(define importers '("gnu" "nix" "pypi" "cpan")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/cpan.scm b/guix/scripts/import/cpan.scm new file mode 100644 index 0000000000..1f4dedf23f --- /dev/null +++ b/guix/scripts/import/cpan.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; +;;; 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 cpan) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import cpan) + #: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-cpan)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import cpan PACKAGE-NAME +Import and convert the CPAN 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 cpan"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-cpan . 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) + (let ((sexp (cpan->guix-package package-name))) + (unless sexp + (leave (_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/tests/cpan.scm b/tests/cpan.scm new file mode 100644 index 0000000000..af7b36e684 --- /dev/null +++ b/tests/cpan.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Eric Bavier +;;; +;;; 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-cpan) + #:use-module (guix import cpan) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(define test-json + "{ + \"metadata\" : { + \"prereqs\" : { + \"configure\" : { + \"requires\" : { + \"ExtUtils::MakeMaker\" : \"0\", + \"Module::Build\" : \"0.28\" + } + }, + \"runtime\" : { + \"requires\" : { + \"Getopt::Std\" : \"0\", + \"Test::Script\" : \"1.05\", + } + } + } + \"name\" : \"Foo-Bar\", + \"version\" : \"0.1\" + } + \"name\" : \"Foo-Bar-0.1\", + \"distribution\" : \"Foo-Bar\", + \"license\" : [ + \"perl_5\" + ], + \"abstract\" : \"Fizzle Fuzz\", + \"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\", + \"author\" : \"GUIX\", + \"version\" : \"0.1\" +}") + +(define test-source + "foobar") + +(test-begin "cpan") + +(test-assert "cpan->guix-package" + ;; Replace network resources with sample data. + (mock ((guix build download) url-fetch + (lambda* (url file-name #:key (mirrors '())) + (with-output-to-file file-name + (lambda () + (display + (match url + ("http://api.metacpan.org/release/Foo-Bar" + test-json) + ("http://example.com/Foo-Bar-0.1.tar.gz" + test-source) + (_ (error "Unexpected URL: " url)))))))) + (match (cpan->guix-package "Foo::Bar") + (('package + ('name "perl-foo-bar") + ('version "0.1") + ('source ('origin + ('method 'url-fetch) + ('uri ('string-append "http://example.com/Foo-Bar-" + 'version ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'perl-build-system) + ('native-inputs + ('quasiquote + (("perl-module-build" ('unquote 'perl-module-build))))) + ('inputs + ('quasiquote + (("perl-test-script" ('unquote 'perl-test-script))))) + ('home-page "http://search.cpan.org/dist/Foo-Bar") + ('synopsis "Fizzle Fuzz") + ('description 'fill-in-yourself!) + ('license 'gpl1+)) + (string=? (bytevector->nix-base32-string + (call-with-input-string test-source port-sha256)) + hash)) + (x + (pk 'fail x #f))))) + +(test-end "cpan") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit 1.4.1 From 0b6af195fe7476a15e498b24c67f9d8f6080a400 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Jan 2015 23:33:42 +0100 Subject: derivations: Add 'derivation-output-names'. * guix/derivations.scm (derivation-output-names): New procedure. (derivation-prerequisites-to-build): Use it for #:outputs. (map-derivation): Likewise. * tests/derivations.scm ("derivation-output-names"): New test. --- guix/derivations.scm | 13 +++++++++---- tests/derivations.scm | 10 +++++++++- 2 files changed, 18 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 69cef1a4cd..5e96d9fa3c 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -58,6 +58,7 @@ derivation-input-output-paths derivation-name + derivation-output-names fixed-output-derivation? offloadable-derivation? substitutable-derivation? @@ -135,6 +136,12 @@ (let ((base (store-path-package-name (derivation-file-name drv)))) (string-drop-right base 4))) +(define (derivation-output-names drv) + "Return the names of the outputs of DRV." + (match (derivation-outputs drv) + (((names . _) ...) + names))) + (define (fixed-output-derivation? drv) "Return #t if DRV is a fixed-output derivation, such as the result of a download with a fixed hash (aka. `fetchurl')." @@ -180,9 +187,7 @@ download with a fixed hash (aka. `fetchurl')." (define* (derivation-prerequisites-to-build store drv #:key (outputs - (map - car - (derivation-outputs drv))) + (derivation-output-names drv)) (use-substitutes? #t)) "Return two values: the list of derivation-inputs required to build the OUTPUTS of DRV and not already available in STORE, recursively, and the list @@ -844,7 +849,7 @@ recursively." replacements)))) (derivation-builder-environment-vars drv)) #:inputs (append (map list sources) inputs) - #:outputs (map car (derivation-outputs drv)) + #:outputs (derivation-output-names drv) #:hash (match (derivation-outputs drv) ((($ _ algo hash)) hash) diff --git a/tests/derivations.scm b/tests/derivations.scm index 4b36758c25..25e6f75657 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -178,6 +178,14 @@ (let ((drv (derivation %store "foo-0.0" %bash '()))) (derivation-name drv))) +(test-equal "derivation-output-names" + '(("out") ("bar" "chbouib")) + (let ((drv1 (derivation %store "foo-0.0" %bash '())) + (drv2 (derivation %store "foo-0.0" %bash '() + #:outputs '("bar" "chbouib")))) + (list (derivation-output-names drv1) + (derivation-output-names drv2)))) + (test-assert "offloadable-derivation?" (and (offloadable-derivation? (derivation %store "foo" %bash '())) (not (offloadable-derivation? -- cgit 1.4.1 From e9651e39b315035eb9e87888155f8d6e33ef0567 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 Jan 2015 00:39:59 +0100 Subject: derivations: Add 'substitution-oracle' and use it. This makes 'guix environment PACKAGE' significantly faster when substitutes are enabled. Before that, it would lead to many invocations of 'guix substitute-binary', one per 'derivation-prerequisites-to-build' call. Now, all these are replaced by a single invocation. * guix/derivations.scm (derivation-output-paths, substitution-oracle): New procedures. (derivation-prerequisites-to-build): Replace #:use-substitutes? with #:substitutable?. Remove the local 'derivation-output-paths' and 'substitutable?'. * guix/ui.scm (show-what-to-build): Add 'substitutable?'. Pass it to 'derivation-prerequisites-to-build'. [built-or-substitutable?]: Use it instead of 'has-substitutes?'. * tests/derivations.scm ("derivation-prerequisites-to-build and substitutes"): Use #:substitutable? instead of #:use-substitutes?. --- guix/derivations.scm | 64 +++++++++++++++++++++++++++++++-------------------- guix/ui.scm | 16 +++++++++---- tests/derivations.scm | 3 ++- 3 files changed, 52 insertions(+), 31 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 5e96d9fa3c..ec438e833c 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -62,6 +62,7 @@ fixed-output-derivation? offloadable-derivation? substitutable-derivation? + substitution-oracle derivation-hash read-derivation @@ -184,39 +185,52 @@ download with a fixed hash (aka. `fetchurl')." ;; synonymous, see . offloadable-derivation?) +(define (derivation-output-paths drv sub-drvs) + "Return the output paths of outputs SUB-DRVS of DRV." + (match drv + (($ outputs) + (map (lambda (sub-drv) + (derivation-output-path (assoc-ref outputs sub-drv))) + sub-drvs)))) + +(define* (substitution-oracle store drv) + "Return a one-argument procedure that, when passed a store file name, +returns #t if it's substitutable and #f otherwise. The returned procedure +knows about all substitutes for all the derivations listed in DRV and their +prerequisites. + +Creating a single oracle (thus making a single 'substitutable-paths' call) and +reusing it is much more efficient than calling 'has-substitutes?' or similar +repeatedly, because it avoids the costs associated with launching the +substituter many times." + (let* ((paths (delete-duplicates + (fold (lambda (drv result) + (let ((self (match (derivation->output-paths drv) + (((names . paths) ...) + paths))) + (deps (append-map derivation-input-output-paths + (derivation-prerequisites + drv)))) + (append self deps result))) + '() + drv))) + (subst (substitutable-paths store paths))) + (cut member <> subst))) + (define* (derivation-prerequisites-to-build store drv #:key (outputs (derivation-output-names drv)) - (use-substitutes? #t)) + (substitutable? + (substitution-oracle store + (list drv)))) "Return two values: the list of derivation-inputs required to build the OUTPUTS of DRV and not already available in STORE, recursively, and the list -of required store paths that can be substituted. When USE-SUBSTITUTES? is #f, -that second value is the empty list." - (define (derivation-output-paths drv sub-drvs) - (match drv - (($ outputs) - (map (lambda (sub-drv) - (derivation-output-path (assoc-ref outputs sub-drv))) - sub-drvs)))) - +of required store paths that can be substituted. SUBSTITUTABLE? must be a +one-argument procedure similar to that returned by 'substitution-oracle'." (define built? (cut valid-path? store <>)) - (define substitutable? - ;; Return true if the given path is substitutable. Call - ;; `substitutable-paths' upfront, to benefit from parallelism in the - ;; substituter. - (if use-substitutes? - (let ((s (substitutable-paths store - (append - (derivation-output-paths drv outputs) - (append-map - derivation-input-output-paths - (derivation-prerequisites drv)))))) - (cut member <> s)) - (const #f))) - (define input-built? (compose (cut any built? <>) derivation-input-output-paths)) diff --git a/guix/ui.scm b/guix/ui.scm index c77e04172e..5bd4d1f8c2 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Alex Kost @@ -299,21 +299,27 @@ error." derivations listed in DRV. Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are available for download." + (define substitutable? + ;; Call 'substitutation-oracle' upfront so we don't end up launching the + ;; substituter many times. This makes a big difference, especially when + ;; DRV is a long list as is the case with 'guix environment'. + (if use-substitutes? + (substitution-oracle store drv) + (const #f))) + (define (built-or-substitutable? drv) (let ((out (derivation->output-path drv))) ;; If DRV has zero outputs, OUT is #f. (or (not out) (or (valid-path? store out) - (and use-substitutes? - (has-substitutes? store out)))))) + (substitutable? out))))) (let*-values (((build download) (fold2 (lambda (drv build download) (let-values (((b d) (derivation-prerequisites-to-build store drv - #:use-substitutes? - use-substitutes?))) + #:substitutable? substitutable?))) (values (append b build) (append d download)))) '() '() diff --git a/tests/derivations.scm b/tests/derivations.scm index 25e6f75657..8e592ab6a1 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -589,7 +589,8 @@ (derivation-prerequisites-to-build store drv)) ((build* download*) (derivation-prerequisites-to-build store drv - #:use-substitutes? #f))) + #:substitutable? + (const #f)))) (and (null? build) (equal? download (list output)) (null? download*) -- cgit 1.4.1