From 891a843d5184f696618af6fcbb9791ef6b574504 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Wed, 28 Sep 2016 11:36:35 +0200 Subject: guix: Add lint-checker for packages which should be no inputs at all. Also refactor some common code into a new function. Examples for these pacakges are python(2)-setuptools and python(2)-pip, which are installed together with python itself. * guix/scripts/lint.scm (warn-if-package-has-input): New procedure. (check-inputs-should-be-native package): Use it; rename and clean-up variables. (check-inputs-should-not-be-an-input-at-all): New procedure. (%checkers) Add it. * doc/guix.texi (Python Modules): Document it. * tests/lint.scm: ("inputs: python-setuptools should not be an input at all (input)", "inputs: python-setuptools should not be an input at all (native-input)" "inputs: python-setuptools should not be an input at all (propagated-input)"): Add tests. --- tests/lint.scm | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) (limited to 'tests') diff --git a/tests/lint.scm b/tests/lint.scm index fa2d19b2a6..b66cd29312 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014, 2015, 2016 Eric Bavier ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2016 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +34,7 @@ #:use-module (gnu packages) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages python) #:use-module (web server) #:use-module (web server http) #:use-module (web response) @@ -354,6 +356,38 @@ string) on HTTP requests." (check-inputs-should-be-native pkg))) "'glib:bin' should probably be a native input"))) +(test-assert + "inputs: python-setuptools should not be an input at all (input)" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (inputs `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg))) + "'python-setuptools' should probably not be an input at all"))) + +(test-assert + "inputs: python-setuptools should not be an input at all (native-input)" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (native-inputs + `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg))) + "'python-setuptools' should probably not be an input at all"))) + +(test-assert + "inputs: python-setuptools should not be an input at all (propagated-input)" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (propagated-inputs + `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg))) + "'python-setuptools' should probably not be an input at all"))) + (test-assert "patches: file names" (->bool (string-contains -- cgit v1.2.3 From 13d5e8dae5f1282eac630dea428c5fe3dc073fb4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Dec 2016 14:03:33 +0100 Subject: store: 'open-connection' no longer raises '&nar-error' for protocol errors. * guix/store.scm (open-connection): Guard body against 'nar-error?' and re-raise as '&nix-connection-error'. * tests/store.scm ("connection handshake error"): New test. --- guix/store.scm | 53 ++++++++++++++++++++++++++++++----------------------- tests/store.scm | 9 +++++++++ 2 files changed, 39 insertions(+), 23 deletions(-) (limited to 'tests') diff --git a/guix/store.scm b/guix/store.scm index a669011f3a..49549d0771 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -374,29 +374,36 @@ space on the file system so that the garbage collector can still operate, should the disk become full. When CPU-AFFINITY is true, it must be an integer corresponding to an OS-level CPU number to which the daemon's worker process for this connection will be pinned. Return a server object." - (let ((port (or port (open-unix-domain-socket file)))) - (write-int %worker-magic-1 port) - (let ((r (read-int port))) - (and (eqv? r %worker-magic-2) - (let ((v (read-int port))) - (and (eqv? (protocol-major %protocol-version) - (protocol-major v)) - (begin - (write-int %protocol-version port) - (when (>= (protocol-minor v) 14) - (write-int (if cpu-affinity 1 0) port) - (when cpu-affinity - (write-int cpu-affinity port))) - (when (>= (protocol-minor v) 11) - (write-int (if reserve-space? 1 0) port)) - (let ((conn (%make-nix-server port - (protocol-major v) - (protocol-minor v) - (make-hash-table 100) - (make-hash-table 100)))) - (let loop ((done? (process-stderr conn))) - (or done? (process-stderr conn))) - conn)))))))) + (guard (c ((nar-error? c) + ;; One of the 'write-' or 'read-' calls below failed, but this is + ;; really a connection error. + (raise (condition + (&nix-connection-error (file (or port file)) + (errno EPROTO)) + (&message (message "build daemon handshake failed")))))) + (let ((port (or port (open-unix-domain-socket file)))) + (write-int %worker-magic-1 port) + (let ((r (read-int port))) + (and (eqv? r %worker-magic-2) + (let ((v (read-int port))) + (and (eqv? (protocol-major %protocol-version) + (protocol-major v)) + (begin + (write-int %protocol-version port) + (when (>= (protocol-minor v) 14) + (write-int (if cpu-affinity 1 0) port) + (when cpu-affinity + (write-int cpu-affinity port))) + (when (>= (protocol-minor v) 11) + (write-int (if reserve-space? 1 0) port)) + (let ((conn (%make-nix-server port + (protocol-major v) + (protocol-minor v) + (make-hash-table 100) + (make-hash-table 100)))) + (let loop ((done? (process-stderr conn))) + (or done? (process-stderr conn))) + conn))))))))) (define (close-connection server) "Close the connection to SERVER." diff --git a/tests/store.scm b/tests/store.scm index 38b8efce96..123ea8a787 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -48,6 +48,15 @@ (test-begin "store") +(test-equal "connection handshake error" + EPROTO + (let ((port (%make-void-port "rw"))) + (guard (c ((nix-connection-error? c) + (and (eq? port (nix-connection-error-file c)) + (nix-connection-error-code c)))) + (open-connection #f #:port port) + 'broken))) + (test-equal "store-path-hash-part" "283gqy39v3g9dxjy26rynl0zls82fmcg" (store-path-hash-part -- cgit v1.2.3 From 3e0c036584b41bcc08a8c8e040295716108bb0b2 Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:40:58 +0200 Subject: import: Add importer for rust crates. * guix/import/crate.scm: New file. * guix/scripts/import/crate.scm: New file. * guix/scripts/import.scm (importers): Add crate importer. * tests/crate.scm: New file. * doc/guix.texi: Add crate importer to table. * Makefile.am (MODULES, SCM_TESTS): Add files. --- Makefile.am | 5 +- doc/guix.texi | 5 ++ guix/import/crate.scm | 125 ++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/crate.scm | 94 +++++++++++++++++++++++++++++++ guix/scripts/refresh.scm | 1 + tests/crate.scm | 102 ++++++++++++++++++++++++++++++++++ 7 files changed, 332 insertions(+), 2 deletions(-) create mode 100644 guix/import/crate.scm create mode 100644 guix/scripts/import/crate.scm create mode 100644 tests/crate.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 5cb4261f4b..84ff6642a2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -122,6 +122,7 @@ MODULES = \ guix/import/snix.scm \ guix/import/cabal.scm \ guix/import/cran.scm \ + guix/import/crate.scm \ guix/import/hackage.scm \ guix/import/elpa.scm \ guix/scripts.scm \ @@ -141,6 +142,7 @@ MODULES = \ guix/scripts/lint.scm \ guix/scripts/challenge.scm \ guix/scripts/import/cran.scm \ + guix/scripts/import/crate.scm \ guix/scripts/import/gnu.scm \ guix/scripts/import/nix.scm \ guix/scripts/import/hackage.scm \ @@ -282,7 +284,8 @@ if HAVE_GUILE_JSON SCM_TESTS += \ tests/pypi.scm \ tests/cpan.scm \ - tests/gem.scm + tests/gem.scm \ + tests/crate.scm endif diff --git a/doc/guix.texi b/doc/guix.texi index f1c5963f76..5db20ecdfa 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5267,6 +5267,11 @@ signatures,, emacs, The GNU Emacs Manual}). identifier. @end itemize @end table + +@item crate +@cindex crate +Import metadata from the crates.io Rust package repository +@uref{https://crates.io, crates.io}. @end table The structure of the @command{guix import} code is modular. It would be diff --git a/guix/import/crate.scm b/guix/import/crate.scm new file mode 100644 index 0000000000..e78e3ad9ca --- /dev/null +++ b/guix/import/crate.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven +;;; +;;; 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 crate) + #:use-module (guix base32) + #:use-module (guix build-system cargo) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix hash) + #:use-module (guix http-client) + #:use-module (guix import json) + #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) ; recursive + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:export (crate->guix-package + guix-package->crate-name)) + +(define (crate-fetch crate-name callback) + "Fetch the metadata for CRATE-NAME from crates.io and call the callback." + + (define (crates->inputs crates) + (sort (map (cut assoc-ref <> "crate_id") crates) string-cilicense string) + (map spdx-string->license (string-split string #\/))) + + (define (crate-kind-predicate kind) + (lambda (dep) (string=? (assoc-ref dep "kind") kind))) + + (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) + (crate (assoc-ref crate-json "crate")) + (name (assoc-ref crate "name")) + (version (assoc-ref crate "max_version")) + (home-page (assoc-ref crate "homepage")) + (synopsis (assoc-ref crate "description")) + (description (assoc-ref crate "description")) + (license (string->license (assoc-ref crate "license"))) + (path (string-append "/" version "/dependencies")) + (deps-json (json-fetch (string-append crate-url name path))) + (deps (assoc-ref deps-json "dependencies")) + (input-crates (filter (crate-kind-predicate "normal") deps)) + (native-input-crates + (filter (lambda (dep) + (not ((crate-kind-predicate "normal") dep))) deps)) + (inputs (crates->inputs input-crates)) + (native-inputs (crates->inputs native-input-crates))) + (callback #:name name #:version version + #:inputs inputs #:native-inputs native-inputs + #:home-page home-page #:synopsis synopsis + #:description description #:license license))) + +(define* (make-crate-sexp #:key name version inputs native-inputs + home-page synopsis description license + #:allow-other-keys) + "Return the `package' s-expression for a rust package with the given NAME, +VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + (let* ((port (http-fetch (crate-uri name version))) + (guix-name (crate-name->package-name name)) + (inputs (map crate-name->package-name inputs)) + (native-inputs (map crate-name->package-name native-inputs)) + (pkg `(package + (name ,guix-name) + (version ,version) + (source (origin + (method url-fetch) + (uri (crate-uri ,name version)) + (file-name (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + ,(bytevector->nix-base32-string (port-sha256 port)))))) + (build-system cargo-build-system) + ,@(maybe-native-inputs native-inputs) + ,@(maybe-inputs inputs) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,(beautify-description description)) + (license ,(match license + (() #f) + ((license) license) + (_ `(list ,@license))))))) + (close-port port) + pkg)) + +(define (crate->guix-package crate-name) + "Fetch the metadata for CRATE-NAME from crates.io, and return the +`package' s-expression corresponding to that package, or #f on failure." + (crate-fetch crate-name make-crate-sexp)) + +(define (guix-package->crate-name package) + "Return the crate name of PACKAGE." + (and-let* ((origin (package-source package)) + (uri (origin-uri origin)) + (crate-url? uri) + (len (string-length crate-url)) + (path (xsubstring uri len)) + (parts (string-split path #\/))) + (match parts + ((name _ ...) name)))) + +(define (crate-name->package-name name) + (string-append "rust-" (string-join (string-split name #\_) "-"))) + diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index e54744feca..c671686043 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" "cpan" "hackage" "elpa" "gem" "cran")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran" "crate")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm new file mode 100644 index 0000000000..4337a0b623 --- /dev/null +++ b/guix/scripts/import/crate.scm @@ -0,0 +1,94 @@ + +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2016 David Craven +;;; +;;; 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 crate) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import crate) + #: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-crate)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import crate PACKAGE-NAME +Import and convert the crate.io 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 crate"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-crate . 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 (crate->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/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index f8fb3f80ca..72f51cbff8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -39,6 +39,7 @@ %kernel.org-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) + #:use-module (guix import crate) #:use-module (guix import hackage) #:use-module (guix gnupg) #:use-module (gnu packages) diff --git a/tests/crate.scm b/tests/crate.scm new file mode 100644 index 0000000000..18d5f72a8c --- /dev/null +++ b/tests/crate.scm @@ -0,0 +1,102 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2016 David Craven +;;; +;;; 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-crate) + #:use-module (guix import crate) + #:use-module (guix base32) + #:use-module (guix build-system cargo) + #:use-module (guix hash) + #:use-module (guix tests) + #:use-module (ice-9 iconv) + #:use-module (ice-9 match) + #:use-module (srfi srfi-64)) + +(define test-crate + "{ + \"crate\": { + \"max_version\": \"1.0.0\", + \"name\": \"foo\", + \"license\": \"MIT/Apache-2.0\", + \"description\": \"summary\", + \"homepage\": \"http://example.com\", + } +}") + +(define test-dependencies + "{ + \"dependencies\": [ + { + \"crate_id\": \"bar\", + \"kind\": \"normal\", + } + ] +}") + +(define test-source-hash + "") + +(test-begin "crate") + +(test-equal "guix-package->crate-name" + "rustc-serialize" + (guix-package->crate-name + (dummy-package + "rust-rustc-serialize" + (source (dummy-origin + (uri (crate-uri "rustc-serialize" "1.0"))))))) + +(test-assert "crate->guix-package" + ;; Replace network resources with sample data. + (mock ((guix http-client) http-fetch + (lambda (url) + (match url + ("https://crates.io/api/v1/crates/foo" + (open-input-string test-crate)) + ("https://crates.io/api/v1/crates/foo/1.0.0/download" + (set! test-source-hash + (bytevector->nix-base32-string + (sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/foo/1.0.0/dependencies" + (open-input-string test-dependencies)) + (_ (error "Unexpected URL: " url))))) + (match (crate->guix-package "foo") + (('package + ('name "rust-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri ('crate-uri "foo" 'version)) + ('file-name ('string-append 'name "-" 'version ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'cargo-build-system) + ('inputs + ('quasiquote + (("rust-bar" ('unquote 'rust-bar))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license ('list 'license:expat 'license:asl2.0))) + (string=? test-source-hash hash)) + (x + (pk 'fail x #f))))) + +(test-end "crate") -- cgit v1.2.3 From 51377437a1e37c9d5f2e137528e9c278b252d781 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 20 Oct 2016 08:47:03 +0200 Subject: graph: Backend must have name and description. * guix/graph.scm (): Add fields "name" and "description". (%graphviz-backend): Provide values for name and description. (export-graph): Ignore name and description when matching backends. (graph-backend-name, graph-backend-description): New procedures. * tests/graph.scm (make-recording-backend): Initialize name and description fields of test graph-backend. --- guix/graph.scm | 20 +++++++++++++------- tests/graph.scm | 3 ++- 2 files changed, 15 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/guix/graph.scm b/guix/graph.scm index 735d340c2c..5cf98f0d54 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -44,6 +44,8 @@ %graphviz-backend graph-backend? graph-backend + graph-backend-name + graph-backend-description export-graph)) @@ -140,12 +142,14 @@ typically returned by 'node-edges' or 'node-back-edges'." ;;; (define-record-type - (graph-backend prologue epilogue node edge) + (graph-backend name description prologue epilogue node edge) graph-backend? - (prologue graph-backend-prologue) - (epilogue graph-backend-epilogue) - (node graph-backend-node) - (edge graph-backend-edge)) + (name graph-backend-name) + (description graph-backend-description) + (prologue graph-backend-prologue) + (epilogue graph-backend-epilogue) + (node graph-backend-node) + (edge graph-backend-edge)) (define %colors ;; See colortbl.h in Graphviz. @@ -170,7 +174,9 @@ typically returned by 'node-edges' or 'node-back-edges'." id1 id2 (pop-color id1))) (define %graphviz-backend - (graph-backend emit-prologue emit-epilogue + (graph-backend "graphviz" + "Generate graph in DOT format for use with Graphviz." + emit-prologue emit-epilogue emit-node emit-edge)) (define* (export-graph sinks port @@ -181,7 +187,7 @@ typically returned by 'node-edges' or 'node-back-edges'." given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is true, draw reverse arrows." (match backend - (($ emit-prologue emit-epilogue emit-node emit-edge) + (($ _ _ emit-prologue emit-epilogue emit-node emit-edge) (emit-prologue (node-type-name node-type) port) (match node-type diff --git a/tests/graph.scm b/tests/graph.scm index f2e441cee6..bc4d62fe50 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -57,7 +57,8 @@ edges." (define (return) (values (reverse nodes) (reverse edges))) - (values (graph-backend (const #t) (const #t) + (values (graph-backend "test" "This is the test backend." + (const #t) (const #t) record-node record-edge) return))) -- cgit v1.2.3 From a6562c7e206650ff3d8e6764e60c59a768414bf7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 Dec 2016 12:43:10 +0100 Subject: profiles: Remove dependency on 'glibc-utf8-locales' for tests. Commit 1af0860e8be81c01ad405c1226d6bc4516e62863 added a mandatory dependency on 'glibc-utf8-locales', which entails long rebuilds for tests. * guix/profiles.scm (profile-derivation): Add #:locales? parameter. Add 'set-utf8-locale' variable. Use it when LOCALES? is true. (link-to-empty-profile): Pass #:locales? #f. * guix/scripts/environment.scm (inputs->profile-derivation): Pass #:locales?. * guix/scripts/package.scm (build-and-use-profile): Likewise. * tests/packages.scm ("--search-paths with pattern"): Pass #:locales? #f. * tests/profiles.scm ("profile-derivation") ("profile-derivation, inputs", "profile-manifest, search-paths") ("etc/profile", "etc/profile when etc/ already exists"): ("etc/profile when etc/ is a symlink"): Likewise. --- guix/profiles.scm | 25 +++++++++++++++++-------- guix/scripts/environment.scm | 3 ++- guix/scripts/package.scm | 3 ++- tests/packages.scm | 3 ++- tests/profiles.scm | 18 ++++++++++++------ 5 files changed, 35 insertions(+), 17 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index 82d8b33c09..e7707b6543 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -919,10 +919,14 @@ files for the truetype fonts of the @var{manifest} entries." (define* (profile-derivation manifest #:key (hooks %default-profile-hooks) + (locales? #t) system) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by -the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." +the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc. + +When LOCALES? is true, the build is performed under a UTF-8 locale; this adds +a dependency on the 'glibc-utf8-locales' package." (mlet %store-monad ((system (if system (return system) (current-system))) @@ -943,6 +947,15 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) + (define set-utf8-locale + ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so + ;; install a UTF-8 locale. + #~(begin + (setenv "LOCPATH" + #$(file-append glibc-utf8-locales "/lib/locale/" + (package-version glibc-utf8-locales))) + (setlocale LC_ALL "en_US.utf8"))) + (define builder (with-imported-modules '((guix build profiles) (guix build union) @@ -957,12 +970,7 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) - ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so - ;; install a UTF-8 locale. - (setenv "LOCPATH" - (string-append #+glibc-utf8-locales "/lib/locale/" - #+(package-version glibc-utf8-locales))) - (setlocale LC_ALL "en_US.utf8") + #+(if locales? set-utf8-locale #t) (define search-paths ;; Search paths of MANIFEST's packages, converted back to their @@ -1110,7 +1118,8 @@ case when generations have been deleted (there are \"holes\")." "Link GENERATION, a string, to the empty profile. An error is raised if that fails." (let* ((drv (run-with-store store - (profile-derivation (manifest '())))) + (profile-derivation (manifest '()) + #:locales? #f))) (prof (derivation->output-path drv "out"))) (build-derivations store (list drv)) (switch-symlinks generation prof))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6dea67ca22..7201d98fea 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -323,7 +323,8 @@ profile." #:system system #:hooks (if bootstrap? '() - %default-profile-hooks))) + %default-profile-hooks) + #:locales? (not bootstrap?))) (define requisites* (store-lift requisites)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 96a22f6fab..90e7fa2298 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -200,7 +200,8 @@ specified in MANIFEST, a manifest object." (profile-derivation manifest #:hooks (if bootstrap? '() - %default-profile-hooks)))) + %default-profile-hooks) + #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) #:use-substitutes? use-substitutes? diff --git a/tests/packages.scm b/tests/packages.scm index 47e76b53e9..247f75cc43 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -968,7 +968,8 @@ (profile-derivation (manifest (map package->manifest-entry (list p1 p2))) - #:hooks '()) + #:hooks '() + #:locales? #f) #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof)) (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n" diff --git a/tests/profiles.scm b/tests/profiles.scm index f9c2f5499e..5536364889 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -195,7 +195,8 @@ ((entry -> (package->manifest-entry %bootstrap-guile)) (guile (package->derivation %bootstrap-guile)) (drv (profile-derivation (manifest (list entry)) - #:hooks '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv)) (bindir -> (string-append profile "/bin")) (_ (built-derivations (list drv)))) @@ -207,7 +208,8 @@ (mlet* %store-monad ((entry -> (package->manifest-entry packages:glibc "debug")) (drv (profile-derivation (manifest (list entry)) - #:hooks '()))) + #:hooks '() + #:locales? #f))) (return (derivation-inputs drv)))) (test-assert "package->manifest-entry defaults to \"out\"" @@ -228,7 +230,8 @@ (package-native-search-paths packages:guile-2.0)))) (entry -> (package->manifest-entry guile)) (drv (profile-derivation (manifest (list entry)) - #:hooks '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) @@ -259,7 +262,8 @@ (package-native-search-paths packages:guile-2.0)))) (entry -> (package->manifest-entry guile)) (drv (profile-derivation (manifest (list entry)) - #:hooks '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) @@ -293,7 +297,8 @@ (display "foo!" port)))))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) - #:hooks '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) @@ -321,7 +326,8 @@ (display "foo!" port)))))))) (entry -> (package->manifest-entry thing)) (drv (profile-derivation (manifest (list entry)) - #:hooks '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) -- cgit v1.2.3 From 506abddb99e02f824bff7ed7d7f7b37c4dafe0a7 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 18 Dec 2016 09:55:17 +0100 Subject: tests: Mock up http-fetch in import tests. This is a follow-up to commit 63773200d7ac68fcaee6efd9ffe8ea7aa3fafa38. * tests/gem.scm ("gem->guix-package"): Replace mock definition of "url-fetch" with "http-fetch". * tests/pypi.scm ("pypi->guix-package"): Add mock definition of "http-fetch". --- tests/gem.scm | 10 +++---- tests/pypi.scm | 95 ++++++++++++++++++++++++++++++---------------------------- 2 files changed, 55 insertions(+), 50 deletions(-) (limited to 'tests') diff --git a/tests/gem.scm b/tests/gem.scm index a46c2b1439..669cd8ee60 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson +;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,13 +46,12 @@ (test-assert "gem->guix-package" ;; Replace network resources with sample data. - (mock ((guix import utils) url-fetch - (lambda (url file-name) + (mock ((guix http-client) http-fetch + (lambda (url) (match url ("https://rubygems.org/api/v1/gems/foo.json" - (with-output-to-file file-name - (lambda () - (display test-json)))) + (values (open-input-string test-json) + (string-length test-json))) (_ (error "Unexpected URL: " url))))) (match (gem->guix-package "foo") (('package diff --git a/tests/pypi.scm b/tests/pypi.scm index 9d2fcc7391..1f7ac2500a 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson +;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -91,51 +92,55 @@ baz > 13.37") (test-assert "pypi->guix-package" ;; Replace network resources with sample data. - (mock ((guix import utils) url-fetch - (lambda (url file-name) - (match url - ("https://pypi.python.org/pypi/foo/json" - (with-output-to-file file-name - (lambda () - (display test-json)))) - ("https://example.com/foo-1.0.0.tar.gz" - (begin - (mkdir "foo-1.0.0") - (with-output-to-file "foo-1.0.0/requirements.txt" - (lambda () - (display test-requirements))) - (system* "tar" "czvf" file-name "foo-1.0.0/") - (delete-file-recursively "foo-1.0.0") - (set! test-source-hash - (call-with-input-file file-name port-sha256)))) - ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) - (_ (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) - ('propagated-inputs - ('quasiquote - (("python-bar" ('unquote 'python-bar)) - ("python-baz" ('unquote 'python-baz)) - ("python-setuptools" ('unquote 'python-setuptools))))) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license 'license:lgpl2.0)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f))))) + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://example.com/foo-1.0.0.tar.gz" + (begin + (mkdir "foo-1.0.0") + (with-output-to-file "foo-1.0.0/requirements.txt" + (lambda () + (display test-requirements))) + (system* "tar" "czvf" file-name "foo-1.0.0/") + (delete-file-recursively "foo-1.0.0") + (set! test-source-hash + (call-with-input-file file-name port-sha256)))) + ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) + (_ (error "Unexpected URL: " url))))) + (mock ((guix http-client) http-fetch + (lambda (url) + (match url + ("https://pypi.python.org/pypi/foo/json" + (values (open-input-string test-json) + (string-length test-json))) + ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) + (_ (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) + ('propagated-inputs + ('quasiquote + (("python-bar" ('unquote 'python-bar)) + ("python-baz" ('unquote 'python-baz)) + ("python-setuptools" ('unquote 'python-setuptools))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license 'license:lgpl2.0)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) (test-skip (if (which "zip") 0 1)) (test-assert "pypi->guix-package, wheels" -- cgit v1.2.3 From 239f46325d554978cfc2d9dc63f1943527bfd360 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 18 Dec 2016 10:53:27 +0100 Subject: tests: Mock up http-fetch in import test. This is a follow-up to commit 63773200d7ac68fcaee6efd9ffe8ea7aa3fafa38. * tests/pypi.scm ("pypi->guix-package, wheels"): Add mock definition of "http-fetch". --- tests/pypi.scm | 64 +++++++++++++++++++++++++++++++--------------------------- 1 file changed, 34 insertions(+), 30 deletions(-) (limited to 'tests') diff --git a/tests/pypi.scm b/tests/pypi.scm index 1f7ac2500a..f26e7fea13 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -148,10 +148,6 @@ baz > 13.37") (mock ((guix import utils) url-fetch (lambda (url file-name) (match url - ("https://pypi.python.org/pypi/foo/json" - (with-output-to-file file-name - (lambda () - (display test-json)))) ("https://example.com/foo-1.0.0.tar.gz" (begin (mkdir "foo-1.0.0") @@ -175,31 +171,39 @@ baz > 13.37") (rename-file zip-file file-name)) (delete-file-recursively "foo-1.0.0.dist-info"))) (_ (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) - ('propagated-inputs - ('quasiquote - (("python-bar" ('unquote 'python-bar)) - ("python-baz" ('unquote 'python-baz)) - ("python-setuptools" ('unquote 'python-setuptools))))) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license 'license:lgpl2.0)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f))))) + (mock ((guix http-client) http-fetch + (lambda (url) + (match url + ("https://pypi.python.org/pypi/foo/json" + (values (open-input-string test-json) + (string-length test-json))) + ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) + (_ (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) + ('propagated-inputs + ('quasiquote + (("python-bar" ('unquote 'python-bar)) + ("python-baz" ('unquote 'python-baz)) + ("python-setuptools" ('unquote 'python-setuptools))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license 'license:lgpl2.0)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) (test-end "pypi") -- cgit v1.2.3 From e69c1a544606d6870eef959c3cda17fe6bdce875 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 18 Dec 2016 13:35:21 +0100 Subject: tests: Adjust cpan tests. This is a follow-up to commit ff55fe559951b88bfd691b9dada3a0f26002c4cb. * tests/cpan.scm (source-url-http, source-url-https): Use cpan-source-url. --- tests/cpan.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/tests/cpan.scm b/tests/cpan.scm index e37fc437fc..56effc7201 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -101,13 +101,15 @@ (pk 'fail x #f))))) (test-equal "source-url-http" - ((@@ (guix import cpan) fix-source-url) - "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + ((@@ (guix import cpan) cpan-source-url) + `(("download_url" . + "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") (test-equal "source-url-https" - ((@@ (guix import cpan) fix-source-url) - "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + ((@@ (guix import cpan) cpan-source-url) + `(("download_url" . + "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") (test-end "cpan") -- cgit v1.2.3 From 662a1aa6b049d29977cfc376d4a185a3e8be4a07 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 18 Dec 2016 13:38:01 +0100 Subject: tests: Mock up http-fetch. This is a follow-up to commit 63773200d7ac68fcaee6efd9ffe8ea7aa3fafa38. * tests/cpan.scm ("cpan->guix-package"): Add mock definition of http-fetch. --- tests/cpan.scm | 63 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 35 insertions(+), 28 deletions(-) (limited to 'tests') diff --git a/tests/cpan.scm b/tests/cpan.scm index 56effc7201..0c28a74d3e 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -68,37 +68,44 @@ (lambda () (display (match url - ("https://api.metacpan.org/release/Foo-Bar" - test-json) - ("https://api.metacpan.org/module/Test::Script" - "{ \"distribution\" : \"Test-Script\" }") ("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) - ('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 (package-license perl))) - (string=? (bytevector->nix-base32-string - (call-with-input-string test-source port-sha256)) - hash)) - (x - (pk 'fail x #f))))) + (mock ((guix http-client) http-fetch + (lambda (url) + (match url + ("https://api.metacpan.org/release/Foo-Bar" + (values (open-input-string test-json) + (string-length test-json))) + ("https://api.metacpan.org/module/Test::Script?fields=distribution" + (let ((result "{ \"distribution\" : \"Test-Script\" }")) + (values (open-input-string result) + (string-length result)))) + (_ (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) + ('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 (package-license perl))) + (string=? (bytevector->nix-base32-string + (call-with-input-string test-source port-sha256)) + hash)) + (x + (pk 'fail x #f)))))) (test-equal "source-url-http" ((@@ (guix import cpan) cpan-source-url) -- cgit v1.2.3 From 5b14a7902c58d9fb7923f9e16871f549fbe59b6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Dec 2016 17:06:12 +0100 Subject: gexp: Native inputs of nested gexps are properly accounted for. Previously, 'gexp-native-inputs' would not return the native inputs of nested gexps. For example, this: (gexp-native-inputs #~(foo #$#~(bar #+coreutils))) would return '(). * guix/gexp.scm (gexp-inputs)[add-reference-inputs]: In the non-recursive cases, check whether N? and NATIVE? are the same, and act accordingly. [native-input?]: Remove. Fold over all of (gexp-references exp). * tests/gexp.scm ("ungexp + ungexp-native, nested, special mixture"): New test. * tests/gexp.scm ("input list splicing + ungexp-native-splicing"): Pass #:native? #t to 'gexp-input'. --- guix/gexp.scm | 28 ++++++++++++---------------- tests/gexp.scm | 11 ++++++++++- 2 files changed, 22 insertions(+), 17 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index fd5dc49233..5021688ac7 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -678,32 +678,28 @@ references; otherwise, return only non-native references." (if (direct-store-path? str) (cons `(,str) result) result)) - (($ (? struct? thing) output) - (if (lookup-compiler thing) + (($ (? struct? thing) output n?) + (if (and (eqv? n? native?) (lookup-compiler thing)) ;; THING is a derivation, or a package, or an origin, etc. (cons `(,thing ,output) result) result)) (($ (lst ...) output n?) - (fold-right add-reference-inputs result - ;; XXX: For now, automatically convert LST to a list of - ;; gexp-inputs. - (map (match-lambda - ((? gexp-input? x) x) - (x (%gexp-input x "out" (or n? native?)))) - lst))) + (if (eqv? native? n?) + (fold-right add-reference-inputs result + ;; XXX: For now, automatically convert LST to a list of + ;; gexp-inputs. + (map (match-lambda + ((? gexp-input? x) x) + (x (%gexp-input x "out" (or n? native?)))) + lst)) + result)) (_ ;; Ignore references to other kinds of objects. result))) - (define (native-input? x) - (and (gexp-input? x) - (gexp-input-native? x))) - (fold-right add-reference-inputs '() - (if native? - (filter native-input? (gexp-references exp)) - (remove native-input? (gexp-references exp))))) + (gexp-references exp))) (define gexp-native-inputs (cut gexp-inputs <> #:native? #t)) diff --git a/tests/gexp.scm b/tests/gexp.scm index 354d28f014..797d5fa457 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -277,6 +277,14 @@ (ungexp %bootstrap-guile))))) (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) +(test-equal "ungexp + ungexp-native, nested, special mixture" + `(() <> ((,coreutils "out"))) + + ;; (gexp-native-inputs exp) used to return '(), wrongfully. + (let* ((foo (gexp (foo (ungexp-native coreutils)))) + (exp (gexp (bar (ungexp foo))))) + (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) + (test-assert "input list" (let ((exp (gexp (display '(ungexp (list %bootstrap-guile coreutils))))) @@ -327,7 +335,8 @@ `(list ,@(cons 5 outputs)))))) (test-assert "input list splicing + ungexp-native-splicing" - (let* ((inputs (list (gexp-input glibc "debug") %bootstrap-guile)) + (let* ((inputs (list (gexp-input glibc "debug" #:native? #t) + %bootstrap-guile)) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? `((,glibc "debug") (,%bootstrap-guile "out")) -- cgit v1.2.3 From f943c317fb714075b455d4a30f631c8cb45732b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 Dec 2016 19:06:22 +0100 Subject: environment: Add '--root' option. * guix/scripts/environment.scm (show-help, %options): Add --root. (register-gc-root): New procedure. (guix-environment): Call 'register-gc-root' when OPTS has a 'gc-root' option. * doc/guix.texi (Invoking guix environment): Document it. * tests/guix-environment.sh: Add tests. --- doc/guix.texi | 15 +++++++++++++++ guix/scripts/environment.scm | 34 ++++++++++++++++++++++++++++++++-- tests/guix-environment.sh | 17 ++++++++++++++++- 3 files changed, 63 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 512b3ae9ce..69129d5835 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5997,6 +5997,21 @@ The @code{--container} option requires Linux-libre 3.19 or newer. The available options are summarized below. @table @code +@item --root=@var{file} +@itemx -r @var{file} +@cindex persistent environment +@cindex garbage collector root, for environments +Make @var{file} a symlink to the profile for this environment, and +register it as a garbage collector root. + +This is useful if you want to protect your environment from garbage +collection, to make it ``persistent''. + +When this option is omitted, the environment is protected from garbage +collection only for the duration of the @command{guix environment} +session. This means that next time you recreate the same environment, +you could have to rebuild or re-download packages. + @item --expression=@var{expr} @itemx -e @var{expr} Create an environment for the package or list of packages that diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 7201d98fea..1d3be6a84f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -155,6 +155,9 @@ COMMAND or an interactive shell in that environment.\n")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " -C, --container run command within an isolated container")) (display (_ " -N, --network allow containers to access the network")) @@ -247,6 +250,9 @@ COMMAND or an interactive shell in that environment.\n")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -523,7 +529,26 @@ message if any test fails." (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) (leave (_ "is your kernel version < 3.19?\n")))) -;; Entry point. +(define (register-gc-root target root) + "Make ROOT an indirect root to TARGET. This is procedure is idempotent." + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (symlink target root) + ((store-lift add-indirect-root) root)) + (lambda args + (if (and (= EEXIST (system-error-errno args)) + (equal? (false-if-exception (readlink root)) target)) + (with-monad %store-monad + (return #t)) + (apply throw args)))))) + + +;;; +;;; Entry point. +;;; + (define (guix-environment . args) (with-error-handling (let* ((opts (parse-args args)) @@ -579,7 +604,9 @@ message if any test fails." system)) (prof-drv (inputs->profile-derivation inputs system bootstrap?)) - (profile -> (derivation->output-path prof-drv))) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + ;; First build the inputs. This is necessary even for ;; --search-paths. Additionally, we might need to build bash for ;; a container. @@ -588,6 +615,9 @@ message if any test fails." (list prof-drv bash) (list prof-drv)) opts) + (mwhen gc-root + (register-gc-root profile gc-root)) + (cond ((assoc-ref opts 'dry-run?) (return #t)) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 68343520b0..2b3bbfe036 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -25,7 +25,8 @@ set -e guix environment --version tmpdir="t-guix-environment-$$" -trap 'rm -r "$tmpdir"' EXIT +gcroot="t-guix-environment-gc-root-$$" +trap 'rm -r "$tmpdir"; rm -f "$gcroot"' EXIT mkdir "$tmpdir" @@ -61,6 +62,20 @@ fi guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ -- "$SHELL" -c 'test -f "$GUIX_ENVIRONMENT/bin/guile"' +# Make sure '-r' works as expected. +rm -f "$gcroot" +expected="`guix environment --bootstrap --ad-hoc guile-bootstrap \ + -- "$SHELL" -c 'echo $GUIX_ENVIRONMENT'`" +guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ + -- guile -c 1 +test `readlink "$gcroot"` = "$expected" + +# Make sure '-r' is idempotent. +guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ + -- guile -c 1 +test `readlink "$gcroot"` = "$expected" + + case "`uname -m`" in x86_64) # On x86_64, we should be able to create a 32-bit environment. -- cgit v1.2.3 From 7c247809efe5d6a2a11617f41f45a2b6e8d6855f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 Dec 2016 23:46:44 +0100 Subject: guix build: '--with-source' overrides the 'replacement' of a package. * guix/scripts/build.scm (package-with-source): Set 'replacement' to #f. * tests/scripts-build.scm ("options->transformation, with-source, replacement"): New test. --- guix/scripts/build.scm | 6 +++++- tests/scripts-build.scm | 13 +++++++++++++ 2 files changed, 18 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8c2c4902fc..ccb4c275fc 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -151,7 +151,11 @@ the new package's version number from URI." ;; Use #:recursive? #t to allow for directories. (source (download-to-store store uri - #:recursive? #t)))))) + #:recursive? #t)) + + ;; Override the replacement, otherwise '--with-source' would + ;; have no effect. + (replacement #f))))) ;;; diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index b324012806..a1f684c736 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -50,6 +50,19 @@ (add-to-store store "guix.scm" #t "sha256" s))))))) +(test-assert "options->transformation, with-source, replacement" + ;; Same, but this time the original package has a 'replacement' field. We + ;; expect that replacement to be set to #f in the new package. + (let* ((p (dummy-package "guix.scm" (replacement coreutils))) + (s (search-path %load-path "guix.scm")) + (t (options->transformation `((with-source . ,s))))) + (with-store store + (let ((new (t store p))) + (and (not (eq? new p)) + (string=? (package-source new) + (add-to-store store "guix.scm" #t "sha256" s)) + (not (package-replacement new))))))) + (test-assert "options->transformation, with-source, with version" ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source ;; should be applicable, and its version should be extracted. -- cgit v1.2.3 From f53a5514e0e9535d2e7c668803e64b4aac17da2b Mon Sep 17 00:00:00 2001 From: David Craven Date: Sun, 1 Jan 2017 16:14:45 +0100 Subject: import: crate: Provide a default home-page value. * guix/import/crate.scm (make-crate-sexp): Provide a default home-page value. * tests/crate.scm (test-crate): Add repository field. Problem reported by ng0 . --- guix/import/crate.scm | 12 +++++++++--- tests/crate.scm | 1 + 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 3a19fc70cf..33cc6104c5 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -55,7 +55,8 @@ (crate (assoc-ref crate-json "crate")) (name (assoc-ref crate "name")) (version (assoc-ref crate "max_version")) - (home-page (assoc-ref crate "homepage")) + (homepage (assoc-ref crate "homepage")) + (repository (assoc-ref crate "repository")) (synopsis (assoc-ref crate "description")) (description (assoc-ref crate "description")) (license (string->license (assoc-ref crate "license"))) @@ -67,7 +68,10 @@ (filter (lambda (dep) (not ((crate-kind-predicate "normal") dep))) deps)) (inputs (crates->inputs input-crates)) - (native-inputs (crates->inputs native-input-crates))) + (native-inputs (crates->inputs native-input-crates)) + (home-page (match homepage + (() repository) + (_ homepage)))) (callback #:name name #:version version #:inputs inputs #:native-inputs native-inputs #:home-page home-page #:synopsis synopsis @@ -95,7 +99,9 @@ VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (build-system cargo-build-system) ,@(maybe-native-inputs native-inputs) ,@(maybe-inputs inputs) - (home-page ,home-page) + (home-page ,(match home-page + (() "") + (_ home-page))) (synopsis ,synopsis) (description ,(beautify-description description)) (license ,(match license diff --git a/tests/crate.scm b/tests/crate.scm index 18d5f72a8c..6f6fc2bc29 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -35,6 +35,7 @@ \"license\": \"MIT/Apache-2.0\", \"description\": \"summary\", \"homepage\": \"http://example.com\", + \"repository\": \"http://example.com\", } }") -- cgit v1.2.3 From f1d136957d0d5634e60e5389a046a917169cdb9e Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 29 Dec 2016 16:29:24 +0100 Subject: build-system: cargo: Handle Cargo.lock file not present. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build-system/cargo.scm (cargo-build): Add src output. (private-keywords): Add #:outputs. * guix/build/cargo-build-system.scm (configure): Use /share/rust-source when replacing inputs. (build, check): Don't do anything when there isn't a Cargo.lock file present. (install): Install sources to src output. When a Cargo.lock file is present use cargo install to install binaries to out. * guix/import/crate.scm (make-crate-sexp): Importer uses the src output for crate inputs by default. * guix/import/utils.scm (package-names->package-inputs, maybe-inputs, maybe-native-inputs): Take an optional output argument. * tests/crate.scm (crate->guix-package test): Update. Problem reported by Francisco Gómez García . --- guix/build-system/cargo.scm | 4 ++-- guix/build/cargo-build-system.scm | 20 ++++++++++++-------- guix/import/crate.scm | 4 ++-- guix/import/utils.scm | 14 ++++++++------ tests/crate.scm | 2 +- 5 files changed, 25 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 8d835dda1d..ffc0afda3b 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -109,7 +109,7 @@ to NAME and VERSION." #:inputs inputs #:system system #:modules imported-modules - #:outputs outputs + #:outputs (cons "src" outputs) #:guile-for-build guile-for-build)) (define* (lower name @@ -121,7 +121,7 @@ to NAME and VERSION." "Return a bag for NAME." (define private-keywords - '(#:source #:target #:cargo #:rustc #:inputs #:native-inputs)) + '(#:source #:target #:cargo #:rustc #:inputs #:native-inputs #:outputs)) (and (not target) ;; TODO: support cross-compilation (bag diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 4fa29b4cd3..7d656a8d58 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -54,7 +54,7 @@ (when (and crate path) (match (string-split (basename path) #\-) ((_ ... version) - (format port "\"~a:~a\" = { path = \"~a/rustsrc\" }~%" + (format port "\"~a:~a\" = { path = \"~a/share/rust-source\" }~%" crate version path))))))) inputs) (close-port port)) @@ -63,19 +63,22 @@ (define* (build #:key (cargo-build-flags '("--release" "--frozen")) #:allow-other-keys) "Build a given Cargo package." - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))) + (if (file-exists? "Cargo.lock") + (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))) + #t)) (define* (check #:key tests? #:allow-other-keys) "Run tests for a given Cargo package." - (when tests? - (zero? (system* "cargo" "test")))) + (if (and tests? (file-exists? "Cargo.lock")) + (zero? (system* "cargo" "test")) + #t)) (define* (install #:key inputs outputs #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out")) (src (assoc-ref inputs "source")) - (bin (string-append out "/bin")) - (rsrc (string-append out "/rustsrc"))) + (rsrc (string-append (assoc-ref outputs "src") + "/share/rust-source"))) (mkdir-p rsrc) ;; Rust doesn't have a stable ABI yet. Because of this ;; Cargo doesn't have a search path for binaries yet. @@ -87,8 +90,9 @@ ;; When the package includes executables we install ;; it using cargo install. This fails when the crate ;; doesn't contain an executable. - (system* "cargo" "install" "--root" bin) - #t)) + (if (file-exists? "Cargo.lock") + (system* "cargo" "install" "--root" out) + (mkdir out)))) (define %standard-phases ;; 'configure' phase is not needed. diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 33cc6104c5..233a20e983 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -97,8 +97,8 @@ VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (base32 ,(bytevector->nix-base32-string (port-sha256 port)))))) (build-system cargo-build-system) - ,@(maybe-native-inputs native-inputs) - ,@(maybe-inputs inputs) + ,@(maybe-native-inputs native-inputs "src") + ,@(maybe-inputs inputs "src") (home-page ,(match home-page (() "") (_ home-page))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index f304da20e6..be1980d08f 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -211,24 +211,26 @@ into a proper sentence and by using two spaces between sentences." (regexp-substitute/global #f "\\. \\b" cleaned 'pre ". " 'post))) -(define (package-names->package-inputs names) +(define* (package-names->package-inputs names #:optional (output #f)) (map (lambda (input) - (list input (list 'unquote (string->symbol input)))) + (cons* input (list 'unquote (string->symbol input)) + (or (and output (list output)) + '()))) names)) -(define (maybe-inputs package-names) +(define* (maybe-inputs package-names #:optional (output #f)) "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a package definition." - (match (package-names->package-inputs package-names) + (match (package-names->package-inputs package-names output) (() '()) ((package-inputs ...) `((inputs (,'quasiquote ,package-inputs)))))) -(define (maybe-native-inputs package-names) +(define* (maybe-native-inputs package-names #:optional (output #f)) "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a package definition." - (match (package-names->package-inputs package-names) + (match (package-names->package-inputs package-names output) (() '()) ((package-inputs ...) diff --git a/tests/crate.scm b/tests/crate.scm index 6f6fc2bc29..0bb344bb8a 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -91,7 +91,7 @@ ('build-system 'cargo-build-system) ('inputs ('quasiquote - (("rust-bar" ('unquote 'rust-bar))))) + (("rust-bar" ('unquote 'rust-bar) "src")))) ('home-page "http://example.com") ('synopsis "summary") ('description "summary") -- cgit v1.2.3 From 5e2e4a51f93f98c35824e4a7f5a88274d1551b4c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Jan 2017 22:22:14 +0100 Subject: gexp: Support 'ungexp' forms in improper lists. * guix/gexp.scm (gexp)[collect-escapes, substitute-references]: Replace the (exp0 exp ...) patterns with (exp0 . exp) to match improper lists. Adjust clause bodies accordingly. * tests/gexp.scm ("one input package, dotted list"): New test. --- guix/gexp.scm | 8 ++++---- tests/gexp.scm | 12 +++++++++++- 2 files changed, 15 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 79a7b18b09..1f7fbef0a0 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -812,9 +812,9 @@ environment." (cons exp result)) ((ungexp-native-splicing _ ...) (cons exp result)) - ((exp0 exp ...) + ((exp0 . exp) (let ((result (loop #'exp0 result))) - (fold loop result #'(exp ...)))) + (loop #'exp result))) (_ result)))) @@ -875,9 +875,9 @@ environment." (substitute-ungexp-splicing exp substs)) (((ungexp-native-splicing _ ...) rest ...) (substitute-ungexp-splicing exp substs)) - ((exp0 exp ...) + ((exp0 . exp) #`(cons #,(substitute-references #'exp0 substs) - #,(substitute-references #'(exp ...) substs))) + #,(substitute-references #'exp substs))) (x #''x))) (syntax-case s (ungexp output) diff --git a/tests/gexp.scm b/tests/gexp.scm index 797d5fa457..baf78837ae 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -92,6 +92,16 @@ (package-derivation %store coreutils))) (gexp->sexp* exp))))) +(test-assert "one input package, dotted list" + (let ((exp (gexp (coreutils . (ungexp coreutils))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (equal? `(coreutils . ,(derivation->output-path + (package-derivation %store coreutils))) + (gexp->sexp* exp))))) + (test-assert "one input origin" (let ((exp (gexp (display (ungexp (package-source coreutils)))))) (and (gexp? exp) -- cgit v1.2.3 From b96a0640a3ca128c0b9bf9acaef7b3b7a8bb1455 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Jan 2017 16:16:17 +0100 Subject: graph: Add '%reverse-package-node-type'. * guix/scripts/graph.scm (%reverse-package-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("reverse package DAG"): New test. * doc/guix.texi (Invoking guix refresh): Add cross-reference to "Invoking guix graph". (Invoking guix graph): Document 'reverse-package'. --- doc/guix.texi | 18 ++++++++++++++++++ guix/scripts/graph.scm | 21 +++++++++++++++++++++ tests/graph.scm | 14 +++++++++++++- 3 files changed, 52 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 3a9ebe8a63..adc7fefcae 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5445,6 +5445,10 @@ end, display the fraction of packages covered by all these updaters. List top-level dependent packages that would need to be rebuilt as a result of upgrading one or more packages. +@xref{Invoking guix graph, the @code{reverse-package} type of +@command{guix graph}}, for information on how to visualize the list of +dependents of a package. + @end table Be aware that the @code{--list-dependent} option only @@ -5746,6 +5750,20 @@ This is the default type used in the example above. It shows the DAG of package objects, excluding implicit dependencies. It is concise, but filters out many details. +@item reverse-package +This shows the @emph{reverse} DAG of packages. For example: + +@example +guix graph --type=reverse-package ocaml +@end example + +... yields the graph of packages that depend on OCaml. + +Note that for core packages this can yield huge graphs. If all you want +is to know the number of packages that depend on a given package, use +@command{guix refresh --list-dependent} (@pxref{Invoking guix refresh, +@option{--list-dependent}}). + @item bag-emerged This is the package DAG, @emph{including} implicit inputs. diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index d96df5fbaf..79ce503a2e 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type @@ -101,6 +102,25 @@ name." (label node-full-name) (edges (lift1 package-node-edges %store-monad)))) + +;;; +;;; Reverse package DAG. +;;; + +(define %reverse-package-node-type + ;; For this node type we first need to compute the list of packages and the + ;; list of back-edges. Since we want to do it only once, we use the + ;; promises below. + (let* ((packages (delay (fold-packages cons '()))) + (back-edges (delay (run-with-store #f ;store not actually needed + (node-back-edges %package-node-type + (force packages)))))) + (node-type + (inherit %package-node-type) + (name "reverse-package") + (description "the reverse DAG of packages") + (edges (lift1 (force back-edges) %store-monad))))) + ;;; ;;; Package DAG using bags. @@ -323,6 +343,7 @@ substitutes." (define %node-types ;; List of all the node types. (list %package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type diff --git a/tests/graph.scm b/tests/graph.scm index bc4d62fe50..6431c482f7 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +32,7 @@ #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages guile) + #:use-module (gnu packages libunistring) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -92,6 +93,17 @@ edges." (list p3 p3 p2) (list p2 p1 p1)))))))) +(test-assert "reverse package DAG" + (let-values (((backend nodes+edges) (make-recording-backend))) + (run-with-store %store + (export-graph (list libunistring) 'port + #:node-type %reverse-package-node-type + #:backend backend)) + ;; We should see nothing more than these 3 packages. + (let-values (((nodes edges) (nodes+edges))) + (and (member (package->tuple guile-2.0) nodes) + (->bool (member (edge->tuple libunistring guile-2.0) edges)))))) + (test-assert "bag-emerged DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (let* ((o (dummy-origin (method (lambda _ -- cgit v1.2.3