From 16142b3c14b4d913fd941a96fff12d598cb4a1d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 May 2015 22:05:10 +0200 Subject: build-system/gnu: Adjust to removal of a "bin" output for Libtool. * guix/build-system/gnu.scm (dist-package): Change libtool:bin input to just libtool. --- guix/build-system/gnu.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 3ccdef132..a383c8c75 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -206,7 +206,7 @@ runs `make distcheck' and whose result is one or more source tarballs." (module-ref (resolve-interface module) var)))) `(("autoconf" ,(ref '(gnu packages autotools) 'autoconf)) ("automake" ,(ref '(gnu packages autotools) 'automake)) - ("libtool" ,(ref '(gnu packages autotools) 'libtool) "bin") + ("libtool" ,(ref '(gnu packages autotools) 'libtool)) ("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext)) ("texinfo" ,(ref '(gnu packages texinfo) 'texinfo)))))))) -- cgit v1.3 From 2d51666bd0eee238b70e97f61ad6ce4b958d7362 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 May 2015 22:06:50 +0200 Subject: build-system/gnu: 'dist-package' preserves the package's native inputs. * guix/build-system/gnu.scm (dist-package)[native-inputs]: Preserve P's native-inputs. --- guix/build-system/gnu.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index a383c8c75..252022493 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -204,7 +204,8 @@ runs `make distcheck' and whose result is one or more source tarballs." ;; Add autotools & co. as inputs. (let ((ref (lambda (module var) (module-ref (resolve-interface module) var)))) - `(("autoconf" ,(ref '(gnu packages autotools) 'autoconf)) + `(,@(package-native-inputs p) + ("autoconf" ,(ref '(gnu packages autotools) 'autoconf)) ("automake" ,(ref '(gnu packages autotools) 'automake)) ("libtool" ,(ref '(gnu packages autotools) 'libtool)) ("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext)) -- cgit v1.3 From dedb17ad010ee9ef67f3f4f3997dd17f226c8090 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 2 May 2015 23:55:24 +0200 Subject: profiles: Store search paths in manifests. Discussed in . * guix/packages.scm (sexp->search-path-specification): New variable. * guix/profiles.scm ()[search-paths]: New field. (package->manifest-entry): Initialize it. (manifest->gexp): Match it. Wrap #$deps in (propagated-inputs ...). Emit (search-paths ...). Increment version. (find-package): New procedure. (sexp->manifest)[infer-search-paths]: New procedure. Use it to initialize the 'search-paths' field for versions 0 and 1. Add case for version 2. * guix/scripts/package.scm (search-path-environment-variables)[manifest-entry->package]: Remove. Use 'manifest-entry-search-paths' instead of 'manifest-entry->package' plus 'package-native-search-paths'. * tests/profiles.scm ("profile-manifest, search-paths"): New test. --- guix/packages.scm | 15 ++++++++++ guix/profiles.scm | 76 ++++++++++++++++++++++++++++++++++++++++++------ guix/scripts/package.scm | 22 ++------------ tests/profiles.scm | 22 ++++++++++++++ 4 files changed, 106 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index a979f31a3..b7a1979a7 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -56,6 +56,7 @@ search-path-specification search-path-specification? search-path-specification->sexp + sexp->search-path-specification package package? @@ -202,10 +203,24 @@ representation." (define (search-path-specification->sexp spec) "Return an sexp representing SPEC, a . The sexp corresponds to the arguments expected by `set-path-environment-variable'." + ;; Note that this sexp format is used both by build systems and in + ;; (guix profiles), so think twice before you change it. (match spec (($ variable files separator type pattern) `(,variable ,files ,separator ,type ,pattern)))) +(define (sexp->search-path-specification sexp) + "Convert SEXP, which is as returned by 'search-path-specification->sexp', to +a object." + (match sexp + ((variable files separator type pattern) + (search-path-specification + (variable variable) + (files files) + (separator separator) + (file-type type) + (file-pattern pattern))))) + (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. diff --git a/guix/profiles.scm b/guix/profiles.scm index 4bb309305..2e515d549 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -59,6 +59,7 @@ manifest-entry-output manifest-entry-item manifest-entry-dependencies + manifest-entry-search-paths manifest-pattern manifest-pattern? @@ -133,6 +134,8 @@ (default "out")) (item manifest-entry-item) ; package | store path (dependencies manifest-entry-dependencies ; (store path | package)* + (default '())) + (search-paths manifest-entry-search-paths ; search-path-specification* (default '()))) (define-record-type* manifest-pattern @@ -165,25 +168,60 @@ omitted or #f, use the first output of PACKAGE." (version (package-version package)) (output (or output (car (package-outputs package)))) (item package) - (dependencies (delete-duplicates deps))))) + (dependencies (delete-duplicates deps)) + (search-paths (package-native-search-paths package))))) (define (manifest->gexp manifest) "Return a representation of MANIFEST as a gexp." (define (entry->gexp entry) (match entry - (($ name version output (? string? path) (deps ...)) - #~(#$name #$version #$output #$path #$deps)) - (($ name version output (? package? package) (deps ...)) + (($ name version output (? string? path) + (deps ...) (search-paths ...)) + #~(#$name #$version #$output #$path + (propagated-inputs #$deps) + (search-paths #$(map search-path-specification->sexp + search-paths)))) + (($ name version output (? package? package) + (deps ...) (search-paths ...)) #~(#$name #$version #$output - (ungexp package (or output "out")) #$deps)))) + (ungexp package (or output "out")) + (propagated-inputs #$deps) + (search-paths #$(map search-path-specification->sexp + search-paths)))))) (match manifest (($ (entries ...)) - #~(manifest (version 1) + #~(manifest (version 2) (packages #$(map entry->gexp entries)))))) +(define (find-package name version) + "Return a package from the distro matching NAME and possibly VERSION. This +procedure is here for backward-compatibility and will eventually vanish." + (define find-best-packages-by-name ;break abstractions + (module-ref (resolve-interface '(gnu packages)) + 'find-best-packages-by-name)) + + ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the + ;; former traverses the module tree only once and then allows for efficient + ;; access via a vhash. + (match (find-best-packages-by-name name version) + ((p _ ...) p) + (_ + (match (find-best-packages-by-name name #f) + ((p _ ...) p) + (_ #f))))) + (define (sexp->manifest sexp) "Parse SEXP as a manifest." + (define (infer-search-paths name version) + ;; Infer the search path specifications for NAME-VERSION by looking up a + ;; same-named package in the distro. Useful for the old manifest formats + ;; that did not store search path info. + (let ((package (find-package name version))) + (if package + (package-native-search-paths package) + '()))) + (match sexp (('manifest ('version 0) ('packages ((name version output path) ...))) @@ -193,7 +231,8 @@ omitted or #f, use the first output of PACKAGE." (name name) (version version) (output output) - (item path))) + (item path) + (search-paths (infer-search-paths name version)))) name version output path))) ;; Version 1 adds a list of propagated inputs to the @@ -215,11 +254,30 @@ omitted or #f, use the first output of PACKAGE." (version version) (output output) (item path) - (dependencies deps)))) + (dependencies deps) + (search-paths (infer-search-paths name version))))) name version output path deps))) + ;; Version 2 adds search paths and is slightly more verbose. + (('manifest ('version 2 minor-version ...) + ('packages ((name version output path + ('propagated-inputs deps) + ('search-paths search-paths) + extra-stuff ...) + ...))) + (manifest + (map (lambda (name version output path deps search-paths) + (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps) + (search-paths (map sexp->search-path-specification + search-paths)))) + name version output path deps search-paths))) (_ - (error "unsupported manifest format" manifest)))) + (error "unsupported manifest format" sexp)))) (define (read-manifest port) "Return the packages listed in MANIFEST." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1e724b4e1..fca70f566 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -384,22 +384,6 @@ current settings and report only settings not already effective." %user-profile-directory profile))) - ;; The search path info is not stored in the manifest. Thus, we infer the - ;; search paths from same-named packages found in the distro. - - (define manifest-entry->package - (match-lambda - (($ name version) - ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; - ;; the former traverses the module tree only once and then allows for - ;; efficient access via a vhash. - (match (find-best-packages-by-name name version) - ((p _ ...) p) - (_ - (match (find-best-packages-by-name name #f) - ((p _ ...) p) - (_ #f))))))) - (define search-path-definition (match-lambda (($ variable files separator @@ -426,10 +410,8 @@ current settings and report only settings not already effective." variable (string-join path separator))))))) - (let* ((packages (filter-map manifest-entry->package entries)) - (search-paths (delete-duplicates - (append-map package-native-search-paths - packages)))) + (let ((search-paths (delete-duplicates + (append-map manifest-entry-search-paths entries)))) (filter-map search-path-definition search-paths)))) (define (display-search-paths entries profile) diff --git a/tests/profiles.scm b/tests/profiles.scm index 54fbaea86..890f09a75 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -26,6 +26,7 @@ #:use-module (guix derivations) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages base) #:prefix packages:) + #:use-module ((gnu packages guile) #:prefix packages:) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-11) @@ -198,6 +199,27 @@ #:hooks '()))) (return (derivation-inputs drv)))) +(test-assertm "profile-manifest, search-paths" + (mlet* %store-monad + ((guile -> (package + (inherit %bootstrap-guile) + (native-search-paths + (package-native-search-paths packages:guile-2.0)))) + (entry -> (package->manifest-entry guile)) + (drv (profile-derivation (manifest (list entry)) + #:hooks '())) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + + ;; Read the manifest back and make sure search paths are preserved. + (let ((manifest (profile-manifest profile))) + (match (manifest-entries manifest) + ((result) + (return (equal? (manifest-entry-search-paths result) + (manifest-entry-search-paths entry) + (package-native-search-paths + packages:guile-2.0))))))))) (test-end "profiles") -- cgit v1.3 From f77bcbc374bb94272c57508dc04fb8599b56a9d8 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 24 Apr 2015 07:57:51 -0500 Subject: guix: packages: Add package-direct-sources and package-transitive-sources. * guix/tests.scm (dummy-origin): New syntax. * guix/packages.scm (package-direct-sources) (package-transitive-sources): New procedures. * tests/packages.scm ("package-direct-sources, no source") ("package-direct-sources, #f source") ("package-direct-sources, not input source", "package-direct-sources") ("package-transitive-sources"): Test them. --- guix/packages.scm | 24 ++++++++++++++++++++++++ guix/tests.scm | 10 +++++++++- tests/packages.scm | 30 ++++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index b7a1979a7..d7fced838 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -83,6 +83,8 @@ package-location package-field-location + package-direct-sources + package-transitive-sources package-direct-inputs package-transitive-inputs package-transitive-target-inputs @@ -540,6 +542,28 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." ((input rest ...) (loop rest (cons input result)))))) +(define (package-direct-sources package) + "Return all source origins associated with PACKAGE; including origins in +PACKAGE's inputs." + `(,@(or (and=> (package-source package) list) '()) + ,@(filter-map (match-lambda + ((_ (? origin? orig) _ ...) + orig) + (_ #f)) + (package-direct-inputs package)))) + +(define (package-transitive-sources package) + "Return PACKAGE's direct sources, and their direct sources, recursively." + (delete-duplicates + (concatenate (filter-map (match-lambda + ((_ (? origin? orig) _ ...) + (list orig)) + ((_ (? package? p) _ ...) + (package-direct-sources p)) + (_ #f)) + (bag-transitive-inputs + (package->bag package)))))) + (define (package-direct-inputs package) "Return all the direct inputs of PACKAGE---i.e, its direct inputs along with their propagated inputs." diff --git a/guix/tests.scm b/guix/tests.scm index 080ee9cc7..87e6cc283 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -37,7 +37,8 @@ %substitute-directory with-derivation-narinfo with-derivation-substitute - dummy-package)) + dummy-package + dummy-origin)) ;;; Commentary: ;;; @@ -219,6 +220,13 @@ initialized with default values, and with EXTRA-FIELDS set as specified." (synopsis #f) (description #f) (home-page #f) (license #f))) +(define-syntax-rule (dummy-origin extra-fields ...) + "Return a \"dummy\" origin, with all its compulsory fields initialized with +default values, and with EXTRA-FIELDS set as specified." + (origin extra-fields ... + (method #f) (uri "http://www.example.com") + (sha256 (base32 (make-string 52 #\x))))) + ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) diff --git a/tests/packages.scm b/tests/packages.scm index 4e5281365..511ad78b6 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -155,6 +155,36 @@ (package-transitive-supported-systems d) (package-transitive-supported-systems e)))) +(let* ((o (dummy-origin)) + (u (dummy-origin)) + (i (dummy-origin)) + (a (dummy-package "a")) + (b (dummy-package "b" + (inputs `(("a" ,a) ("i" ,i))))) + (c (package (inherit b) (source o))) + (d (dummy-package "d" + (build-system trivial-build-system) + (source u) (inputs `(("c" ,c)))))) + (test-assert "package-direct-sources, no source" + (null? (package-direct-sources a))) + (test-equal "package-direct-sources, #f source" + (list i) + (package-direct-sources b)) + (test-equal "package-direct-sources, not input source" + (list u) + (package-direct-sources d)) + (test-assert "package-direct-sources" + (let ((s (package-direct-sources c))) + (and (= (length (pk 's-sources s)) 2) + (member o s) + (member i s)))) + (test-assert "package-transitive-sources" + (let ((s (package-transitive-sources d))) + (and (= (length (pk 'd-sources s)) 3) + (member o s) + (member i s) + (member u s))))) + (test-equal "package-transitive-supported-systems, implicit inputs" %supported-systems -- cgit v1.3 From 2cdfe13deaf3d959e1ecb3a207cdbc28985e0e79 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 28 Jan 2015 13:33:28 -0600 Subject: guix: build: Add transitive source building. * guix/scripts/build.scm (%options, options->derivations): Add --sources option. * doc/guix.texi (Invoking guix build): Document --sources option. * tests/guix-build.sh: Add tests. --- doc/guix.texi | 43 ++++++++++++++++++++++++++ guix/scripts/build.scm | 55 ++++++++++++++++++++++----------- tests/guix-build.sh | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 163 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index c68e2915d..3328cbac9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2932,6 +2932,49 @@ The returned source tarball is the result of applying any patches and code snippets specified in the package's @code{origin} (@pxref{Defining Packages}). +@item --sources +Fetch and return the source of @var{package-or-derivation} and all their +dependencies, recursively. This is a handy way to obtain a local copy +of all the source code needed to build @var{packages}, allowing you to +eventually build them even without network access. It is an extension +of the @code{--source} option and can accept one of the following +optional argument values: + +@table @code +@item package +This value causes the @code{--sources} option to behave in the same way +as the @code{--source} option. + +@item all +Build all packages' source derivations, including any source that might +be listed as @code{inputs}. This is the default value. + +@example +$ guix build --sources tzdata +The following derivations will be built: + /gnu/store/@dots{}-tzdata2015b.tar.gz.drv + /gnu/store/@dots{}-tzcode2015b.tar.gz.drv +@end example + +@item transitive +Build all packages' source derivations, as well as all source +derivations for packages' transitive inputs. This can be used e.g. to +prefetch package source for later offline building. + +@example +$ guix build --sources=transitive tzdata +The following derivations will be built: + /gnu/store/@dots{}-tzcode2015b.tar.gz.drv + /gnu/store/@dots{}-findutils-4.4.2.tar.xz.drv + /gnu/store/@dots{}-grep-2.21.tar.xz.drv + /gnu/store/@dots{}-coreutils-8.23.tar.xz.drv + /gnu/store/@dots{}-make-4.1.tar.xz.drv + /gnu/store/@dots{}-bash-4.3.tar.xz.drv +@dots{} +@end example + +@end table + @item --system=@var{system} @itemx -s @var{system} Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 370c2a37f..9366ab6cc 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -228,6 +228,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " + --sources[=TYPE] build source derivations; TYPE may optionally be one + of \"package\", \"all\" (default), or \"transitive\"")) + (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) @@ -262,10 +265,22 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix build"))) - (option '(#\S "source") #f #f (lambda (opt name arg result) - (alist-cons 'source? #t result))) + (alist-cons 'source #t result))) + (option '("sources") #f #t + (lambda (opt name arg result) + (match arg + ("package" + (alist-cons 'source #t result)) + ((or "all" #f) + (alist-cons 'source package-direct-sources result)) + ("transitive" + (alist-cons 'source package-transitive-sources result)) + (else + (leave (_ "invalid argument: '~a' option argument: ~a, ~ +must be one of 'package', 'all', or 'transitive'~%") + name arg))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -308,28 +323,34 @@ build." (triplet (cut package-cross-derivation <> <> triplet <>)))) - (define src? (assoc-ref opts 'source?)) + (define src (assoc-ref opts 'source)) (define sys (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? graft?)) (let ((opts (options/with-source store (options/resolve-packages store opts)))) - (filter-map (match-lambda - (('argument . (? package? p)) - (if src? + (concatenate + (filter-map (match-lambda + (('argument . (? package? p)) + (match src + (#f + (list (package->derivation store p sys))) + (#t (let ((s (package-source p))) - (package-source-derivation store s)) - (package->derivation store p sys))) - (('argument . (? derivation? drv)) - drv) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (_ #f)) - opts)))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p))))) + (('argument . (? derivation? drv)) + (list drv)) + (('argument . (? derivation-path? drv)) + (list (call-with-input-file drv read-derivation))) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (_ #f)) + opts))))) (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by actual diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 836c45e77..a72ce0911 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -36,6 +36,88 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' | \ guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' +# Check --sources option with its arguments +module_dir="t-guix-build-$$" +mkdir "$module_dir" +trap "rm -rf $module_dir" EXIT + +cat > "$module_dir/foo.scm"< Date: Sun, 3 May 2015 22:33:27 +0200 Subject: guix package: Move profile cleaning out of 'search-path-environment-variables'. * guix/scripts/package.scm (user-friendly-profile): New procedure. (search-path-environment-variables): Remove 'profile' local variable. (display-search-paths): Explicitly call 'user-friendly-profile' for the argument to 'search-path-environment-variables'. (guix-package)[process-query]: Likewise. --- guix/scripts/package.scm | 80 +++++++++++++++++++++++++----------------------- 1 file changed, 41 insertions(+), 39 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fca70f566..d9bad7ba8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -89,6 +89,15 @@ return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if %current-profile profile)) +(define (user-friendly-profile profile) + "Return either ~/.guix-profile if that's what PROFILE refers to, directly or +indirectly, or PROFILE." + (if (and %user-profile-directory + (false-if-exception + (string=? (readlink %user-profile-directory) profile))) + %user-profile-directory + profile)) + (define (link-to-empty-profile store generation) "Link GENERATION, a string, to the empty profile." (let* ((drv (run-with-store store @@ -375,49 +384,41 @@ an output path different than CURRENT-PATH." "Return environment variable definitions that may be needed for the use of ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the current settings and report only settings not already effective." - - ;; Prefer ~/.guix-profile to the real profile directory name. - (let ((profile (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) - profile))) - %user-profile-directory - profile))) - - (define search-path-definition - (match-lambda - (($ variable files separator - type pattern) - (let* ((values (or (and=> (getenv variable) - (cut string-tokenize* <> separator)) - '())) - ;; Add a trailing slash to force symlinks to be treated as - ;; directories when 'find-files' traverses them. - (files (if pattern - (map (cut string-append <> "/") files) - files)) - - ;; XXX: Silence 'find-files' when it stumbles upon non-existent - ;; directories (see - ;; .) - (path (with-null-error-port - (search-path-as-list files (list profile) - #:type type - #:pattern pattern)))) - (if (every (cut member <> values) path) - #f - (format #f "export ~a=\"~a\"" - variable - (string-join path separator))))))) - - (let ((search-paths (delete-duplicates - (append-map manifest-entry-search-paths entries)))) - (filter-map search-path-definition search-paths)))) + (define search-path-definition + (match-lambda + (($ variable files separator + type pattern) + (let* ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + ;; Add a trailing slash to force symlinks to be treated as + ;; directories when 'find-files' traverses them. + (files (if pattern + (map (cut string-append <> "/") files) + files)) + + ;; XXX: Silence 'find-files' when it stumbles upon non-existent + ;; directories (see + ;; .) + (path (with-null-error-port + (search-path-as-list files (list profile) + #:type type + #:pattern pattern)))) + (if (every (cut member <> values) path) + #f + (format #f "export ~a=\"~a\"" + variable + (string-join path separator))))))) + + (let ((search-paths (delete-duplicates + (append-map manifest-entry-search-paths entries)))) + (filter-map search-path-definition search-paths))) (define (display-search-paths entries profile) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let ((settings (search-path-environment-variables entries profile))) + (let* ((profile (user-friendly-profile profile)) + (settings (search-path-environment-variables entries profile))) (unless (null? settings) (format #t (_ "The following environment variable definitions may be needed:~%")) (format #t "~{ ~a~%~}" settings)))) @@ -999,6 +1000,7 @@ more information.~%")) (('search-paths) (let* ((manifest (profile-manifest profile)) (entries (manifest-entries manifest)) + (profile (user-friendly-profile profile)) (settings (search-path-environment-variables entries profile (const #f)))) (format #t "~{~a~%~}" settings) -- cgit v1.3 From 4e9f59205835e148d4329e7d77c81dccfacd4ea2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 May 2015 23:01:35 +0200 Subject: guix package: Introduce 'evaluate-search-paths'. * guix/scripts/package.scm (evaluate-search-paths): New procedure, with most of the code formerly in 'search-path-environment-variables'. (search-path-environment-variables): Use it. --- guix/scripts/package.scm | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d9bad7ba8..003f6958e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -379,10 +379,10 @@ an output path different than CURRENT-PATH." (with-error-to-port (%make-void-port "w") (lambda () exp))) -(define* (search-path-environment-variables entries profile - #:optional (getenv getenv)) - "Return environment variable definitions that may be needed for the use of -ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the +(define* (evaluate-search-paths search-paths directory + #:optional (getenv (const #f))) + "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, +and return a list of variable/value pairs. Use GETENV to determine the current settings and report only settings not already effective." (define search-path-definition (match-lambda @@ -401,18 +401,26 @@ current settings and report only settings not already effective." ;; directories (see ;; .) (path (with-null-error-port - (search-path-as-list files (list profile) + (search-path-as-list files (list directory) #:type type #:pattern pattern)))) (if (every (cut member <> values) path) - #f - (format #f "export ~a=\"~a\"" - variable - (string-join path separator))))))) + #f ;VARIABLE is already set appropriately + (cons variable (string-join path separator))))))) + + (filter-map search-path-definition search-paths)) +(define* (search-path-environment-variables entries profile + #:optional (getenv getenv)) + "Return environment variable definitions that may be needed for the use of +ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the +current settings and report only settings not already effective." (let ((search-paths (delete-duplicates (append-map manifest-entry-search-paths entries)))) - (filter-map search-path-definition search-paths))) + (filter-map (match-lambda + ((variable . value) + (format #f "export ~a=\"~a\"" variable value))) + (evaluate-search-paths search-paths profile getenv)))) (define (display-search-paths entries profile) "Display the search path environment variables that may need to be set for -- cgit v1.3 From 2087023dd48059f273bb7eae9815fb255aa7d0a9 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 4 May 2015 14:16:28 -0500 Subject: guix: build: Fix indentation for --sources in help output. * guix/scripts/build.scm (show-help)[--sources]: Make indentation consistent with other long options. --- guix/scripts/build.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 9366ab6cc..da71adba6 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -228,7 +228,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " - --sources[=TYPE] build source derivations; TYPE may optionally be one + --sources[=TYPE] build source derivations; TYPE may optionally be one of \"package\", \"all\" (default), or \"transitive\"")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) -- cgit v1.3 From 5e6039a48b136d34d21b34237617d77580566e51 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 15:38:30 +0200 Subject: substitute: Increase TTL from 24h to 36h. * guix/scripts/substitute.scm (%narinfo-ttl): Increase to 36h. --- guix/scripts/substitute.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b9983c5b9..ae97f74d2 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -84,8 +84,10 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. - (* 24 3600)) + ;; valid. This is a reasonable default value (corresponds to the TTL for + ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to + ;; state what their TTL is in /nix-cache-info. (XXX) + (* 36 3600)) (define %narinfo-negative-ttl ;; Likewise, but for negative lookups---i.e., cached lookup failures. -- cgit v1.3 From e89431bf016830a919ec2430889f6c2679aab408 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 22:11:37 +0200 Subject: Move search path specifications to (guix search-paths). * guix/packages.scm (, search-path-specification->sexp, sexp->search-path-specification): Move to... * guix/search-paths.scm: ... here. New file. * Makefile.am (MODULES): Add it. * guix/build-system/cmake.scm, guix/build-system/glib-or-gtk.scm, guix/build-system/gnu.scm, guix/build-system/haskell.scm, guix/build-system/perl.scm, guix/build-system/python.scm, guix/build-system/ruby.scm, guix/build-system/waf.scm, guix/profiles.scm, guix/scripts/package.scm: Use it. --- Makefile.am | 1 + guix/build-system/cmake.scm | 1 + guix/build-system/glib-or-gtk.scm | 1 + guix/build-system/gnu.scm | 1 + guix/build-system/haskell.scm | 1 + guix/build-system/perl.scm | 1 + guix/build-system/python.scm | 1 + guix/build-system/ruby.scm | 1 + guix/build-system/waf.scm | 1 + guix/packages.scm | 44 ++-------------------- guix/profiles.scm | 3 +- guix/scripts/package.scm | 1 + guix/search-paths.scm | 77 +++++++++++++++++++++++++++++++++++++++ 13 files changed, 92 insertions(+), 42 deletions(-) create mode 100644 guix/search-paths.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index aa412bda2..ae694eb0e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -87,6 +87,7 @@ MODULES = \ guix/build/gremlin.scm \ guix/build/emacs-utils.scm \ guix/build/graft.scm \ + guix/search-paths.scm \ guix/packages.scm \ guix/import/utils.scm \ guix/import/gnu.scm \ diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 1bc1879be..25ac262d5 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -21,6 +21,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 954c71689..a1f0a9b8a 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 252022493..da664e542 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix packages) #:use-module (srfi srfi-1) diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 0fbf0b8e7..1cb734631 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 783315367..06af1dd20 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index d498cf618..e9fffcc62 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -23,6 +23,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 83bc93d90..e4fda30cf 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index c67f649fa..044d2a082 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module ((guix build-system python) diff --git a/guix/packages.scm b/guix/packages.scm index d7fced838..c955b3515 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,6 +26,7 @@ #:use-module (guix base32) #:use-module (guix derivations) #:use-module (guix build-system) + #:use-module (guix search-paths) #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -36,7 +37,8 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:re-export (%current-system - %current-target-system) + %current-target-system + search-path-specification) ;for convenience #:export (origin origin? origin-uri @@ -52,12 +54,6 @@ origin-imported-modules base32 - - search-path-specification - search-path-specification? - search-path-specification->sexp - sexp->search-path-specification - package package? package-name @@ -189,40 +185,6 @@ representation." ((_ str) #'(nix-base32-string->bytevector str))))) -;; The specification of a search path. -(define-record-type* - search-path-specification make-search-path-specification - search-path-specification? - (variable search-path-specification-variable) ;string - (files search-path-specification-files) ;list of strings - (separator search-path-specification-separator ;string - (default ":")) - (file-type search-path-specification-file-type ;symbol - (default 'directory)) - (file-pattern search-path-specification-file-pattern ;#f | string - (default #f))) - -(define (search-path-specification->sexp spec) - "Return an sexp representing SPEC, a . The sexp -corresponds to the arguments expected by `set-path-environment-variable'." - ;; Note that this sexp format is used both by build systems and in - ;; (guix profiles), so think twice before you change it. - (match spec - (($ variable files separator type pattern) - `(,variable ,files ,separator ,type ,pattern)))) - -(define (sexp->search-path-specification sexp) - "Convert SEXP, which is as returned by 'search-path-specification->sexp', to -a object." - (match sexp - ((variable files separator type pattern) - (search-path-specification - (variable variable) - (files files) - (separator separator) - (file-type type) - (file-pattern pattern))))) - (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. diff --git a/guix/profiles.scm b/guix/profiles.scm index 2e515d549..fd2afc05a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -22,8 +22,9 @@ (define-module (guix profiles) #:use-module (guix utils) #:use-module (guix records) - #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix store) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 003f6958e..44cacdca8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -25,6 +25,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix search-paths) #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) diff --git a/guix/search-paths.scm b/guix/search-paths.scm new file mode 100644 index 000000000..147bfcae8 --- /dev/null +++ b/guix/search-paths.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix search-paths) + #:use-module (guix records) + #:use-module (ice-9 match) + #:export ( + search-path-specification + search-path-specification? + search-path-specification-variable + search-path-specification-files + search-path-specification-separator + search-path-specification-file-type + search-path-specification-file-pattern + + search-path-specification->sexp + sexp->search-path-specification)) + +;;; Commentary: +;;; +;;; This module defines "search path specifications", which allow packages to +;;; declare environment variables that they use to define search paths. For +;;; instance, GCC has the 'CPATH' variable, Guile has the 'GUILE_LOAD_PATH' +;;; variable, etc. +;;; +;;; Code: + +;; The specification of a search path. +(define-record-type* + search-path-specification make-search-path-specification + search-path-specification? + (variable search-path-specification-variable) ;string + (files search-path-specification-files) ;list of strings + (separator search-path-specification-separator ;string + (default ":")) + (file-type search-path-specification-file-type ;symbol + (default 'directory)) + (file-pattern search-path-specification-file-pattern ;#f | string + (default #f))) + +(define (search-path-specification->sexp spec) + "Return an sexp representing SPEC, a . The sexp +corresponds to the arguments expected by `set-path-environment-variable'." + ;; Note that this sexp format is used both by build systems and in + ;; (guix profiles), so think twice before you change it. + (match spec + (($ variable files separator type pattern) + `(,variable ,files ,separator ,type ,pattern)))) + +(define (sexp->search-path-specification sexp) + "Convert SEXP, which is as returned by 'search-path-specification->sexp', to +a object." + (match sexp + ((variable files separator type pattern) + (search-path-specification + (variable variable) + (files files) + (separator separator) + (file-type type) + (file-pattern pattern))))) + +;;; search-paths.scm ends here -- cgit v1.3 From 6568d2bd6e4e047dd95b00a7a6e7501a16491eb5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 21:44:52 +0200 Subject: search-paths: Add 'evaluate-search-paths', from (guix scripts package). * guix/scripts/package.scm (with-null-error-port, evaluate-search-paths): Move to... * guix/search-paths.scm: ... here. * guix/utils.scm (string-tokenize*): Move to... * guix/search-paths.scm: ... here. * tests/utils.scm ("string-tokenize*"): Adjust accordingly. --- guix/scripts/package.scm | 36 ------------------------ guix/search-paths.scm | 72 +++++++++++++++++++++++++++++++++++++++++++++++- guix/utils.scm | 28 ------------------- tests/utils.scm | 11 ++++---- 4 files changed, 77 insertions(+), 70 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 44cacdca8..933f7d8ee 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -375,42 +375,6 @@ an output path different than CURRENT-PATH." ;;; Search paths. ;;; -(define-syntax-rule (with-null-error-port exp) - "Evaluate EXP with the error port pointing to the bit bucket." - (with-error-to-port (%make-void-port "w") - (lambda () exp))) - -(define* (evaluate-search-paths search-paths directory - #:optional (getenv (const #f))) - "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, -and return a list of variable/value pairs. Use GETENV to determine the -current settings and report only settings not already effective." - (define search-path-definition - (match-lambda - (($ variable files separator - type pattern) - (let* ((values (or (and=> (getenv variable) - (cut string-tokenize* <> separator)) - '())) - ;; Add a trailing slash to force symlinks to be treated as - ;; directories when 'find-files' traverses them. - (files (if pattern - (map (cut string-append <> "/") files) - files)) - - ;; XXX: Silence 'find-files' when it stumbles upon non-existent - ;; directories (see - ;; .) - (path (with-null-error-port - (search-path-as-list files (list directory) - #:type type - #:pattern pattern)))) - (if (every (cut member <> values) path) - #f ;VARIABLE is already set appropriately - (cons variable (string-join path separator))))))) - - (filter-map search-path-definition search-paths)) - (define* (search-path-environment-variables entries profile #:optional (getenv getenv)) "Return environment variable definitions that may be needed for the use of diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 147bfcae8..b17f5acd5 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -18,6 +18,9 @@ (define-module (guix search-paths) #:use-module (guix records) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export ( search-path-specification @@ -29,7 +32,8 @@ search-path-specification-file-pattern search-path-specification->sexp - sexp->search-path-specification)) + sexp->search-path-specification + evaluate-search-paths)) ;;; Commentary: ;;; @@ -74,4 +78,70 @@ a object." (file-type type) (file-pattern pattern))))) +(define-syntax-rule (with-null-error-port exp) + "Evaluate EXP with the error port pointing to the bit bucket." + (with-error-to-port (%make-void-port "w") + (lambda () exp))) + +;; XXX: This procedure used to be in (guix utils) but since we want to be able +;; to use (guix search-paths) on the build side, we want to avoid the +;; dependency on (guix utils), and so this procedure is back here for now. +(define (string-tokenize* string separator) + "Return the list of substrings of STRING separated by SEPARATOR. This is +like `string-tokenize', but SEPARATOR is a string." + (define (index string what) + (let loop ((string string) + (offset 0)) + (cond ((string-null? string) + #f) + ((string-prefix? what string) + offset) + (else + (loop (string-drop string 1) (+ 1 offset)))))) + + (define len + (string-length separator)) + + (let loop ((string string) + (result '())) + (cond ((index string separator) + => + (lambda (offset) + (loop (string-drop string (+ offset len)) + (cons (substring string 0 offset) + result)))) + (else + (reverse (cons string result)))))) + +(define* (evaluate-search-paths search-paths directory + #:optional (getenv (const #f))) + "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, +and return a list of variable/value pairs. Use GETENV to determine the +current settings and report only settings not already effective." + (define search-path-definition + (match-lambda + (($ variable files separator + type pattern) + (let* ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + ;; Add a trailing slash to force symlinks to be treated as + ;; directories when 'find-files' traverses them. + (files (if pattern + (map (cut string-append <> "/") files) + files)) + + ;; XXX: Silence 'find-files' when it stumbles upon non-existent + ;; directories (see + ;; .) + (path (with-null-error-port + (search-path-as-list files (list directory) + #:type type + #:pattern pattern)))) + (if (every (cut member <> values) path) + #f ;VARIABLE is already set appropriately + (cons variable (string-join path separator))))))) + + (filter-map search-path-definition search-paths)) + ;;; search-paths.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 3d38ba122..a2ade2bf9 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -72,7 +72,6 @@ version-major+minor guile-version>? package-name->name+version - string-tokenize* string-replace-substring arguments-from-environment-variable file-extension @@ -606,33 +605,6 @@ introduce the version part." (substring file 0 dot) file))) -(define (string-tokenize* string separator) - "Return the list of substrings of STRING separated by SEPARATOR. This is -like `string-tokenize', but SEPARATOR is a string." - (define (index string what) - (let loop ((string string) - (offset 0)) - (cond ((string-null? string) - #f) - ((string-prefix? what string) - offset) - (else - (loop (string-drop string 1) (+ 1 offset)))))) - - (define len - (string-length separator)) - - (let loop ((string string) - (result '())) - (cond ((index string separator) - => - (lambda (offset) - (loop (string-drop string (+ offset len)) - (cons (substring string 0 offset) - result)))) - (else - (reverse (cons string result)))))) - (define* (string-replace-substring str substr replacement #:optional (start 0) diff --git a/tests/utils.scm b/tests/utils.scm index a662c9a8d..e03a07b2f 100644 --- a/tests/utils.scm +++ b/tests/utils.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 © 2014 Eric Bavier ;;; ;;; This file is part of GNU Guix. @@ -82,10 +82,11 @@ ("foo" "bar" "baz") ("foo" "bar" "") ("foo" "bar" "baz")) - (list (string-tokenize* "foo" ":") - (string-tokenize* "foo;bar;baz" ";") - (string-tokenize* "foo!bar!" "!") - (string-tokenize* "foo+-+bar+-+baz" "+-+"))) + (let ((string-tokenize* (@@ (guix search-paths) string-tokenize*))) + (list (string-tokenize* "foo" ":") + (string-tokenize* "foo;bar;baz" ";") + (string-tokenize* "foo!bar!" "!") + (string-tokenize* "foo+-+bar+-+baz" "+-+")))) (test-equal "string-replace-substring" '("foo BAR! baz" -- cgit v1.3 From b07901c0cc5b36efdc92263ddeaa2be28cf2f398 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 22:06:24 +0200 Subject: search-paths: Add 'environment-variable-definition'. * guix/search-paths.scm (environment-variable-definition): New variable. * guix/scripts/package.scm (search-path-environment-variables): Use it. --- guix/scripts/package.scm | 2 +- guix/search-paths.scm | 25 ++++++++++++++++++++++++- 2 files changed, 25 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 933f7d8ee..9e433dd19 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -384,7 +384,7 @@ current settings and report only settings not already effective." (append-map manifest-entry-search-paths entries)))) (filter-map (match-lambda ((variable . value) - (format #f "export ~a=\"~a\"" variable value))) + (environment-variable-definition variable value))) (evaluate-search-paths search-paths profile getenv)))) (define (display-search-paths entries profile) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index b17f5acd5..7957c8824 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -33,7 +33,8 @@ search-path-specification->sexp sexp->search-path-specification - evaluate-search-paths)) + evaluate-search-paths + environment-variable-definition)) ;;; Commentary: ;;; @@ -144,4 +145,26 @@ current settings and report only settings not already effective." (filter-map search-path-definition search-paths)) +(define* (environment-variable-definition variable value + #:key + (kind 'exact) + (separator ":")) + "Return a the definition of VARIABLE to VALUE in Bash syntax: + +KIND can be either 'exact (return the definition of VARIABLE=VALUE), +'prefix (return the definition where VALUE is added as a prefix to VARIABLE's +current value), or 'suffix (return the definition where VALUE is added as a +suffix to VARIABLE's current value.) In the case of 'prefix and 'suffix, +SEPARATOR is used as the separator between VARIABLE's current value and its +prefix/suffix." + (match kind + ('exact + (format #f "export ~a=\"~a\"" variable value)) + ('prefix + (format #f "export ~a=\"~a${~a:+~a}$~a\"" + variable value variable separator variable)) + ('suffix + (format #f "export ~a=\"$~a${~a:+~a}~a\"" + variable variable variable separator value)))) + ;;; search-paths.scm ends here -- cgit v1.3 From 441cfb420ab7979443cc2752b714738151c9c4e6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 22:27:11 +0200 Subject: search-paths: 'evaluate-search-paths' now returns spec/value pairs. * guix/search-paths.scm (evaluate-search-paths): Return specification/value pairs instead of variable/value pairs. * guix/scripts/package.scm (search-path-environment-variables): Adjust accordingly. Pass #:separator to 'environment-variable-definition'. --- guix/scripts/package.scm | 8 ++++++-- guix/search-paths.scm | 9 +++++---- 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 9e433dd19..7f53af772 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -383,8 +383,12 @@ current settings and report only settings not already effective." (let ((search-paths (delete-duplicates (append-map manifest-entry-search-paths entries)))) (filter-map (match-lambda - ((variable . value) - (environment-variable-definition variable value))) + ((spec . value) + (let ((variable (search-path-specification-variable spec)) + (sep (search-path-specification-separator spec))) + ;; TODO: Offer the choice between exact/prefix/suffix. + (environment-variable-definition variable value + #:separator sep)))) (evaluate-search-paths search-paths profile getenv)))) (define (display-search-paths entries profile) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 7957c8824..154e508d5 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -117,12 +117,13 @@ like `string-tokenize', but SEPARATOR is a string." (define* (evaluate-search-paths search-paths directory #:optional (getenv (const #f))) "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, -and return a list of variable/value pairs. Use GETENV to determine the +and return a list of specification/value pairs. Use GETENV to determine the current settings and report only settings not already effective." (define search-path-definition (match-lambda - (($ variable files separator - type pattern) + ((and spec + ($ variable files separator + type pattern)) (let* ((values (or (and=> (getenv variable) (cut string-tokenize* <> separator)) '())) @@ -141,7 +142,7 @@ current settings and report only settings not already effective." #:pattern pattern)))) (if (every (cut member <> values) path) #f ;VARIABLE is already set appropriately - (cons variable (string-join path separator))))))) + (cons spec (string-join path separator))))))) (filter-map search-path-definition search-paths)) -- cgit v1.3 From 88aab8e3499ef6b6cb63e736ce324bb7910f85dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 22:41:31 +0200 Subject: profiles: Use a &message error condition instead of 'error'. * guix/profiles.scm (sexp->manifest): Use 'raise' instead of 'error'. --- guix/profiles.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index fd2afc05a..8445e0076 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -278,7 +278,8 @@ procedure is here for backward-compatibility and will eventually vanish." search-paths)))) name version output path deps search-paths))) (_ - (error "unsupported manifest format" sexp)))) + (raise (condition + (&message (message "unsupported manifest format"))))))) (define (read-manifest port) "Return the packages listed in MANIFEST." -- cgit v1.3 From 954cea3ae6e7264b8d2f5139dceeeeb3f553abef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 May 2015 23:18:14 +0200 Subject: records: Make 'make-syntactic-constructor' available at load/eval/expand. * guix/records.scm (make-syntactic-constructor): Wrap in 'eval-when'. --- guix/records.scm | 190 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 97 insertions(+), 93 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index fd17e135e..db59a9905 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -42,102 +42,106 @@ (format #f fmt args ...) form)))) -(define* (make-syntactic-constructor type name ctor fields - #:key (thunked '()) (defaults '()) - (delayed '())) - "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects +(eval-when (expand load eval) + ;; This procedure is a syntactic helper used by 'define-record-type*', hence + ;; 'eval-when'. + + (define* (make-syntactic-constructor type name ctor fields + #:key (thunked '()) (defaults '()) + (delayed '())) + "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is the list of identifiers of delayed fields." - (with-syntax ((type type) - (name name) - (ctor ctor) - (expected fields) - (defaults defaults)) - #`(define-syntax name - (lambda (s) - (define (record-inheritance orig-record field+value) - ;; Produce code that returns a record identical to ORIG-RECORD, - ;; except that values for the FIELD+VALUE alist prevail. - (define (field-inherited-value f) - (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - field+value) - car)) - - ;; Make sure there are no unknown field names. - (let* ((fields (map (compose car syntax->datum) field+value)) - (unexpected (lset-difference eq? fields 'expected))) - (when (pair? unexpected) - (record-error 'name s "extraneous field initializers ~a" - unexpected))) - - #`(make-struct type 0 - #,@(map (lambda (field index) - (or (field-inherited-value field) - #`(struct-ref #,orig-record - #,index))) - 'expected - (iota (length 'expected))))) - - (define (thunked-field? f) - (memq (syntax->datum f) '#,thunked)) - - (define (delayed-field? f) - (memq (syntax->datum f) '#,delayed)) - - (define (wrap-field-value f value) - (cond ((thunked-field? f) - #`(lambda () #,value)) - ((delayed-field? f) - #`(delay #,value)) - (else value))) - - (define (field-bindings field+value) - ;; Return field to value bindings, for use in 'let*' below. - (map (lambda (field+value) - (syntax-case field+value () - ((field value) - #`(field - #,(wrap-field-value #'field #'value))))) - field+value)) - - (syntax-case s (inherit #,@fields) - ((_ (inherit orig-record) (field value) (... ...)) - #`(let* #,(field-bindings #'((field value) (... ...))) - #,(record-inheritance #'orig-record - #'((field value) (... ...))))) - ((_ (field value) (... ...)) - (let ((fields (map syntax->datum #'(field (... ...)))) - (dflt (map (match-lambda - ((f v) - (list (syntax->datum f) v))) - #'defaults))) - - (define (field-value f) - (or (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - #'((field value) (... ...))) - car) - (let ((value - (car (assoc-ref dflt (syntax->datum f))))) - (wrap-field-value f value)))) - - (let ((fields (append fields (map car dflt)))) - (cond ((lset= eq? fields 'expected) - #`(let* #,(field-bindings - #'((field value) (... ...))) - (ctor #,@(map field-value 'expected)))) - ((pair? (lset-difference eq? fields 'expected)) - (record-error 'name s - "extraneous field initializers ~a" - (lset-difference eq? fields - 'expected))) - (else - (record-error 'name s - "missing field initializers ~a" - (lset-difference eq? 'expected - fields)))))))))))) + (with-syntax ((type type) + (name name) + (ctor ctor) + (expected fields) + (defaults defaults)) + #`(define-syntax name + (lambda (s) + (define (record-inheritance orig-record field+value) + ;; Produce code that returns a record identical to ORIG-RECORD, + ;; except that values for the FIELD+VALUE alist prevail. + (define (field-inherited-value f) + (and=> (find (lambda (x) + (eq? f (car (syntax->datum x)))) + field+value) + car)) + + ;; Make sure there are no unknown field names. + (let* ((fields (map (compose car syntax->datum) field+value)) + (unexpected (lset-difference eq? fields 'expected))) + (when (pair? unexpected) + (record-error 'name s "extraneous field initializers ~a" + unexpected))) + + #`(make-struct type 0 + #,@(map (lambda (field index) + (or (field-inherited-value field) + #`(struct-ref #,orig-record + #,index))) + 'expected + (iota (length 'expected))))) + + (define (thunked-field? f) + (memq (syntax->datum f) '#,thunked)) + + (define (delayed-field? f) + (memq (syntax->datum f) '#,delayed)) + + (define (wrap-field-value f value) + (cond ((thunked-field? f) + #`(lambda () #,value)) + ((delayed-field? f) + #`(delay #,value)) + (else value))) + + (define (field-bindings field+value) + ;; Return field to value bindings, for use in 'let*' below. + (map (lambda (field+value) + (syntax-case field+value () + ((field value) + #`(field + #,(wrap-field-value #'field #'value))))) + field+value)) + + (syntax-case s (inherit #,@fields) + ((_ (inherit orig-record) (field value) (... ...)) + #`(let* #,(field-bindings #'((field value) (... ...))) + #,(record-inheritance #'orig-record + #'((field value) (... ...))))) + ((_ (field value) (... ...)) + (let ((fields (map syntax->datum #'(field (... ...)))) + (dflt (map (match-lambda + ((f v) + (list (syntax->datum f) v))) + #'defaults))) + + (define (field-value f) + (or (and=> (find (lambda (x) + (eq? f (car (syntax->datum x)))) + #'((field value) (... ...))) + car) + (let ((value + (car (assoc-ref dflt (syntax->datum f))))) + (wrap-field-value f value)))) + + (let ((fields (append fields (map car dflt)))) + (cond ((lset= eq? fields 'expected) + #`(let* #,(field-bindings + #'((field value) (... ...))) + (ctor #,@(map field-value 'expected)))) + ((pair? (lset-difference eq? fields 'expected)) + (record-error 'name s + "extraneous field initializers ~a" + (lset-difference eq? fields + 'expected))) + (else + (record-error 'name s + "missing field initializers ~a" + (lset-difference eq? 'expected + fields))))))))))))) (define-syntax define-record-type* (lambda (s) -- cgit v1.3 From 099a2c70558b1372a64cb53a646986469cf9ba47 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 May 2015 10:59:26 +0200 Subject: environment: Use (guix search-paths). * guix/scripts/environment.scm: Use (guix search-paths). Fixes a regression introduced in e89431b. --- guix/scripts/environment.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 80ae92441..b40750083 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -22,6 +22,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix search-paths) #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix build utils) -- cgit v1.3 From c4e8d513f2048bd7ca3b57c73c2b217a349e7b46 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 May 2015 13:46:20 +0200 Subject: gnu-maintenance: 'gnu-package?' returns #t for R and for GNOME packages. Reported by John Darrington. * guix/gnu-maintenance.scm (gnu-package?)[mirror-type]: Add "gnome" to the list of GNU mirrors. Return #f for "cran". --- guix/gnu-maintenance.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 0528e9f25..5cdda28bc 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -179,9 +179,18 @@ network to check in GNU's database." (define (mirror-type url) (let ((uri (string->uri url))) (and (eq? (uri-scheme uri) 'mirror) - (if (member (uri-host uri) '("gnu" "gnupg" "gcc")) - 'gnu - 'non-gnu)))) + (cond + ((member (uri-host uri) + '("gnu" "gnupg" "gcc" "gnome")) + ;; Definitely GNU. + 'gnu) + ((equal? (uri-host uri) "cran") + ;; Possibly GNU: mirror://cran could be either GNU R itself + ;; or a non-GNU package. + #f) + (else + ;; Definitely non-GNU. + 'non-gnu))))) (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) -- cgit v1.3 From 369149995cd4cedc59f1576a23c4df432e682402 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 May 2015 13:55:03 +0200 Subject: search-paths: 'evaluate-search-paths' can be passed a list of directories. * guix/search-paths.scm (evaluate-search-paths): Change 'directory' to 'directories', and adjust 'search-path-as-list' accordingly. * guix/scripts/package.scm (search-path-environment-variables): Adjust call accordingly. --- guix/scripts/package.scm | 3 ++- guix/search-paths.scm | 11 ++++++----- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7f53af772..15f3e13cc 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -389,7 +389,8 @@ current settings and report only settings not already effective." ;; TODO: Offer the choice between exact/prefix/suffix. (environment-variable-definition variable value #:separator sep)))) - (evaluate-search-paths search-paths profile getenv)))) + (evaluate-search-paths search-paths (list profile) + getenv)))) (define (display-search-paths entries profile) "Display the search path environment variables that may need to be set for diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 154e508d5..9dfad8916 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -114,11 +114,12 @@ like `string-tokenize', but SEPARATOR is a string." (else (reverse (cons string result)))))) -(define* (evaluate-search-paths search-paths directory +(define* (evaluate-search-paths search-paths directories #:optional (getenv (const #f))) - "Evaluate SEARCH-PATHS, a list of search-path specifications, for DIRECTORY, -and return a list of specification/value pairs. Use GETENV to determine the -current settings and report only settings not already effective." + "Evaluate SEARCH-PATHS, a list of search-path specifications, for +DIRECTORIES, a list of directory names, and return a list of +specification/value pairs. Use GETENV to determine the current settings and +report only settings not already effective." (define search-path-definition (match-lambda ((and spec @@ -137,7 +138,7 @@ current settings and report only settings not already effective." ;; directories (see ;; .) (path (with-null-error-port - (search-path-as-list files (list directory) + (search-path-as-list files directories #:type type #:pattern pattern)))) (if (every (cut member <> values) path) -- cgit v1.3 From fdfa753c69acb00e4d79ee82f8772bde3e1a6cd6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 May 2015 13:57:59 +0200 Subject: search-paths: Define the 'PATH' environment variable. * guix/search-paths.scm ($PATH): New variable. * guix/scripts/environment.scm (for-each-search-path): Use it. --- guix/scripts/environment.scm | 4 +--- guix/search-paths.scm | 9 +++++++++ 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index b40750083..36d7beb34 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -57,9 +57,7 @@ path value is appended." (if (and current (not pure?)) (string-append value separator current) value))))) - (cons* (search-path-specification - (variable "PATH") - (files '("bin" "sbin"))) + (cons* $PATH (delete-duplicates (append-map package-native-search-paths inputs)))))) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 9dfad8916..89af1e149 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -31,6 +31,8 @@ search-path-specification-file-type search-path-specification-file-pattern + $PATH + search-path-specification->sexp sexp->search-path-specification evaluate-search-paths @@ -58,6 +60,13 @@ (file-pattern search-path-specification-file-pattern ;#f | string (default #f))) +(define $PATH + ;; The 'PATH' variable. This variable is a bit special: it is not attached + ;; to any package in particular. + (search-path-specification + (variable "PATH") + (files '("bin" "sbin")))) + (define (search-path-specification->sexp spec) "Return an sexp representing SPEC, a . The sexp corresponds to the arguments expected by `set-path-environment-variable'." -- cgit v1.3 From b9ea6c6bf4948fd15876c915febad430e3177e42 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 May 2015 14:10:57 +0200 Subject: environment: Use 'evaluate-search-paths'. This allows 'guix environment' to correctly handle non-directory and/or pattern search-path specifications, such as that for 'XML_CATALOG_FILES'. * guix/scripts/environment.scm (for-each-search-path): Use 'evaluate-search-paths' instead of 'search-path-as-list' & co. --- guix/scripts/environment.scm | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 36d7beb34..cf402d367 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson +;;; Copyright © 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +26,6 @@ #:use-module (guix search-paths) #:use-module (guix utils) #:use-module (guix monads) - #:use-module (guix build utils) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (ice-9 format) @@ -41,25 +41,24 @@ Use the output paths of DERIVATIONS to build each search path. When PURE? is #t, the existing search path value is ignored. Otherwise, the existing search path value is appended." - (let ((paths (append-map (lambda (drv) - (map (match-lambda - ((_ . output) - (derivation-output-path output))) - (derivation-outputs drv))) - derivations))) + (let ((directories (append-map (lambda (drv) + (map (match-lambda + ((_ . output) + (derivation-output-path output))) + (derivation-outputs drv))) + derivations)) + (paths (cons $PATH + (delete-duplicates + (append-map package-native-search-paths + inputs))))) (for-each (match-lambda - (($ - variable directories separator) - (let* ((current (getenv variable)) - (path (search-path-as-list directories paths)) - (value (list->search-path-as-string path separator))) - (proc variable - (if (and current (not pure?)) - (string-append value separator current) - value))))) - (cons* $PATH - (delete-duplicates - (append-map package-native-search-paths inputs)))))) + ((($ variable _ sep) . value) + (let ((current (getenv variable))) + (proc variable + (if (and current (not pure?)) + (string-append value sep current) + value))))) + (evaluate-search-paths paths directories)))) ;; Protect some env vars from purification. Borrowed from nix-shell. (define %precious-variables -- cgit v1.3 From 8e3a3bc290cf5de266979fdf9abb87891de4f0ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 May 2015 15:02:35 +0200 Subject: environment: Move iteration outside of 'for-each-search-path'. * guix/search-paths.scm (search-path-definition): New procedure. * guix/scripts/environment.scm (for-each-search-path): Rename to... (evaluate-input-search-paths): ... this. Remove 'proc' and 'pure?' parameters, and return directly the list of search-path/value pairs. (create-environment): Use 'for-each' and 'evaluate-input-search-paths' instead of 'for-each-search-path'. (show-search-paths): Use 'for-each', 'search-path-definition', and 'evaluate-search-paths' instead of 'for-each-search-path'. --- guix/scripts/environment.scm | 36 +++++++++++++++++++----------------- guix/search-paths.scm | 15 +++++++++++++-- 2 files changed, 32 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index cf402d367..e81532c7e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -36,11 +36,9 @@ #:use-module (srfi srfi-98) #:export (guix-environment)) -(define (for-each-search-path proc inputs derivations pure?) - "Apply PROC for each native search path in INPUTS in addition to 'PATH'. -Use the output paths of DERIVATIONS to build each search path. When PURE? is -#t, the existing search path value is ignored. Otherwise, the existing search -path value is appended." +(define (evaluate-input-search-paths inputs derivations) + "Evaluate the native search paths of INPUTS, a list of packages, of the +outputs of DERIVATIONS, and return a list of search-path/value pairs." (let ((directories (append-map (lambda (drv) (map (match-lambda ((_ . output) @@ -51,14 +49,7 @@ path value is appended." (delete-duplicates (append-map package-native-search-paths inputs))))) - (for-each (match-lambda - ((($ variable _ sep) . value) - (let ((current (getenv variable))) - (proc variable - (if (and current (not pure?)) - (string-append value sep current) - value))))) - (evaluate-search-paths paths directories)))) + (evaluate-search-paths paths directories))) ;; Protect some env vars from purification. Borrowed from nix-shell. (define %precious-variables @@ -78,15 +69,26 @@ as 'HOME' and 'USER' are left untouched." PURE? is #t, unset the variables in the current environment. Otherwise, augment existing enviroment variables with additional search paths." (when pure? (purify-environment)) - (for-each-search-path setenv inputs derivations pure?)) + (for-each (match-lambda + ((($ variable _ separator) . value) + (let ((current (getenv variable))) + (setenv variable + (if (and current (not pure?)) + (string-append value separator current) + value))))) + (evaluate-input-search-paths inputs derivations))) (define (show-search-paths inputs derivations pure?) "Display the needed search paths to build an environment that contains the packages within INPUTS. When PURE? is #t, do not augment existing environment variables with additional search paths." - (for-each-search-path (lambda (variable value) - (format #t "export ~a=\"~a\"~%" variable value)) - inputs derivations pure?)) + (for-each (match-lambda + ((search-path . value) + (display + (search-path-definition search-path value + #:kind (if pure? 'exact 'prefix))) + (newline))) + (evaluate-input-search-paths inputs derivations))) (define (show-help) (display (_ "Usage: guix environment [OPTION]... PACKAGE... diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 89af1e149..ee7e9a131 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -36,7 +36,8 @@ search-path-specification->sexp sexp->search-path-specification evaluate-search-paths - environment-variable-definition)) + environment-variable-definition + search-path-definition)) ;;; Commentary: ;;; @@ -160,7 +161,7 @@ report only settings not already effective." #:key (kind 'exact) (separator ":")) - "Return a the definition of VARIABLE to VALUE in Bash syntax: + "Return a the definition of VARIABLE to VALUE in Bash syntax. KIND can be either 'exact (return the definition of VARIABLE=VALUE), 'prefix (return the definition where VALUE is added as a prefix to VARIABLE's @@ -178,4 +179,14 @@ prefix/suffix." (format #f "export ~a=\"$~a${~a:+~a}~a\"" variable variable variable separator value)))) +(define* (search-path-definition search-path value + #:key (kind 'exact)) + "Similar to 'environment-variable-definition', but applied to a +." + (match search-path + (($ variable _ separator) + (environment-variable-definition variable value + #:kind kind + #:separator separator)))) + ;;; search-paths.scm ends here -- cgit v1.3 From c822fb8e3467c86f47a93710761fff1a30e7195b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 May 2015 09:50:15 +0200 Subject: download: Reinstate buffering on connection sockets. * guix/build/download.scm (open-connection-for-uri): Reinstate call to 'setvbuf' inadvertently removed in d17551d9. --- guix/build/download.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 2e0b019d3..7b8e1aac3 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -218,6 +218,9 @@ host name without trailing dot." (thunk))))))) (with-https-proxy (let ((s (open-socket-for-uri uri))) + ;; Buffer input and output on this port. + (setvbuf s _IOFBF %http-receive-buffer-size) + (if https? (tls-wrap s (uri-host uri)) s))))) -- cgit v1.3 From 7623848343e02dc7505478aa5cc0ec2244e968c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 May 2015 10:31:11 +0200 Subject: download: Work around Guile small-receive-buffer bug. Previously, code using directly (guix build download) was still affected by . This includes source derivations, the 'guix download' command, and (guix gnu-maintenance). 'guix substitute' was unaffected since it used (guix http-client), which already had the fix. * guix/http-client.scm (open-socket-for-uri): Remove. (http-fetch): Remove #:buffered? argument to 'open-socket-for-uri'; use 'setvbuf' instead. * guix/scripts/substitute.scm (fetch): Likewise. * guix/build/download.scm (open-socket-for-uri): New procedure, taken from guix/http-client.scm, but without the #:buffered? parameter. --- guix/build/download.scm | 24 ++++++++++++++++++++++-- guix/http-client.scm | 35 ++++++++--------------------------- guix/scripts/substitute.scm | 4 +++- 3 files changed, 33 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 7b8e1aac3..65d18eb83 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -19,7 +19,7 @@ (define-module (guix build download) #:use-module (web uri) - #:use-module (web client) + #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) #:use-module (guix ftp-client) #:use-module (guix build utils) @@ -30,7 +30,8 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:export (open-connection-for-uri + #:export (open-socket-for-uri + open-connection-for-uri resolve-uri-reference maybe-expand-mirrors url-fetch @@ -195,6 +196,25 @@ host name without trailing dot." (add-weak-reference record port) record))) +(define (open-socket-for-uri uri) + "Return an open port for URI. This variant works around + which affects Guile's 'open-socket-for-uri' up to +2.0.11 included." + (define rmem-max + ;; The maximum size for a receive buffer on Linux, see socket(7). + "/proc/sys/net/core/rmem_max") + + (define buffer-size + (if (file-exists? rmem-max) + (call-with-input-file rmem-max read) + 126976)) ;the default for Linux, per 'rmem_default' + + (let ((s ((@ (web client) open-socket-for-uri) uri))) + ;; Work around by restoring a decent + ;; buffer size. + (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) + s)) + (define (open-connection-for-uri uri) "Like 'open-socket-for-uri', but also handle HTTPS connections." (define https? diff --git a/guix/http-client.scm b/guix/http-client.scm index 3bffbb1c2..90eca0a94 100644 --- a/guix/http-client.scm +++ b/guix/http-client.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 © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; @@ -21,7 +21,7 @@ (define-module (guix http-client) #:use-module (guix utils) #:use-module (web uri) - #:use-module (web client) + #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) @@ -30,14 +30,15 @@ #:use-module (rnrs bytevectors) #:use-module (guix ui) #:use-module (guix utils) - #:use-module ((guix build download) #:select (resolve-uri-reference)) + #:use-module ((guix build download) + #:select (open-socket-for-uri resolve-uri-reference)) + #:re-export (open-socket-for-uri) #:export (&http-get-error http-get-error? http-get-error-uri http-get-error-code http-get-error-reason - open-socket-for-uri http-fetch)) ;;; Commentary: @@ -207,26 +208,6 @@ closes PORT, unless KEEP-ALIVE? is true." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) -(define* (open-socket-for-uri uri #:key (buffered? #t)) - "Return an open port for URI. When BUFFERED? is false, the returned port is -unbuffered." - (define rmem-max - ;; The maximum size for a receive buffer on Linux, see socket(7). - "/proc/sys/net/core/rmem_max") - - (define buffer-size - (if (file-exists? rmem-max) - (call-with-input-file rmem-max read) - 126976)) ; the default for Linux, per 'rmem_default' - - (let ((s ((@ (web client) open-socket-for-uri) uri))) - ;; Work around by restoring a decent - ;; buffer size. - (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) - (unless buffered? - (setvbuf s _IONBF)) - s)) - (define* (http-fetch uri #:key port (text? #f) (buffered? #t)) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be @@ -235,9 +216,9 @@ unbuffered port, suitable for use in `filtered-port'. Raise an '&http-get-error' condition if downloading fails." (let loop ((uri uri)) - (let ((port (or port - (open-socket-for-uri uri - #:buffered? buffered?)))) + (let ((port (or port (open-socket-for-uri uri)))) + (unless buffered? + (setvbuf port _IONBF)) (let*-values (((resp data) ;; Try hard to use the API du jour to get an input port. ;; On Guile 2.0.5 and before, we can only get a string or diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ae97f74d2..31559b796 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -182,7 +182,9 @@ to the caller without emitting an error message." (close-port port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) + (set! port (open-socket-for-uri uri)) + (unless buffered? + (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port)))))))) (define-record-type -- cgit v1.3 From d838e7029854d8517c0c5b631f6042a925c86a81 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 May 2015 11:10:24 +0200 Subject: search-paths: Export 'string-tokenize*'. * guix/search-paths.scm (string-tokenize*): Export. * tests/utils.scm ("string-tokenize*"): Adjust accordingly. --- guix/search-paths.scm | 1 + tests/utils.scm | 10 +++++----- 2 files changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/search-paths.scm b/guix/search-paths.scm index ee7e9a131..7fd15d440 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -35,6 +35,7 @@ search-path-specification->sexp sexp->search-path-specification + string-tokenize* evaluate-search-paths environment-variable-definition search-path-definition)) diff --git a/tests/utils.scm b/tests/utils.scm index e03a07b2f..115868c85 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -21,6 +21,7 @@ #:use-module ((guix config) #:select (%gzip)) #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) + #:use-module ((guix search-paths) #:select (string-tokenize*)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) @@ -82,11 +83,10 @@ ("foo" "bar" "baz") ("foo" "bar" "") ("foo" "bar" "baz")) - (let ((string-tokenize* (@@ (guix search-paths) string-tokenize*))) - (list (string-tokenize* "foo" ":") - (string-tokenize* "foo;bar;baz" ";") - (string-tokenize* "foo!bar!" "!") - (string-tokenize* "foo+-+bar+-+baz" "+-+")))) + (list (string-tokenize* "foo" ":") + (string-tokenize* "foo;bar;baz" ";") + (string-tokenize* "foo!bar!" "!") + (string-tokenize* "foo+-+bar+-+baz" "+-+"))) (test-equal "string-replace-substring" '("foo BAR! baz" -- cgit v1.3 From 611adb1ee5814907694abc9afa1bad984f0cbea0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 May 2015 14:14:58 +0200 Subject: profiles: Move build code to (guix build profiles). * guix/build/profiles.scm: New file. * Makefile.am (MODULES): Add it. * guix/profiles.scm (profile-derivation)[builder]: Call out to 'build-profile'. Add (guix build profiles) to the #:modules argument. --- Makefile.am | 1 + guix/build/profiles.scm | 41 +++++++++++++++++++++++++++++++++++++++++ guix/profiles.scm | 13 +++++-------- 3 files changed, 47 insertions(+), 8 deletions(-) create mode 100644 guix/build/profiles.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index ae694eb0e..4fc1fc2ff 100644 --- a/Makefile.am +++ b/Makefile.am @@ -79,6 +79,7 @@ MODULES = \ guix/build/store-copy.scm \ guix/build/utils.scm \ guix/build/union.scm \ + guix/build/profiles.scm \ guix/build/pull.scm \ guix/build/rpath.scm \ guix/build/cvs.scm \ diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm new file mode 100644 index 000000000..1c5b54e40 --- /dev/null +++ b/guix/build/profiles.scm @@ -0,0 +1,41 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build profiles) + #:use-module (guix build union) + #:use-module (ice-9 pretty-print) + #:export (build-profile)) + +;;; Commentary: +;;; +;;; Build a user profile (essentially the union of all the installed packages) +;;; with its associated meta-data. +;;; +;;; Code: + +(define* (build-profile output inputs + #:key manifest) + "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an +sexp, to OUTPUT/manifest." + (union-build output inputs + #:log-port (%make-void-port "w")) + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print manifest p)))) + +;;; profile.scm ends here diff --git a/guix/profiles.scm b/guix/profiles.scm index 8445e0076..afc22e118 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -598,20 +598,17 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (define builder #~(begin - (use-modules (ice-9 pretty-print) - (guix build union)) + (use-modules (guix build profiles)) (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) - (union-build #$output '#$inputs - #:log-port (%make-void-port "w")) - (call-with-output-file (string-append #$output "/manifest") - (lambda (p) - (pretty-print '#$(manifest->gexp manifest) p))))) + (build-profile #$output '#$inputs + #:manifest '#$(manifest->gexp manifest)))) (gexp->derivation "profile" builder - #:modules '((guix build union)) + #:modules '((guix build union) + (guix build profiles)) #:local-build? #t))) (define (profile-regexp profile) -- cgit v1.3 From d664f1b431d2a64ff58ddc4ccce40e187947b960 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 May 2015 17:08:00 +0200 Subject: profiles: Generate an 'etc/profile' file. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Suggested by 宋文武 in . * guix/build/profiles.scm (abstract-profile, write-environment-variable-definition): New procedures. (build-profile): Add #:search-paths parameter. Create OUTPUT/etc/profile. * guix/profiles.scm (profile-derivation)[builder]: Add 'search-paths' variable and pass it to 'build-profile'. Adjust #:modules argument. * tests/profiles.scm ("etc/profile"): New test. * doc/guix.texi (Invoking guix package): Mention etc/profile. --- .dir-locals.el | 1 + doc/guix.texi | 10 ++++++++ guix/build/profiles.scm | 67 ++++++++++++++++++++++++++++++++++++++++++++++--- guix/profiles.scm | 21 +++++++++++++--- tests/profiles.scm | 26 +++++++++++++++++++ 5 files changed, 118 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 7aef85362..eb3da94da 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -14,6 +14,7 @@ ((indent-tabs-mode . nil) (eval . (put 'eval-when 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) + (eval . (put 'test-assertm 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) (eval . (put 'test-eq 'scheme-indent-function 1)) (eval . (put 'call-with-input-string 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 8241cb07b..1b1690a8e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -950,6 +950,16 @@ created in @file{$HOME/.guix-profile}. This symlink always points to the current generation of the user's default profile. Thus, users can add @file{$HOME/.guix-profile/bin} to their @code{PATH} environment variable, and so on. +@cindex search paths +If you are not using the Guix System Distribution, consider adding the +following lines to your @file{~/.bash_profile} (@pxref{Bash Startup +Files,,, bash, The GNU Bash Reference Manual}) so that newly-spawned +shells get all the right environment variable definitions: + +@example +GUIX_PROFILE="$HOME/.guix-profile" \ +source "$HOME/.guix-profile/etc/profile" +@end example In a multi-user setup, user profiles are stored in a place registered as a @dfn{garbage-collector root}, which @file{$HOME/.guix-profile} points diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 1c5b54e40..eda54cb37 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -18,6 +18,10 @@ (define-module (guix build profiles) #:use-module (guix build union) + #:use-module (guix build utils) + #:use-module (guix search-paths) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:export (build-profile)) @@ -28,14 +32,71 @@ ;;; ;;; Code: +(define (abstract-profile profile) + "Return a procedure that replaces PROFILE in VALUE with a reference to the +'GUIX_PROFILE' environment variable. This allows users to specify what the +user-friendly name of the profile is, for instance ~/.guix-profile rather than +/gnu/store/...-profile." + (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))) + (match-lambda + ((search-path . value) + (let* ((separator (search-path-specification-separator search-path)) + (items (string-tokenize* value separator)) + (crop (cute string-drop <> (string-length profile)))) + (cons search-path + (string-join (map (lambda (str) + (string-append replacement (crop str))) + items) + separator))))))) + +(define (write-environment-variable-definition port) + "Write the given environment variable definition to PORT." + (match-lambda + ((search-path . value) + (display (search-path-definition search-path value #:kind 'prefix) + port) + (newline port)))) + (define* (build-profile output inputs - #:key manifest) + #:key manifest search-paths) "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an -sexp, to OUTPUT/manifest." +sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for +all the variables listed in SEARCH-PATHS." + ;; Make the symlinks. (union-build output inputs #:log-port (%make-void-port "w")) + + ;; Store meta-data. (call-with-output-file (string-append output "/manifest") (lambda (p) - (pretty-print manifest p)))) + (pretty-print manifest p))) + + ;; Add a ready-to-use Bash profile. + (mkdir-p (string-append output "/etc")) + (call-with-output-file (string-append output "/etc/profile") + (lambda (port) + ;; The use of $GUIX_PROFILE described below is not great. Another + ;; option would have been to use "$1" and have users run: + ;; + ;; source ~/.guix-profile/etc/profile ~/.guix-profile + ;; + ;; However, when 'source' is used with no arguments, $1 refers to the + ;; first positional parameter of the calling scripts, so we can rely on + ;; it. + (display "\ +# Source this file to define all the relevant environment variables in Bash +# for this profile. You may want to define the 'GUIX_PROFILE' environment +# variable to point to the \"visible\" name of the profile, like this: +# +# GUIX_PROFILE=/path/to/profile +# source /path/to/profile/etc/profile +# +# When GUIX_PROFILE is undefined, the various environment variables refer +# to this specific profile generation. +\n" port) + (let ((variables (evaluate-search-paths (cons $PATH search-paths) + (list output)))) + (for-each (write-environment-variable-definition port) + (map (abstract-profile output) variables)))))) ;;; profile.scm ends here diff --git a/guix/profiles.scm b/guix/profiles.scm index afc22e118..11d9bf0cd 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -598,17 +598,30 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (define builder #~(begin - (use-modules (guix build profiles)) + (use-modules (guix build profiles) + (guix search-paths)) (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) + (define search-paths + ;; Search paths of MANIFEST's packages, converted back to their + ;; record form. + (map sexp->search-path-specification + '#$(map search-path-specification->sexp + (append-map manifest-entry-search-paths + (manifest-entries manifest))))) + (build-profile #$output '#$inputs - #:manifest '#$(manifest->gexp manifest)))) + #:manifest '#$(manifest->gexp manifest) + #:search-paths search-paths))) (gexp->derivation "profile" builder - #:modules '((guix build union) - (guix build profiles)) + #:modules '((guix build profiles) + (guix build union) + (guix build utils) + (guix search-paths) + (guix records)) #:local-build? #t))) (define (profile-regexp profile) diff --git a/tests/profiles.scm b/tests/profiles.scm index 890f09a75..a39717191 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -29,6 +29,8 @@ #:use-module ((gnu packages guile) #:prefix packages:) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 popen) + #:use-module (rnrs io ports) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) @@ -220,6 +222,30 @@ (manifest-entry-search-paths entry) (package-native-search-paths packages:guile-2.0))))))))) + +(test-assertm "etc/profile" + ;; Make sure we get an 'etc/profile' file that at least defines $PATH. + (mlet* %store-monad + ((guile -> (package + (inherit %bootstrap-guile) + (native-search-paths + (package-native-search-paths packages:guile-2.0)))) + (entry -> (package->manifest-entry guile)) + (drv (profile-derivation (manifest (list entry)) + #:hooks '())) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe + (string-append "source " + profile "/etc/profile; " + "unset GUIX_PROFILE; set"))) + (env (get-string-all pipe))) + (return + (and (zero? (close-pipe pipe)) + (string-contains env + (string-append "PATH=" profile "/bin")))))))) + (test-end "profiles") -- cgit v1.3 From a0dac7a01f766e75dc73200a889f31c3920a2d98 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 May 2015 15:39:45 +0200 Subject: profiles: Ensure the profile's etc/ directory is writable. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by 宋文武 . * guix/build/profiles.scm (build-etc/profile, ensure-writable-directory): New procedures. (build-profile): Use them. * tests/profiles.scm ("etc/profile when etc/ already exists"): New test. --- guix/build/profiles.scm | 74 +++++++++++++++++++++++++++++++++++++++---------- tests/profiles.scm | 29 +++++++++++++++++++ 2 files changed, 88 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index eda54cb37..525d59b97 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -21,6 +21,7 @@ #:use-module (guix build utils) #:use-module (guix search-paths) #:use-module (srfi srfi-26) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:export (build-profile)) @@ -57,21 +58,9 @@ user-friendly name of the profile is, for instance ~/.guix-profile rather than port) (newline port)))) -(define* (build-profile output inputs - #:key manifest search-paths) - "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an -sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for -all the variables listed in SEARCH-PATHS." - ;; Make the symlinks. - (union-build output inputs - #:log-port (%make-void-port "w")) - - ;; Store meta-data. - (call-with-output-file (string-append output "/manifest") - (lambda (p) - (pretty-print manifest p))) - - ;; Add a ready-to-use Bash profile. +(define (build-etc/profile output search-paths) + "Build the 'OUTPUT/etc/profile' shell file containing environment variable +definitions for all the SEARCH-PATHS." (mkdir-p (string-append output "/etc")) (call-with-output-file (string-append output "/etc/profile") (lambda (port) @@ -99,4 +88,59 @@ all the variables listed in SEARCH-PATHS." (for-each (write-environment-variable-definition port) (map (abstract-profile output) variables)))))) +(define (ensure-writable-directory directory) + "Ensure DIRECTORY exists and is writable. If DIRECTORY is currently a +symlink (to a read-only directory in the store), then delete the symlink and +instead make DIRECTORY a \"real\" directory containing symlinks." + (define (unsymlink link) + (let* ((target (readlink link)) + (files (scandir target + (negate (cut member <> '("." "..")))))) + (delete-file link) + (mkdir link) + (for-each (lambda (file) + (symlink (string-append target "/" file) + (string-append link "/" file))) + files))) + + (catch 'system-error + (lambda () + (mkdir directory)) + (lambda args + (let ((errno (system-error-errno args))) + (if (= errno EEXIST) + (let ((stat (lstat directory))) + (case (stat:type stat) + ((symlink) + ;; "Unsymlink" DIRECTORY so that it is writable. + (unsymlink directory)) + ((directory) + #t) + (else + (error "cannot mkdir because a same-named file exists" + directory)))) + (apply throw args)))))) + +(define* (build-profile output inputs + #:key manifest search-paths) + "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an +sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for +-all the variables listed in SEARCH-PATHS." + ;; Make the symlinks. + (union-build output inputs + #:log-port (%make-void-port "w")) + + ;; Store meta-data. + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print manifest p))) + + ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have + ;; made 'etc' a symlink to a read-only sub-directory in the store so we need + ;; to work around that. + (ensure-writable-directory (string-append output "/etc")) + + ;; Write 'OUTPUT/etc/profile'. + (build-etc/profile output search-paths)) + ;;; profile.scm ends here diff --git a/tests/profiles.scm b/tests/profiles.scm index de1411dca..ac7f28bf5 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -24,6 +24,7 @@ #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix build-system trivial) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages base) #:prefix packages:) #:use-module ((gnu packages guile) #:prefix packages:) @@ -248,6 +249,34 @@ (and (zero? (close-pipe pipe)) (string-contains path (string-append profile "/bin")))))))) +(test-assertm "etc/profile when etc/ already exists" + ;; Here 'union-build' makes the profile's etc/ a symlink to the package's + ;; etc/ directory, which makes it read-only. Make sure the profile build + ;; handles that. + (mlet* %store-monad + ((thing -> (dummy-package "dummy" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (mkdir (string-append out "/etc")) + (call-with-output-file (string-append out "/etc/foo") + (lambda (port) + (display "foo!" port)))))))) + (entry -> (package->manifest-entry thing)) + (drv (profile-derivation (manifest (list entry)) + #:hooks '())) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (and (file-exists? (string-append profile "/etc/profile")) + (string=? (call-with-input-file + (string-append profile "/etc/foo") + get-string-all) + "foo!")))))) + (test-end "profiles") -- cgit v1.3 From 09d809db6a37502b8cb2fb71748cc8bf500e117f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 May 2015 21:51:30 +0200 Subject: Remove assorted Guile 2.0.5 workarounds. * guix/scripts/authenticate.scm (%default-port-conversion-strategy): Remove. * guix/scripts/substitute.scm (fetch): Remove 2.0.5 special cases. * guix/serialization.scm (write-file): Remove 'scandir' workaround. * guix/ui.scm (command-files): Likewise. --- guix/scripts/authenticate.scm | 8 +------- guix/scripts/substitute.scm | 19 ++++--------------- guix/serialization.scm | 16 +++++----------- guix/ui.scm | 5 +---- 4 files changed, 11 insertions(+), 37 deletions(-) (limited to 'guix') diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index e9900689f..eedebb4ba 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,12 +82,6 @@ to stdout upon success." (leave (_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) -(define %default-port-conversion-strategy - ;; This fluid is in Guile > 2.0.5. - (if (defined? '%default-port-conversion-strategy) - (@ (guile) %default-port-conversion-strategy) - (make-fluid #f))) - ;;; ;;; Entry point with 'openssl'-compatible interface. We support this diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 31559b796..8b4fa36d2 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -157,15 +157,12 @@ to the caller without emitting an error message." (leave (_ "download from '~a' failed: ~a, ~s~%") (uri->string (http-get-error-uri c)) code (http-get-error-reason c)))))) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; ;; Test this with: ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: ;; sudo tc qdisc del dev eth0 root (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + (with-timeout (if timeout? %fetch-timeout 0) (begin @@ -649,17 +646,9 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;; XXX: We're not in control, so we always return anyway. n)) - ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done, - ;; don't pretend to report any progress in that case. - (if (guile-version>? "2.0.5") - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (cut close-port port)) - (begin - (format (current-error-port) (_ "Downloading, please wait...~%")) - (format (current-error-port) - (_ "(Please consider upgrading Guile to get proper progress report.)~%")) - port))) + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port))) (define-syntax with-networking (syntax-rules () diff --git a/guix/serialization.scm b/guix/serialization.scm index 51d7ef76c..7a3defc03 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -279,17 +279,11 @@ sub-directories of FILE as needed." (write-string "type" p) (write-string "directory" p) (let ((entries - ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories - ;; unconditionally, including "." and "..", regardless of the - ;; 'select?' predicate passed to it, so we have to filter - ;; those out externally. - (filter (negate (cut member <> '("." ".."))) - ;; 'scandir' defaults to 'string-locale '("." ".."))) string)) - ;; In Guile 2.0.5 `scandir' would return "." and ".." regardless even though - ;; they don't match `dot-scm?'. Work around it by doing additional - ;; filtering. (if directory - (filter dot-scm? (scandir directory dot-scm?)) + (scandir directory dot-scm?) '())) (define (commands) -- cgit v1.3 From 005c8fc6e0718f6e66ba19f4d21c056fea5c8aa3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 May 2015 21:51:12 +0200 Subject: http-client: Remove monkey patching for 2.0.5. * guix/http-client.scm (read-response-body*): Remove. (http-fetch): Remove hacks for 2.0.5. --- guix/http-client.scm | 58 ++++------------------------------------------------ 1 file changed, 4 insertions(+), 54 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 90eca0a94..dc8d3298f 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -175,33 +175,7 @@ closes PORT, unless KEEP-ALIVE? is true." ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more ;; than what 'content-length' says. See Guile commit 802a25b. (module-set! (resolve-module '(web response)) - 'make-delimited-input-port make-delimited-input-port)) - - (define (read-response-body* r) - "Reads the response body from @var{r}, as a bytevector. Returns - @code{#f} if there was no response body." - (define bad-response - (@@ (web response) bad-response)) - - (if (member '(chunked) (response-transfer-encoding r)) - (let ((chunk-port (make-chunked-input-port (response-port r) - #:keep-alive? #t))) - (get-bytevector-all chunk-port)) - (let ((nbytes (response-content-length r))) - ;; Backport of Guile commit 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 - ;; ("fix response-body-port for responses without content-length"). - (if nbytes - (let ((bv (get-bytevector-n (response-port r) nbytes))) - (if (= (bytevector-length bv) nbytes) - bv - (bad-response "EOF while reading response body: ~a bytes of ~a" - (bytevector-length bv) nbytes))) - (get-bytevector-all (response-port r)))))) - - ;; Install this patch only on Guile 2.0.5. - (unless (guile-version>? "2.0.5") - (module-set! (resolve-module '(web response)) - 'read-response-body read-response-body*))) + 'make-delimited-input-port make-delimited-input-port))) ;; XXX: Work around , present in Guile ;; up to 2.0.7. @@ -221,39 +195,15 @@ Raise an '&http-get-error' condition if downloading fails." (setvbuf port _IONBF)) (let*-values (((resp data) ;; Try hard to use the API du jour to get an input port. - ;; On Guile 2.0.5 and before, we can only get a string or - ;; bytevector, and not an input port. Work around that. (if (guile-version>? "2.0.7") (http-get uri #:streaming? #t #:port port) ; 2.0.9+ - (if (defined? 'http-get*) - (http-get* uri #:decode-body? text? - #:port port) ; 2.0.7 - (http-get uri #:decode-body? text? - #:port port)))) ; 2.0.5- + (http-get* uri #:decode-body? text? ; 2.0.7 + #:port port))) ((code) (response-code resp))) (case code ((200) - (let ((len (response-content-length resp))) - (cond ((not data) - (begin - ;; Guile 2.0.5 and earlier did not support chunked - ;; transfer encoding, which is required for instance when - ;; fetching %PACKAGE-LIST-URL (see - ;; ). - ;; Normally the `when-guile<=2.0.5' block above fixes - ;; that, but who knows what could happen. - (warning (_ "using Guile ~a, which does not support ~s encoding~%") - (version) - (response-transfer-encoding resp)) - (leave (_ "download failed; use a newer Guile~%") - uri resp))) - ((string? data) ; `http-get' from 2.0.5- - (values (open-input-string data) len)) - ((bytevector? data) ; likewise - (values (open-bytevector-input-port data) len)) - (else ; input port - (values data len))))) + (values data (response-content-length resp))) ((301 ; moved permanently 302) ; found (redirection) (let ((uri (resolve-uri-reference (response-location resp) uri))) -- cgit v1.3 From 5463fe512a02eb186ad95a1cae9d2682dbe2ccd0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 May 2015 11:41:55 +0200 Subject: publish: Add '--user' option. * guix/scripts/publish.scm (show-help): Add --user. (%options): Likewise. (run-publish-server): Change 'port' parameter to 'socket'. Pass #:socket instead of #:addr and #:port to 'run-server'. Update caller accordingly. (open-server-socket, gather-user-privileges): New procedures. (guix-publish): Use them. Force %PRIVATE-KEY and %PUBLIC-KEY early on. Warn when running as root. * doc/guix.texi (Invoking guix publish): Document --user. --- doc/guix.texi | 8 +++++- guix/scripts/publish.scm | 65 ++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 61 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 3a9f91e7d..8654e08b4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3657,7 +3657,8 @@ the @code{hydra.gnu.org} build farm. For security, each substitute is signed, allowing recipients to check their authenticity and integrity (@pxref{Substitutes}). Because @command{guix publish} uses the system's signing key, which is only -readable by the system administrator, it must run as root. +readable by the system administrator, it must be started as root; the +@code{--user} option makes it drop root privileges early on. The general syntax is: @@ -3686,6 +3687,11 @@ The following options are available: @itemx -p @var{port} Listen for HTTP requests on @var{port}. +@item --user=@var{user} +@itemx -u @var{user} +Change privileges to @var{user} as soon as possible---i.e., once the +server socket is open and the signing key has been read. + @item --repl[=@var{port}] @itemx -r [@var{port}] Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c7c66fefb..86d3a754f 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -51,6 +51,8 @@ Publish ~a over HTTP.\n") %store-directory) (display (_ " -p, --port=PORT listen on PORT")) (display (_ " + -u, --user=USER change privileges to USER as soon as possible")) + (display (_ " -r, --repl[=PORT] spawn REPL server on PORT")) (newline) (display (_ " @@ -68,6 +70,9 @@ Publish ~a over HTTP.\n") %store-directory) (option '(#\V "version") #f #f (lambda _ (show-version-and-exit "guix publish"))) + (option '(#\u "user") #t #f + (lambda (opt name arg result) + (alist-cons 'user arg result))) (option '(#\p "port") #t #f (lambda (opt name arg result) (alist-cons 'port (string->number* arg) result))) @@ -220,24 +225,62 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (_ (not-found request))) (not-found request)))) -(define (run-publish-server port store) +(define (run-publish-server socket store) (run-server (make-request-handler store) 'http - `(#:addr ,INADDR_ANY - #:port ,port))) + `(#:socket ,socket))) + +(define (open-server-socket addr port) + "Return a TCP socket bound to ADDR and PORT." + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock AF_INET addr port) + sock)) + +(define (gather-user-privileges user) + "Switch to the identity of USER, a user name." + (catch 'misc-error + (lambda () + (let ((user (getpw user))) + (setgroups #()) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)))) + (lambda (key proc message args . rest) + (leave (_ "user '~a' not found: ~a~%") + user (apply format #f message args))))) + + +;;; +;;; Entry point. +;;; (define (guix-publish . args) (with-error-handling - (let* ((opts (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: extraneuous argument~%") arg)) - %default-options)) - (port (assoc-ref opts 'port)) + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneuous argument~%") arg)) + %default-options)) + (port (assoc-ref opts 'port)) + (user (assoc-ref opts 'user)) + (socket (open-server-socket INADDR_ANY port)) (repl-port (assoc-ref opts 'repl))) + ;; Read the key right away so that (1) we fail early on if we can't + ;; access them, and (2) we can then drop privileges. + (force %private-key) + (force %public-key) + + (when user + ;; Now that we've read the key material and opened the socket, we can + ;; drop privileges. + (gather-user-privileges user)) + + (when (zero? (getuid)) + (warning (_ "server running as root; \ +consider using the '--user' option!~%"))) (format #t (_ "publishing ~a on port ~d~%") %store-directory port) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server (assoc-ref opts 'port) store))))) + (run-publish-server socket store))))) -- cgit v1.3 From 9e2292ef3d9e2626381f9726c72d71057160b7c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 May 2015 21:20:19 +0200 Subject: publish: Add '--listen'. * guix/scripts/publish.scm (show-help, %options): Add --listen. (getaddrinfo*): New procedure. (%default-options): Add 'address'. (open-server-socket): Replace 'addr' and 'port' with 'address', a sockaddr. (guix-publish): Adjust accordingly. Augment "publishing" message with the actual address. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 4 ++++ guix/scripts/publish.scm | 58 +++++++++++++++++++++++++++++++++++------------- 2 files changed, 47 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 8654e08b4..50d51c6c6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3687,6 +3687,10 @@ The following options are available: @itemx -p @var{port} Listen for HTTP requests on @var{port}. +@item --listen=@var{host} +Listen on the network interface for @var{host}. The default is to +accept connections from any interface. + @item --user=@var{user} @itemx -u @var{user} Change privileges to @var{user} as soon as possible---i.e., once the diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 86d3a754f..7bad2619b 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -50,6 +50,8 @@ Publish ~a over HTTP.\n") %store-directory) (display (_ " -p, --port=PORT listen on PORT")) + (display (_ " + --listen=HOST listen on the network interface for HOST")) (display (_ " -u, --user=USER change privileges to USER as soon as possible")) (display (_ " @@ -62,6 +64,15 @@ Publish ~a over HTTP.\n") %store-directory) (newline) (show-bug-report-information)) +(define (getaddrinfo* host) + "Like 'getaddrinfo', but properly report errors." + (catch 'getaddrinfo-error + (lambda () + (getaddrinfo host)) + (lambda (key error) + (leave (_ "lookup of host '~a' failed: ~a~%") + host (gai-strerror error))))) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -76,6 +87,15 @@ Publish ~a over HTTP.\n") %store-directory) (option '(#\p "port") #t #f (lambda (opt name arg result) (alist-cons 'port (string->number* arg) result))) + (option '("listen") #t #f + (lambda (opt name arg result) + (match (getaddrinfo* arg) + ((info _ ...) + (alist-cons 'address (addrinfo:addr info) + result)) + (() + (leave (_ "lookup of host '~a' returned nothing") + name))))) (option '(#\r "repl") #f #t (lambda (opt name arg result) ;; If port unspecified, use default Guile REPL port. @@ -83,7 +103,8 @@ Publish ~a over HTTP.\n") %store-directory) (alist-cons 'repl (or port 37146) result)))))) (define %default-options - '((port . 8080) + `((port . 8080) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) (define (lazy-read-file-sexp file) @@ -230,11 +251,11 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." 'http `(#:socket ,socket))) -(define (open-server-socket addr port) - "Return a TCP socket bound to ADDR and PORT." - (let ((sock (socket PF_INET SOCK_STREAM 0))) +(define (open-server-socket address) + "Return a TCP socket bound to ADDRESS, a socket address." + (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0))) (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock AF_INET addr port) + (bind sock address) sock)) (define (gather-user-privileges user) @@ -256,15 +277,19 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define (guix-publish . args) (with-error-handling - (let* ((opts (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: extraneuous argument~%") arg)) - %default-options)) - (port (assoc-ref opts 'port)) - (user (assoc-ref opts 'user)) - (socket (open-server-socket INADDR_ANY port)) + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneuous argument~%") arg)) + %default-options)) + (user (assoc-ref opts 'user)) + (port (assoc-ref opts 'port)) + (address (let ((addr (assoc-ref opts 'address))) + (make-socket-address (sockaddr:fam addr) + (sockaddr:addr addr) + port))) + (socket (open-server-socket address)) (repl-port (assoc-ref opts 'repl))) ;; Read the key right away so that (1) we fail early on if we can't ;; access them, and (2) we can then drop privileges. @@ -279,7 +304,10 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (when (zero? (getuid)) (warning (_ "server running as root; \ consider using the '--user' option!~%"))) - (format #t (_ "publishing ~a on port ~d~%") %store-directory port) + (format #t (_ "publishing ~a on ~a, port ~d~%") + %store-directory + (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) + (sockaddr:port address)) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store -- cgit v1.3 From 6944fdbdbd2339ee66f30e416806da9c7e8b6e01 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 17 May 2015 23:20:59 +0200 Subject: syscalls: Add 'set-network-interface-up'. * guix/build/syscalls.scm (set-network-interface-up): New procedure. --- guix/build/syscalls.scm | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index b62a8cce6..5bc4595d0 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,6 +46,7 @@ network-interface-address set-network-interface-flags set-network-interface-address + set-network-interface-up configure-network-interface)) ;;; Commentary: @@ -552,4 +553,17 @@ the same type as that returned by 'make-socket-address'." (lambda () (close-port sock))))) +(define* (set-network-interface-up name + #:key (family AF_INET)) + "Turn up the interface NAME." + (let ((sock (socket family SOCK_STREAM 0))) + (dynamic-wind + (const #t) + (lambda () + (let ((flags (network-interface-flags sock name))) + (set-network-interface-flags sock name + (logior flags IFF_UP)))) + (lambda () + (close-port sock))))) + ;;; syscalls.scm ends here -- cgit v1.3 From 113c17a0c969e600023698ae3a34994a796d0046 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 May 2015 09:47:29 +0200 Subject: profiles: Gracefully deal with packages containing an etc/ symlink. This fixes a bug whereby 'guix package -i gcc-toolchain' would fail in 'build-profile'. This is because in 'gcc-toolchain', etc/ is a symlink, and so the 'scandir' call in 'unsymlink' would return #f instead of returning a list. Reported by Andreas Enge . * guix/build/profiles.scm (ensure-writable-directory)[unsymlink]: Append "/" to TARGET before calling 'scandir'. * tests/profiles.scm ("etc/profile when etc/ is a symlink"): New test. --- guix/build/profiles.scm | 4 +++- tests/profiles.scm | 28 ++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 525d59b97..2becc6b9a 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -94,7 +94,9 @@ symlink (to a read-only directory in the store), then delete the symlink and instead make DIRECTORY a \"real\" directory containing symlinks." (define (unsymlink link) (let* ((target (readlink link)) - (files (scandir target + ;; TARGET might itself be a symlink, so append "/" to make sure + ;; 'scandir' enters it. + (files (scandir (string-append target "/") (negate (cut member <> '("." "..")))))) (delete-file link) (mkdir link) diff --git a/tests/profiles.scm b/tests/profiles.scm index ac7f28bf5..cc9a822ce 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -277,6 +277,34 @@ get-string-all) "foo!")))))) +(test-assertm "etc/profile when etc/ is a symlink" + ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail + ;; gracelessly because 'scandir' would return #f. + (mlet* %store-monad + ((thing -> (dummy-package "dummy" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (mkdir (string-append out "/foo")) + (symlink "foo" (string-append out "/etc")) + (call-with-output-file (string-append out "/etc/bar") + (lambda (port) + (display "foo!" port)))))))) + (entry -> (package->manifest-entry thing)) + (drv (profile-derivation (manifest (list entry)) + #:hooks '())) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (and (file-exists? (string-append profile "/etc/profile")) + (string=? (call-with-input-file + (string-append profile "/etc/bar") + get-string-all) + "foo!")))))) + (test-end "profiles") -- cgit v1.3 From e3fd0ce6969a62665a1eaedccebb6b21ced1e86f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 19 May 2015 09:35:52 +0200 Subject: store: Add 'optimize-store' RPC. * guix/store.scm (operation-id): Add 'optimize-store'. (optimize-store): New procedure. --- guix/store.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 10b9062db..fc2f8d92c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -90,6 +90,7 @@ references requisites referrers + optimize-store topologically-sorted valid-derivers query-derivation-outputs @@ -171,7 +172,8 @@ (query-substitutable-path-infos 30) (query-valid-paths 31) (query-substitutable-paths 32) - (query-valid-derivers 33)) + (query-valid-derivers 33) + (optimize-store 34)) (define-enumerate-type hash-algo ;; hash.hh @@ -760,6 +762,12 @@ substitutable. For each substitutable path, a `substitutable?' object is returned." substitutable-path-list)) +(define-operation (optimize-store) + "Optimize the store by hard-linking identical files (\"deduplication\".) +Return #t on success." + ;; Note: the daemon in Guix <= 0.8.2 does not implement this RPC. + boolean) + (define (run-gc server action to-delete min-freed) "Perform the garbage-collector operation ACTION, one of the `gc-action' values. When ACTION is `delete-specific', the TO-DELETE is -- cgit v1.3 From 38d27786086ff2b8d1325b1c0090ccff3745adfc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 19 May 2015 09:59:45 +0200 Subject: guix gc: Add '--optimize'. * guix/scripts/gc.scm (show-help, %options): Add --optimize. (guix-gc): Handle it. --- doc/guix.texi | 11 +++++++++++ guix/scripts/gc.scm | 10 +++++++++- 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 91c86dc30..0d2a01f75 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1472,6 +1472,17 @@ Attempt to delete all the store files and directories specified as arguments. This fails if some of the files are not in the store, or if they are still live. +@item --optimize +@cindex deduplication +Optimize the store by hard-linking identical files---this is +@dfn{deduplication}. + +The daemon performs deduplication after each successful build or archive +import, unless it was started with @code{--disable-deduplication} +(@pxref{Invoking guix-daemon, @code{--disable-deduplication}}). Thus, +this option is primarily useful when the daemon was running with +@code{--disable-deduplication}. + @item --list-dead Show the list of dead files and directories still present in the store---i.e., files and directories no longer reachable from any root. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index ed16cab8f..4bae65a1e 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +43,8 @@ Invoke the garbage collector.\n")) collect at least MIN bytes of garbage")) (display (_ " -d, --delete attempt to delete PATHS")) + (display (_ " + --optimize optimize the store by deduplicating identical files")) (display (_ " --list-dead list dead paths")) (display (_ " @@ -88,6 +90,10 @@ Invoke the garbage collector.\n")) (lambda (opt name arg result) (alist-cons 'action 'delete (alist-delete 'action result)))) + (option '("optimize") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'optimize + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -169,6 +175,8 @@ Invoke the garbage collector.\n")) (list-relatives requisites)) ((list-referrers) (list-relatives referrers)) + ((optimize) + (optimize-store store)) ((list-dead) (for-each (cut simple-format #t "~a~%" <>) (dead-paths store))) -- cgit v1.3 From 755e1147aa33d1c305bb9db6c5e03cf1063079fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 May 2015 11:12:34 +0200 Subject: guix package: --search-paths mentions $PATH. * guix/scripts/package.scm (search-path-environment-variables): Add $PATH to SEARCH-PATHS. --- guix/scripts/package.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 15f3e13cc..300af681c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -381,7 +381,9 @@ an output path different than CURRENT-PATH." ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the current settings and report only settings not already effective." (let ((search-paths (delete-duplicates - (append-map manifest-entry-search-paths entries)))) + (cons $PATH + (append-map manifest-entry-search-paths + entries))))) (filter-map (match-lambda ((spec . value) (let ((variable (search-path-specification-variable spec)) -- cgit v1.3 From dbc31ab25c355eae373e1766b4a77fccbe462bf3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 May 2015 11:52:45 +0200 Subject: guix package: Add optional argument to --search-paths. * guix/scripts/package.scm (search-path-environment-variables): Add #:kind parameter. Pass it to 'environment-variable-definition'. (display-search-paths): Add #:kind parameter and pass it to 'search-path-environment-variables'. (%options): Add an optional parameter for "--search-paths". (guix-package)[process-query]: Handle it. * tests/guix-package-net.sh: Adjust existing test. * tests/guix-package.sh: Adjust existing tests and add new test. * doc/guix.texi (Invoking guix package): Document it. --- doc/guix.texi | 14 +++++++++++++- guix/scripts/package.scm | 38 +++++++++++++++++++++++++++----------- tests/guix-package-net.sh | 2 +- tests/guix-package.sh | 9 +++++++-- 4 files changed, 48 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 8e1bdb6f9..53c9fb2d4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1098,7 +1098,7 @@ The difference between @code{--roll-back} and not make a zeroth generation, so if a specified generation does not exist, the current generation will not be changed. -@item --search-paths +@item --search-paths[=@var{kind}] @cindex search paths Report environment variable definitions, in Bash syntax, that may be needed in order to use the set of installed packages. These environment @@ -1113,6 +1113,18 @@ library are installed in the profile, then @code{--search-paths} will suggest setting these variables to @code{@var{profile}/include} and @code{@var{profile}/lib}, respectively. +The typical use case is to define these environment variables in the +shell: + +@example +$ eval `guix package --search-paths` +@end example + +@var{kind} may be one of @code{exact}, @code{prefix}, or @code{suffix}, +meaning that the returned environment variable definitions will either +be exact settings, or prefixes or suffixes of the current value of these +variables. When omitted, @var{kind} defaults to @code{exact}. + @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 300af681c..d6d7c66cf 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -376,10 +376,13 @@ an output path different than CURRENT-PATH." ;;; (define* (search-path-environment-variables entries profile - #:optional (getenv getenv)) + #:optional (getenv getenv) + #:key (kind 'exact)) "Return environment variable definitions that may be needed for the use of ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the -current settings and report only settings not already effective." +current settings and report only settings not already effective. KIND +must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search +path definition to be returned." (let ((search-paths (delete-duplicates (cons $PATH (append-map manifest-entry-search-paths @@ -388,17 +391,19 @@ current settings and report only settings not already effective." ((spec . value) (let ((variable (search-path-specification-variable spec)) (sep (search-path-specification-separator spec))) - ;; TODO: Offer the choice between exact/prefix/suffix. (environment-variable-definition variable value - #:separator sep)))) + #:separator sep + #:kind kind)))) (evaluate-search-paths search-paths (list profile) getenv)))) -(define (display-search-paths entries profile) +(define* (display-search-paths entries profile + #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." (let* ((profile (user-friendly-profile profile)) - (settings (search-path-environment-variables entries profile))) + (settings (search-path-environment-variables entries profile + #:kind kind))) (unless (null? settings) (format #t (_ "The following environment variable definitions may be needed:~%")) (format #t "~{ ~a~%~}" settings)))) @@ -533,10 +538,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (lambda (opt name arg result arg-handler) (values (alist-cons 'switch-generation arg result) #f))) - (option '("search-paths") #f #f + (option '("search-paths") #f #t (lambda (opt name arg result arg-handler) - (values (cons `(query search-paths) result) - #f))) + (let ((kind (match arg + ((or "exact" "prefix" "suffix") + (string->symbol arg)) + (#f + 'exact) + (x + (leave (_ "~a: unsupported \ +kind of search path~%") + x))))) + (values (cons `(query search-paths ,kind) + result) + #f)))) (option '(#\p "profile") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'profile (canonicalize-profile arg) @@ -977,12 +992,13 @@ more information.~%")) (find-packages-by-name name version))) #t)) - (('search-paths) + (('search-paths kind) (let* ((manifest (profile-manifest profile)) (entries (manifest-entries manifest)) (profile (user-friendly-profile profile)) (settings (search-path-environment-variables entries profile - (const #f)))) + (const #f) + #:kind kind))) (format #t "~{~a~%~}" settings) #t)) diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index cf3233bee..14222cfd2 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -147,7 +147,7 @@ test "`readlink_base "$profile"`" = "$profile-2-link" # Make sure LIBRARY_PATH gets listed by `--search-paths'. guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap -guix package --search-paths -p "$profile" | grep LIBRARY_PATH +guix package -p "$profile" --search-paths | grep LIBRARY_PATH # Roll back so we can delete #3 below. guix package -p "$profile" --switch-generation=2 diff --git a/tests/guix-package.sh b/tests/guix-package.sh index a732110d5..d420b8076 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -52,8 +52,13 @@ test -L "$profile" && test -L "$profile-1-link" test -f "$profile/bin/guile" # No search path env. var. here. -guix package --search-paths -p "$profile" -test "`guix package --search-paths -p "$profile" | wc -l`" = 0 +guix package -p "$profile" --search-paths +guix package -p "$profile" --search-paths | grep '^export PATH=' +test "`guix package -p "$profile" --search-paths | wc -l`" = 1 # $PATH +( set -e; set -x; \ + eval `guix package --search-paths=prefix -p "$PWD/$profile"`; \ + test "`type -P guile`" = "$PWD/$profile/bin/guile" ; \ + type -P rm ) # Exit with 1 when a generation does not exist. if guix package -p "$profile" --delete-generations=42; -- cgit v1.3 From 820a40327dfd075f03c8cbe336f955f45e3e60ef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 May 2015 12:00:04 +0200 Subject: ftp-client: Throw when log-in fails. * guix/ftp-client.scm (ftp-open): When '%ftp-listen' returns something different from 220, throw instead of writing an error message. --- guix/ftp-client.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index ab72405df..37feb895a 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -109,11 +109,8 @@ or a TCP port number), and return it." (%ftp-login "anonymous" "guix@example.com" s) (%make-ftp-connection s ai)) (begin - (format (current-error-port) - "FTP to `~a' failed: ~A: ~A~%" - host code message) (close s) - #f)))) + (throw 'ftp-error s "log-in" code message))))) (lambda args ;; Connection failed, so try one of the other addresses. -- cgit v1.3 From 7ea1432e22b42969ff0d078e68f5cb55a75b1aca Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 18 May 2015 07:49:44 -0400 Subject: ui: Factorize user-provided Scheme file loading. * guix/ui.scm (make-user-module, load*): New procedures. * guix/scripts/system.scm (%user-module): Define in terms of 'make-user-module'. (read-operating-system): Define in terms of load*'. --- guix/scripts/system.scm | 22 ++++------------------ guix/ui.scm | 24 ++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1838e8945..459b2da0c 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -48,28 +48,14 @@ (define %user-module ;; Module in which the machine description file is loaded. - (let ((module (make-fresh-user-module))) - (for-each (lambda (iface) - (module-use! module (resolve-interface iface))) - '((gnu system) - (gnu services) - (gnu system shadow))) - module)) + (make-user-module '((gnu system) + (gnu services) + (gnu system shadow)))) (define (read-operating-system file) "Read the operating-system declaration from FILE and return it." - ;; TODO: Factorize. - (catch #t - (lambda () - ;; Avoid ABI incompatibility with the record. - (set! %fresh-auto-compile #t) + (load* file %user-module)) - (save-module-excursion - (lambda () - (set-current-module %user-module) - (primitive-load file)))) - (lambda args - (report-load-error file args)))) ;;; diff --git a/guix/ui.scm b/guix/ui.scm index 911e5ee86..920355fbb 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -48,6 +48,8 @@ P_ report-error leave + make-user-module + load* report-load-error warn-about-load-error show-version-and-exit @@ -133,6 +135,28 @@ messages." (report-error args ...) (exit 1))) +(define (make-user-module modules) + "Return a new user module with the additional MODULES loaded." + ;; Module in which the machine description file is loaded. + (let ((module (make-fresh-user-module))) + (for-each (lambda (iface) + (module-use! module (resolve-interface iface))) + modules) + module)) + +(define (load* file user-module) + "Load the user provided Scheme source code FILE." + (catch #t + (lambda () + (set! %fresh-auto-compile #t) + + (save-module-excursion + (lambda () + (set-current-module user-module) + (primitive-load file)))) + (lambda args + (report-load-error file args)))) + (define (report-load-error file args) "Report the failure to load FILE, a user-provided Scheme file, and exit. ARGS is the list of arguments received by the 'throw' handler." -- cgit v1.3 From 8404ed5c3e3a36958dc0427531b21ae14b6398aa Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 18 May 2015 07:51:56 -0400 Subject: profiles: Add 'packages->manifest' procedure. * guix/profiles.scm (packages->manifest): New procedure. --- guix/profiles.scm | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 11d9bf0cd..9cb226eda 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -80,6 +80,7 @@ profile-manifest package->manifest-entry + packages->manifest %default-profile-hooks profile-derivation generation-number @@ -172,6 +173,18 @@ omitted or #f, use the first output of PACKAGE." (dependencies (delete-duplicates deps)) (search-paths (package-native-search-paths package))))) +(define (packages->manifest packages) + "Return a list of manifest entries, one for each item listed in PACKAGES. +Elements of PACKAGES can be either package objects or package/string tuples +denoting a specific output of a package." + (manifest + (map (match-lambda + ((package output) + (package->manifest-entry package output)) + (package + (package->manifest-entry package))) + packages))) + (define (manifest->gexp manifest) "Return a representation of MANIFEST as a gexp." (define (entry->gexp entry) @@ -469,7 +482,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) (define build - #~(begin + #~(begin (use-modules (guix build utils) (srfi srfi-1) (srfi srfi-26) (ice-9 ftw)) @@ -478,20 +491,20 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (let* ((base (basename #+ghc))) (string-drop base (+ 1 (string-index base #\-))))) - + (define db-subdir (string-append "lib/" ghc-name-version "/package.conf.d")) (define db-dir (string-append #$output "/" db-subdir)) - + (define (conf-files top) (find-files (string-append top "/" db-subdir) "\\.conf$")) (define (copy-conf-file conf) (let ((base (basename conf))) (copy-file conf (string-append db-dir "/" base)))) - + (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) (for-each copy-conf-file (append-map conf-files -- cgit v1.3 From 1b6764477fda1a71f0ed377546f49adf2e36e5cb Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 14 May 2015 21:11:57 -0400 Subject: package: Add --manifest option. * guix/scripts/package.scm (show-help): Add help text. (%options): Add manifest option. (guix-package): Add manifest option handler. * doc/guix.texi ("Invoking guix package"): Document it. * tests/guix-package.sh: Add test. --- doc/guix.texi | 17 ++++++++ guix/scripts/package.scm | 107 ++++++++++++++++++++++++++++------------------- tests/guix-package.sh | 12 ++++++ 3 files changed, 92 insertions(+), 44 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 53c9fb2d4..9b2e367d0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1068,6 +1068,23 @@ substring ``emacs'': $ guix package --upgrade . --do-not-upgrade emacs @end example +@item --manifest=@var{file} +@itemx -m @var{file} +Create a new @dfn{generation} of the profile from the manifest object +returned by the Scheme code in @var{file}. + +A manifest file may look like this: + +@example +(use-package-modules guile emacs gcc) + +(packages->manifest + (list guile-2.0 + emacs + ;; Use a specific package output. + (list gcc "debug"))) +@end example + @item --roll-back Roll back to the previous @dfn{generation} of the profile---i.e., undo the last transaction. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d6d7c66cf..125173406 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -432,6 +432,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -r, --remove=PACKAGE remove PACKAGE")) (display (_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) + (display (_ " + -m, --manifest=FILE create a new profile generation with the manifest + from FILE")) (display (_ " --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) (display (_ " @@ -524,6 +527,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (lambda (opt name arg result arg-handler) (values (alist-cons 'roll-back? #t result) #f))) + (option '(#\m "manifest") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'manifest arg result) + arg-handler))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result arg-handler) (values (cons `(query list-generations ,(or arg "")) @@ -800,6 +807,50 @@ more information.~%")) (define dry-run? (assoc-ref opts 'dry-run?)) (define profile (assoc-ref opts 'profile)) + (define (build-and-use-profile manifest) + (let* ((bootstrap? (assoc-ref opts 'bootstrap?))) + + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (let* ((prof-drv (run-with-store (%store) + (profile-derivation + manifest + #:hooks (if bootstrap? + '() + %default-profile-hooks)))) + (prof (derivation->output-path prof-drv))) + (show-what-to-build (%store) (list prof-drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + + (cond + (dry-run? #t) + ((and (file-exists? profile) + (and=> (readlink* profile) (cut string=? prof <>))) + (format (current-error-port) (_ "nothing to be done~%"))) + (else + (let* ((number (generation-number profile)) + + ;; Always use NUMBER + 1 for the new profile, + ;; possibly overwriting a "previous future + ;; generation". + (name (generation-file-name profile + (+ 1 number)))) + (and (build-derivations (%store) (list prof-drv)) + (let* ((entries (manifest-entries manifest)) + (count (length entries))) + (switch-symlinks name prof) + (switch-symlinks profile name) + (unless (string=? profile %current-profile) + (register-gc-root (%store) name)) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count) + (display-search-paths entries profile))))))))) + ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) @@ -834,60 +885,28 @@ more information.~%")) (alist-delete 'delete-generations opts))) (_ #f)) opts)) + ((and (assoc-ref opts 'manifest) + (not dry-run?)) + (let* ((file-name (assoc-ref opts 'manifest)) + (user-module (make-user-module '((guix profiles) + (gnu)))) + (manifest (load* file-name user-module))) + (format #t (_ "installing new manifest from ~a with ~d entries.~%") + file-name (length (manifest-entries manifest))) + (build-and-use-profile manifest))) (else (let* ((manifest (profile-manifest profile)) (install (options->installable opts manifest)) (remove (options->removable opts manifest)) - (bootstrap? (assoc-ref opts 'bootstrap?)) (transaction (manifest-transaction (install install) (remove remove))) (new (manifest-perform-transaction manifest transaction))) - (when (equal? profile %current-profile) - (ensure-default-profile)) - (unless (and (null? install) (null? remove)) - (let* ((prof-drv (run-with-store (%store) - (profile-derivation - new - #:hooks (if bootstrap? - '() - %default-profile-hooks)))) - (prof (derivation->output-path prof-drv))) - (show-manifest-transaction (%store) manifest transaction - #:dry-run? dry-run?) - (show-what-to-build (%store) (list prof-drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - - (cond - (dry-run? #t) - ((and (file-exists? profile) - (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) - (else - (let* ((number (generation-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (generation-file-name profile - (+ 1 number)))) - (and (build-derivations (%store) (list prof-drv)) - (let* ((entries (manifest-entries new)) - (count (length entries))) - (switch-symlinks name prof) - (switch-symlinks profile name) - (unless (string=? profile %current-profile) - (register-gc-root (%store) name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) - (display-search-paths entries - profile)))))))))))) + (show-manifest-transaction (%store) manifest transaction + #:dry-run? dry-run?) + (build-and-use-profile new)))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was diff --git a/tests/guix-package.sh b/tests/guix-package.sh index d420b8076..26a5e9d1a 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -242,3 +242,15 @@ export GUIX_BUILD_OPTIONS available2="`guix package -A | sort`" test "$available2" = "$available" guix package -I + +unset GUIX_BUILD_OPTIONS + +# Applying a manifest file +cat > "$module_dir/manifest.scm"<manifest (list %bootstrap-guile)) +EOF +guix package --bootstrap -m "$module_dir/manifest.scm" +guix package -I | grep guile +test `guix package -I | wc -l` -eq 1 -- cgit v1.3 From 4d043ab6283cb15e2f0cd0847a38ccf3604aab66 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 20 May 2015 18:42:35 -0400 Subject: ui: Deduplicate 'show-what-to-build*'. * guix/ui.scm (show-what-to-build*): New procedure. * guix/scripts/environment.scm (show-what-to-build*): Delete. * guix/scripts/system.scm (show-what-to-build*): Likewise. * build-aux/make-binary-tarball.scm (show-what-to-build*): Likewise. --- build-aux/make-binary-tarball.scm | 3 --- guix/scripts/environment.scm | 3 --- guix/scripts/system.scm | 2 -- guix/ui.scm | 4 ++++ 4 files changed, 4 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/build-aux/make-binary-tarball.scm b/build-aux/make-binary-tarball.scm index 0b5dbaf1d..e12bec476 100644 --- a/build-aux/make-binary-tarball.scm +++ b/build-aux/make-binary-tarball.scm @@ -27,9 +27,6 @@ (gnu system install) (ice-9 match)) -(define show-what-to-build* - (store-lift show-what-to-build)) - (define copy-file* (lift2 copy-file %store-monad)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index e81532c7e..f403e95f3 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -192,9 +192,6 @@ packages." (append-map transitive-inputs packages))) ;; TODO: Deduplicate these. -(define show-what-to-build* - (store-lift show-what-to-build)) - (define set-build-options-from-command-line* (store-lift set-build-options-from-command-line)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 459b2da0c..8d5fbe5a7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -67,8 +67,6 @@ (store-lift references)) (define topologically-sorted* (store-lift topologically-sorted)) -(define show-what-to-build* - (store-lift show-what-to-build)) (define* (copy-item item target diff --git a/guix/ui.scm b/guix/ui.scm index 920355fbb..9bab7c51d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -57,6 +57,7 @@ string->number* size->number show-what-to-build + show-what-to-build* show-manifest-transaction call-with-error-handling with-error-handling @@ -453,6 +454,9 @@ available for download." (null? download) download))) (pair? build))) +(define show-what-to-build* + (store-lift show-what-to-build)) + (define (right-arrow port) "Return either a string containing the 'RIGHT ARROW' character, or an ASCII replacement if PORT is not Unicode-capable." -- cgit v1.3 From 2d977638c9a6d8779b01042b0f085da5b26affa9 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 20 May 2015 18:48:10 -0400 Subject: scripts: Move 'set-build-options-from-command-line*' to (guix scripts build) module. * guix/scripts/build.scm (set-build-options-from-command-line*): New procedure. * guix/scripts/environment.scm (set-build-options-from-command-line*): Delete. --- guix/scripts/build.scm | 4 ++++ guix/scripts/environment.scm | 4 ---- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index da71adba6..2307f76b4 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -37,6 +37,7 @@ #:autoload (guix download) (download-to-store) #:export (%standard-build-options set-build-options-from-command-line + set-build-options-from-command-line* show-build-options-help guix-build)) @@ -139,6 +140,9 @@ options handled by 'set-build-options-from-command-line', and listed in #:print-build-trace (assoc-ref opts 'print-build-trace?) #:verbosity (assoc-ref opts 'verbosity))) +(define set-build-options-from-command-line* + (store-lift set-build-options-from-command-line)) + (define %standard-build-options ;; List of standard command-line options for tools that build something. (list (option '(#\L "load-path") #t #f diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index f403e95f3..d053daf02 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -191,10 +191,6 @@ packages." (delete-duplicates (append-map transitive-inputs packages))) -;; TODO: Deduplicate these. -(define set-build-options-from-command-line* - (store-lift set-build-options-from-command-line)) - (define (build-inputs inputs opts) "Build the packages in INPUTS using the build options in OPTS." (let ((substitutes? (assoc-ref opts 'substitutes?)) -- cgit v1.3 From a4b1a6b65e0f01056bb41e51bddadc7fed923a14 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 May 2015 14:26:01 +0200 Subject: guix package: Adjust --help message. * guix/scripts/package.scm (show-help): Add KIND parameter for --search-paths as a followup to dbc31ab. --- guix/scripts/package.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 125173406..06ee44179 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -440,7 +440,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " --roll-back roll back to the previous generation")) (display (_ " - --search-paths display needed environment variable definitions")) + --search-paths[=KIND] + display needed environment variable definitions")) (display (_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) -- cgit v1.3 From ea982704430b061f263580041d4f94174d8ba5cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 May 2015 23:23:47 +0200 Subject: syscalls: Add 'restart-on-EINTR'. * guix/build/syscalls.scm (call-with-restart-on-EINTR): New procedure. (restart-on-EINTR): New macro. --- guix/build/syscalls.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 5bc4595d0..9ec7e8b4a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -29,6 +29,7 @@ MS_REMOUNT MS_BIND MS_MOVE + restart-on-EINTR mount umount mount-points @@ -89,6 +90,19 @@ (ref bv)))) (lambda () 0))) +(define (call-with-restart-on-EINTR thunk) + (let loop () + (catch 'system-error + thunk + (lambda args + (if (= (system-error-errno args) EINTR) + (loop) + (apply throw args)))))) + +(define-syntax-rule (restart-on-EINTR expr) + "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." + (call-with-restart-on-EINTR (lambda () expr))) + (define (augment-mtab source target type options) "Augment /etc/mtab with information about the given mount point." (let ((port (open-file "/etc/mtab" "a"))) -- cgit v1.3 From 60a56db0074259355a590851131aa23e1549fd8c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 May 2015 23:24:49 +0200 Subject: services: swap: Use 'restart-on-EINTR'. * gnu/services/base.scm (swap-service)[start, stop]: Use 'restart-on-EINTR'. * guix/build/syscalls.scm (swapoff): Fix typo in 'throw' arguments. --- gnu/services/base.scm | 4 ++-- guix/build/syscalls.scm | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 697b9395c..d5744204d 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -851,10 +851,10 @@ gexp, to open it, and evaluate @var{close} to close it." (requirement `(udev ,@requirement)) (documentation "Enable the given swap device.") (start #~(lambda () - (swapon #$device) + (restart-on-EINTR (swapon #$device)) #t)) (stop #~(lambda _ - (swapoff #$device) + (restart-on-EINTR (swapoff #$device)) #f)) (respawn? #f))))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 9ec7e8b4a..3585bf27a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -218,7 +218,7 @@ constants from ." (let ((ret (proc (string->pointer device))) (err (errno))) (unless (zero? ret) - (throw 'system-error "swapff" "~S: ~A" + (throw 'system-error "swapoff" "~S: ~A" (list device (strerror err)) (list err))))))) -- cgit v1.3 From 4a35a866be51361b80a5618e422d135959960c3d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 23 May 2015 16:52:17 +0200 Subject: guix system: init: Make sure the target is root-owned. Suggested by Mark H Weaver . * guix/scripts/system.scm (install): Add 'chown' and 'chmod' calls for TARGET when running as root, and warn otherwise. --- guix/scripts/system.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8d5fbe5a7..1feb82138 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -145,6 +145,16 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; Copy items to the new store. (copy-closure to-copy target #:log-port log-port))))) + ;; Make sure TARGET is root-owned when running as root, but still allow + ;; non-root uses (useful for testing.) See + ;; . + (if (zero? (geteuid)) + (chown target 0 0) + (warning (_ "not running as 'root', so \ +the ownership of '~a' may be incorrect!~%") + target)) + + (chmod target #o755) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) (populate (lift2 populate-root-file-system %store-monad))) -- cgit v1.3 From 328639e48f7ccb8e32fa42a8a0fbc2097fac38e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 May 2015 17:15:16 +0200 Subject: guix system: Always add zero previous entries in grub.cfg for 'init'. * guix/scripts/system.scm (grub.cfg): Remove. (perform-action): Call 'operating-system-grub.cfg' with the empty list as the 2nd argument when ACTION is 'init. --- guix/scripts/system.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1feb82138..5a2bf7b4b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -284,10 +284,6 @@ it atomically, and then run OS's activation script." ((disk-image) (system-disk-image os #:disk-image-size image-size)))) -(define (grub.cfg os) - "Return the GRUB configuration file for OS." - (operating-system-grub.cfg os (previous-grub-entries))) - (define* (maybe-build drvs #:key dry-run? use-substitutes?) "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is @@ -317,7 +313,10 @@ boot directly to the kernel or to the bootloader." #:full-boot? full-boot? #:mappings mappings)) (grub (package->derivation grub)) - (grub.cfg (grub.cfg os)) + (grub.cfg (operating-system-grub.cfg os + (if (eq? 'init action) + '() + (previous-grub-entries)))) (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) -- cgit v1.3 From f245b03debfa05fa692e95769a9b7116200bf191 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 May 2015 17:20:24 +0200 Subject: guix system: init: Copy the closure of 'grub.cfg', not that of the system. Fixes . Reported by Daniel Pimentel . * guix/scripts/system.scm (install): Copy the closure of GRUB.CFG rather than that of OS-DIR. --- guix/scripts/system.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5a2bf7b4b..277f31f6f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -128,8 +128,9 @@ TARGET, and register them." (define* (install os-drv target #:key (log-port (current-output-port)) grub? grub.cfg device) - "Copy the output of OS-DRV and its dependencies to directory TARGET. TARGET -must be an absolute directory name since that's what 'guix-register' expects. + "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to +directory TARGET. TARGET must be an absolute directory name since that's what +'guix-register' expects. When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (define (maybe-copy to-copy) @@ -160,7 +161,9 @@ the ownership of '~a' may be incorrect!~%") (populate (lift2 populate-root-file-system %store-monad))) (mbegin %store-monad - (maybe-copy os-dir) + ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's + ;; background image and so on. + (maybe-copy grub.cfg) ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) -- cgit v1.3 From 9b14107f2d686a5554bc174856f345d8daaff22d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 May 2015 17:22:43 +0200 Subject: ui: Add 'copy-file' replacement with better error reporting. * guix/ui.scm (copy-file): New procedure. --- guix/ui.scm | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9bab7c51d..372733c24 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -246,6 +246,23 @@ General help using GNU software: ")) (append args (list link)) errno)))))) +(set! copy-file + ;; Note: here we use 'set!', not #:replace, because UIs typically use + ;; 'copy-recursively', which doesn't use (guix ui). + (let ((real-copy-file (@ (guile) copy-file))) + (lambda (source target) + "This is a 'copy-file' replacement that provides proper error reporting." + (catch 'system-error + (lambda () + (real-copy-file source target)) + (lambda (key proc fmt args errno) + ;; Augment the FMT and ARGS with information about TARGET (this + ;; information is missing as of Guile 2.0.11, making the exception + ;; uninformative.) + (apply throw key proc "~A: ~S" + (list (strerror (car errno)) target) + (list errno))))))) + (define (string->number* str) "Like `string->number', but error out with an error message on failure." (or (string->number str) -- cgit v1.3 From 6ec1f4caa34d350d9f8b90b71192c1d32807d934 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 24 May 2015 17:29:14 +0200 Subject: ui: Make 'symlink' replacement more future-proof. * guix/ui.scm (symlink): Change next-to-last 'throw' argument to explicitly ignore ARGS; change last argument to (list errno). --- guix/ui.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 372733c24..2b62e7abc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -243,8 +243,8 @@ General help using GNU software: ")) ;; information is missing as of Guile 2.0.11, making the exception ;; uninformative.) (apply throw key proc "~A: ~S" - (append args (list link)) - errno)))))) + (list (strerror (car errno)) link) + (list errno))))))) (set! copy-file ;; Note: here we use 'set!', not #:replace, because UIs typically use -- cgit v1.3 From 2abcc97fd1867176d5530f988ab34c26530de2c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 May 2015 18:25:19 +0200 Subject: ui: Auto-compile user code, and improve error reporting. Reported by Christian Grothoff. * guix/ui.scm (load*): Add 'frame-with-source'. Set %load-should-auto-compile. Change error handle to just (exit 1). Add pre-unwind handler to capture the stack and call 'report-load-error'. (report-load-error): Add optional 'frame' parameter and pass it to 'display-error'. * tests/guix-system.sh: Add "unbound variable" test. --- .dir-locals.el | 1 + guix/ui.scm | 43 ++++++++++++++++++++++++++++++++++++++----- tests/guix-system.sh | 26 ++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index eb3da94da..7ac7e13ff 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -13,6 +13,7 @@ . ((indent-tabs-mode . nil) (eval . (put 'eval-when 'scheme-indent-function 1)) + (eval . (put 'call-with-prompt 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) (eval . (put 'test-assertm 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) diff --git a/guix/ui.scm b/guix/ui.scm index 2b62e7abc..d590eef04 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -35,6 +35,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-31) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) @@ -147,18 +148,50 @@ messages." (define (load* file user-module) "Load the user provided Scheme source code FILE." + (define (frame-with-source frame) + ;; Walk from FRAME upwards until source location information is found. + (let loop ((frame frame) + (previous frame)) + (if (not frame) + previous + (if (frame-source frame) + frame + (loop (frame-previous frame) frame))))) + (catch #t (lambda () + ;; XXX: Force a recompilation to avoid ABI issues. (set! %fresh-auto-compile #t) + (set! %load-should-auto-compile #t) (save-module-excursion (lambda () (set-current-module user-module) - (primitive-load file)))) - (lambda args - (report-load-error file args)))) -(define (report-load-error file args) + ;; Hide the "auto-compiling" messages. + (parameterize ((current-warning-port (%make-void-port "w"))) + ;; Give 'load' an absolute file name so that it doesn't try to + ;; search for FILE in %LOAD-PATH. Note: use 'load', not + ;; 'primitive-load', so that FILE is compiled, which then allows us + ;; to provide better error reporting with source line numbers. + (load (canonicalize-path file)))))) + (lambda _ + ;; XXX: Errors are reported from the pre-unwind handler below, but + ;; calling 'exit' from there has no effect, so we call it here. + (exit 1)) + (rec (handle-error . args) + ;; Capture the stack up to this procedure call, excluded, and pass + ;; the faulty stack frame to 'report-load-error'. + (let* ((stack (make-stack #t handle-error)) + (depth (stack-length stack)) + (last (and (> depth 0) (stack-ref stack 0))) + (frame (frame-with-source + (if (> depth 1) + (stack-ref stack 1) ;skip the 'throw' frame + last)))) + (report-load-error file args frame))))) + +(define* (report-load-error file args #:optional frame) "Report the failure to load FILE, a user-provided Scheme file, and exit. ARGS is the list of arguments received by the 'throw' handler." (match args @@ -172,7 +205,7 @@ ARGS is the list of arguments received by the 'throw' handler." (exit 1))) ((error args ...) (report-error (_ "failed to load '~a':~%") file) - (apply display-error #f (current-error-port) args) + (apply display-error frame (current-error-port) args) (exit 1)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 7008ef803..4289db239 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -45,6 +45,32 @@ else fi +# Reporting of unbound variables. + +cat > "$tmpfile" < "$errorfile" +then false +else + grep "$tmpfile:9:.*[Uu]nbound variable.*GRUB-config" "$errorfile" +fi + # Reporting of duplicate service identifiers. cat > "$tmpfile" < Date: Mon, 25 May 2015 19:33:19 +0200 Subject: guix package: --manifest DTRT when combined with --dry-run. * guix/scripts/package.scm (guix-package)[process-actions]: Process 'manifest action regardless of whether 'dry-run? is set. Adjust the message accordingly. * tests/guix-package.sh: Add error-reporting test. --- guix/scripts/package.scm | 14 ++++++++------ tests/guix-package.sh | 18 +++++++++++++++++- 2 files changed, 25 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 06ee44179..9da6b9ec1 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -886,14 +886,16 @@ more information.~%")) (alist-delete 'delete-generations opts))) (_ #f)) opts)) - ((and (assoc-ref opts 'manifest) - (not dry-run?)) - (let* ((file-name (assoc-ref opts 'manifest)) + ((assoc-ref opts 'manifest) + (let* ((file-name (assoc-ref opts 'manifest)) (user-module (make-user-module '((guix profiles) (gnu)))) - (manifest (load* file-name user-module))) - (format #t (_ "installing new manifest from ~a with ~d entries.~%") - file-name (length (manifest-entries manifest))) + (manifest (load* file-name user-module))) + (if (assoc-ref opts 'dry-run?) + (format #t (_ "would install new manifest from '~a' with ~d entries~%") + file-name (length (manifest-entries manifest))) + (format #t (_ "installing new manifest from '~a' with ~d entries~%") + file-name (length (manifest-entries manifest)))) (build-and-use-profile manifest))) (else (let* ((manifest (profile-manifest profile)) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 26a5e9d1a..b361b1ba0 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -245,7 +245,7 @@ guix package -I unset GUIX_BUILD_OPTIONS -# Applying a manifest file +# Applying a manifest file. cat > "$module_dir/manifest.scm"< "$module_dir/manifest.scm"<manifest + (list %bootstrap-guile + wonderful-package-that-does-not-exist)) +EOF +if guix package --bootstrap -n -m "$module_dir/manifest.scm" \ + 2> "$module_dir/stderr" +then false +else + cat "$module_dir/stderr" + grep "manifest.scm:[1-3]:.*[Uu]nbound variable.*wonderful-package" \ + "$module_dir/stderr" +fi -- cgit v1.3 From db030303b820297da23f8ce7101be88427eeef8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 25 May 2015 22:52:41 +0200 Subject: guix system: Add '--on-error'. * guix/ui.scm (load*): Add #:on-error parameter. [tag, error-string]: New variables. Wrap 'load' call in 'call-with-prompt'. Pass TAG to 'make-stack'. Honor ON-ERROR after 'report-load-error' call. (report-load-error): Change to not exit on error. Make private. * guix/scripts/system.scm (show-help, %options): Add --on-error. (guix-system): Use 'load*' and pass it #:on-error. --- doc/guix.texi | 19 +++++++++++++++++ guix/scripts/system.scm | 10 ++++++++- guix/ui.scm | 55 +++++++++++++++++++++++++++++++++++-------------- 3 files changed, 68 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a4aa1b67f..a97436cc0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5995,6 +5995,25 @@ For the @code{vm-image} and @code{disk-image} actions, create an image of the given @var{size}. @var{size} may be a number of bytes, or it may include a unit as a suffix (@pxref{Block size, size specifications,, coreutils, GNU Coreutils}). + +@item --on-error=@var{strategy} +Apply @var{strategy} when an error occurs when reading @var{file}. +@var{strategy} may be one of the following: + +@table @code +@item nothing-special +Report the error concisely and exit. This is the default strategy. + +@item backtrace +Likewise, but also display a backtrace. + +@item debug +Report the error and enter Guile's debugger. From there, you can run +commands such as @code{,bt} to get a backtrace, @code{,locals} to +display local variable values, and more generally inspect the program's +state. @xref{Debug Commands,,, guile, GNU Guile Reference Manual}, for +a list of available debugging commands. +@end table @end table Note that all the actions above, except @code{build} and @code{init}, diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 277f31f6f..b6d7d0d04 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -382,6 +382,9 @@ Build the operating system declared in FILE according to ACTION.\n")) - 'init', initialize a root file system to run GNU.\n")) (show-build-options-help) + (display (_ " + --on-error=STRATEGY + apply STRATEGY when an error occurs while reading FILE")) (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (_ " @@ -422,6 +425,10 @@ Build the operating system declared in FILE according to ACTION.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) + (option '("on-error") #t #f + (lambda (opt name arg result) + (alist-cons 'on-error (string->symbol arg) + result))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -514,7 +521,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (action (assoc-ref opts 'action)) (system (assoc-ref opts 'system)) (os (if file - (read-operating-system file) + (load* file %user-module + #:on-error (assoc-ref opts 'on-error)) (leave (_ "no configuration file specified~%")))) (dry? (assoc-ref opts 'dry-run?)) diff --git a/guix/ui.scm b/guix/ui.scm index d590eef04..7490de080 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -43,6 +43,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) + #:autoload (system repl repl) (start-repl) + #:autoload (system repl debug) (make-debug stack->vector) #:replace (symlink) #:export (_ N_ @@ -51,7 +53,6 @@ leave make-user-module load* - report-load-error warn-about-load-error show-version-and-exit show-bug-report-information @@ -146,7 +147,8 @@ messages." modules) module)) -(define (load* file user-module) +(define* (load* file user-module + #:key (on-error 'nothing-special)) "Load the user provided Scheme source code FILE." (define (frame-with-source frame) ;; Walk from FRAME upwards until source location information is found. @@ -158,6 +160,14 @@ messages." frame (loop (frame-previous frame) frame))))) + (define (error-string frame args) + (call-with-output-string + (lambda (port) + (apply display-error frame port (cdr args))))) + + (define tag + (make-prompt-tag "user-code")) + (catch #t (lambda () ;; XXX: Force a recompilation to avoid ABI issues. @@ -170,11 +180,14 @@ messages." ;; Hide the "auto-compiling" messages. (parameterize ((current-warning-port (%make-void-port "w"))) - ;; Give 'load' an absolute file name so that it doesn't try to - ;; search for FILE in %LOAD-PATH. Note: use 'load', not - ;; 'primitive-load', so that FILE is compiled, which then allows us - ;; to provide better error reporting with source line numbers. - (load (canonicalize-path file)))))) + (call-with-prompt tag + (lambda () + ;; Give 'load' an absolute file name so that it doesn't try to + ;; search for FILE in %LOAD-PATH. Note: use 'load', not + ;; 'primitive-load', so that FILE is compiled, which then allows us + ;; to provide better error reporting with source line numbers. + (load (canonicalize-path file))) + (const #f)))))) (lambda _ ;; XXX: Errors are reported from the pre-unwind handler below, but ;; calling 'exit' from there has no effect, so we call it here. @@ -182,31 +195,43 @@ messages." (rec (handle-error . args) ;; Capture the stack up to this procedure call, excluded, and pass ;; the faulty stack frame to 'report-load-error'. - (let* ((stack (make-stack #t handle-error)) + (let* ((stack (make-stack #t handle-error tag)) (depth (stack-length stack)) (last (and (> depth 0) (stack-ref stack 0))) (frame (frame-with-source (if (> depth 1) (stack-ref stack 1) ;skip the 'throw' frame last)))) - (report-load-error file args frame))))) + + (report-load-error file args frame) + + (case on-error + ((debug) + (newline) + (display (_ "entering debugger; type ',bt' for a backtrace\n")) + (start-repl #:debug (make-debug (stack->vector stack) 0 + (error-string frame args) + #f))) + ((backtrace) + (newline (current-error-port)) + (display-backtrace stack (current-error-port))) + (else + #t)))))) (define* (report-load-error file args #:optional frame) - "Report the failure to load FILE, a user-provided Scheme file, and exit. + "Report the failure to load FILE, a user-provided Scheme file. ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . _) (let ((err (system-error-errno args))) - (leave (_ "failed to load '~a': ~a~%") file (strerror err)))) + (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) (format (current-error-port) (_ "~a: error: ~a~%") - (location->string loc) message) - (exit 1))) + (location->string loc) message))) ((error args ...) (report-error (_ "failed to load '~a':~%") file) - (apply display-error frame (current-error-port) args) - (exit 1)))) + (apply display-error frame (current-error-port) args)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ "Report the failure to load FILE, a user-provided Scheme file, without -- cgit v1.3 From cdb5b075d545dd4e0b2a03bdc62fa0d1f6e00fc3 Mon Sep 17 00:00:00 2001 From: Cyrill Schenkel Date: Sun, 24 May 2015 14:04:15 +0200 Subject: gc: ignore trailing slash or subdirectories for `guix gc -d' MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/scripts/gc.scm (guix-gc): Convert paths to direct store paths. * guix/store.scm (direct-store-path): Get rid of subdirectories in store path. * tests/guix-gc.sh: New tests. Co-authored-by: Ludovic Courtès --- guix/scripts/gc.scm | 2 +- guix/store.scm | 10 ++++++++++ tests/guix-gc.sh | 20 ++++++++++++++++++++ 3 files changed, 31 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 4bae65a1e..a250cdc19 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -168,7 +168,7 @@ Invoke the garbage collector.\n")) (collect-garbage store min-freed) (collect-garbage store)))) ((delete) - (delete-paths store paths)) + (delete-paths store (map direct-store-path paths))) ((list-references) (list-relatives references)) ((list-requisites) diff --git a/guix/store.scm b/guix/store.scm index fc2f8d92c..8905a5a55 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -121,6 +121,7 @@ derivation-path? store-path-package-name store-path-hash-part + direct-store-path log-file)) (define %protocol-version #x10c) @@ -1012,6 +1013,15 @@ valid inputs." (let ((len (+ 1 (string-length (%store-prefix))))) (not (string-index (substring path len) #\/))))) +(define (direct-store-path path) + "Return the direct store path part of PATH, stripping components after +'/gnu/store/xxxx-foo'." + (let ((prefix-length (+ (string-length (%store-prefix)) 35))) + (if (> (string-length path) prefix-length) + (let ((slash (string-index path #\/ prefix-length))) + (if slash (string-take path slash) path)) + path))) + (define (derivation-path? path) "Return #t if PATH is a derivation path." (and (store-path? path) (string-suffix? ".drv" path))) diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index eac9d82e8..c1eb66cef 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -64,3 +64,23 @@ guix gc -C 1KiB # Check trivial error cases. if guix gc --delete /dev/null; then false; else true; fi + +# Bug #19757 +out="`guix build guile-bootstrap`" +test -d "$out" + +guix gc --delete "$out" + +! test -d "$out" + +out="`guix build guile-bootstrap`" +test -d "$out" + +guix gc --delete "$out/" + +! test -d "$out" + +out="`guix build guile-bootstrap`" +test -d "$out" + +guix gc --delete "$out/bin/guile" -- cgit v1.3 From 41766807d042023b1f807cc40e9fd09fc3682a4e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 May 2015 22:38:17 +0200 Subject: ui: Improve error reporting for 'read/eval'. The effect is visible on commands like: guix build -e '(+ 2 "foo")' guix build -e '()' * guix/ui.scm (read/eval): Change handler to properly report syntax errors and use 'display-error' for other errors. --- guix/ui.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 7490de080..2140c2e50 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -446,8 +446,14 @@ interpreted." (lambda () (eval exp (force %guix-user-module))) (lambda args - (leave (_ "failed to evaluate expression `~a': ~s~%") - exp args))))) + (report-error (_ "failed to evaluate expression '~a':~%") exp) + (match args + (('syntax-error proc message properties form . rest) + (report-error (_ "syntax error: ~a~%") message)) + ((error args ...) + (apply display-error #f (current-error-port) args)) + (what? #f)) + (exit 1))))) (define (read/eval-package-expression str) "Read and evaluate STR and return the package it refers to, or exit an -- cgit v1.3 From 07eaecfae1add0b1b0d78047c0ac7b1229592dcb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 26 May 2015 23:38:27 +0200 Subject: profiles: Hooks always return a monadic value. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Suggested by 宋文武 . * guix/profiles.scm (ghc-package-cache-file): Return a monadic #f, not just #f, when MANIFEST contains no GHC package. (profile-derivation): Do not filter based on the return value of HOOK; instead filter based on the value of items in EXTRAS. --- guix/profiles.scm | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 9cb226eda..9011449aa 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -516,12 +516,14 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (for-each delete-file (find-files db-dir "\\.conf$")) success))) - ;; Don't depend on GHC when there's nothing to do. - (and (any (cut string-prefix? "ghc" <>) - (map manifest-entry-name (manifest-entries manifest))) - (gexp->derivation "ghc-package-cache" build - #:modules '((guix build utils)) - #:local-build? #t))) + (with-monad %store-monad + ;; Don't depend on GHC when there's nothing to do. + (if (any (cut string-prefix? "ghc" <>) + (map manifest-entry-name (manifest-entries manifest))) + (gexp->derivation "ghc-package-cache" build + #:modules '((guix build utils)) + #:local-build? #t) + (return #f)))) (define (ca-certificate-bundle manifest) "Return a derivation that builds a single-file bundle containing the CA @@ -602,11 +604,14 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (mlet %store-monad ((extras (if (null? (manifest-entries manifest)) (return '()) (sequence %store-monad - (filter-map (lambda (hook) - (hook manifest)) - hooks))))) + (map (lambda (hook) + (hook manifest)) + hooks))))) (define inputs - (append (map gexp-input extras) + (append (filter-map (lambda (gexp) + (and (gexp? gexp) + (gexp-input gexp))) + extras) (manifest-inputs manifest))) (define builder -- cgit v1.3 From b734996f9cf395705860703422d5e92565dd3a13 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 May 2015 09:40:19 +0200 Subject: monads: 'foldm', 'mapm', and 'anym' now take a list of regular values. * guix/monads.scm (foldm, mapm, anym): Change to take a list of regular values as is customary. * tests/monads.scm ("mapm", "anym"): Adjust accordingly. --- guix/monads.scm | 46 ++++++++++++++++++++++++++++------------------ tests/monads.scm | 13 +++++++------ 2 files changed, 35 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/monads.scm b/guix/monads.scm index f693e99a5..424852543 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -225,8 +225,11 @@ MONAD---i.e., return a monadic function in MONAD." (return (apply proc args))))) (define (foldm monad mproc init lst) - "Fold MPROC over LST, a list of monadic values in MONAD, and return a -monadic value seeded by INIT." + "Fold MPROC over LST and return a monadic value seeded by INIT. + + (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) + => '(c b a) ;monadic +" (with-monad monad (let loop ((lst lst) (result init)) @@ -234,18 +237,21 @@ monadic value seeded by INIT." (() (return result)) ((head tail ...) - (mlet* monad ((item head) - (result (mproc item result))) - (loop tail result))))))) + (>>= (mproc head result) + (lambda (result) + (loop tail result)))))))) (define (mapm monad mproc lst) - "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic -list. LST items are bound from left to right, so effects in MONAD are known -to happen in that order." + "Map MPROC over LST and return a monadic list. + + (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2)) + => (1 2 3) ;monadic +" (mlet monad ((result (foldm monad (lambda (item result) - (mlet monad ((item (mproc item))) - (return (cons item result)))) + (>>= (mproc item) + (lambda (item) + (return (cons item result))))) '() lst))) (return (reverse result)))) @@ -268,20 +274,24 @@ evaluating each item of LST in sequence." (lambda (item) (seq tail (cons item result))))))))) -(define (anym monad proc lst) - "Apply PROC to the list of monadic values LST; return the first value, -lifted in MONAD, for which PROC returns true." +(define (anym monad mproc lst) + "Apply MPROC to the list of values LST; return as a monadic value the first +value for which MPROC returns a true monadic value or #f. For example: + + (anym %state-monad (lift1 odd? %state-monad) '(0 1 2)) + => #t ;monadic +" (with-monad monad (let loop ((lst lst)) (match lst (() (return #f)) ((head tail ...) - (mlet* monad ((value head) - (result -> (proc value))) - (if result - (return result) - (loop tail)))))))) + (>>= (mproc head) + (lambda (result) + (if result + (return result) + (loop tail))))))))) (define-syntax listm (lambda (s) diff --git a/tests/monads.scm b/tests/monads.scm index 57a8e6679..5529a6188 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -163,7 +163,7 @@ (test-assert "mapm" (every (lambda (monad run) (with-monad monad - (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10)))) + (equal? (run (mapm monad (lift1 1+ monad) (iota 10))) (map 1+ (iota 10))))) %monads %monad-run)) @@ -202,11 +202,12 @@ (test-assert "anym" (every (lambda (monad run) (eq? (run (with-monad monad - (let ((lst (list (return 1) (return 2) (return 3)))) - (anym monad - (lambda (x) - (and (odd? x) 'odd!)) - lst)))) + (anym monad + (lift1 (lambda (x) + (and (odd? x) 'odd!)) + monad) + (append (make-list 1000 0) + (list 1 2))))) 'odd!)) %monads %monad-run)) -- cgit v1.3 From b04af0ec670c097ef46ad7751924941401272730 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Wed, 27 May 2015 20:58:27 +0800 Subject: profiles: Add gtk-icon-themes hook. * guix/profiles.scm (gtk-icon-themes): New function. (%default-profile-hooks): Add it. --- guix/profiles.scm | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 78 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 9011449aa..55c059860 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Alex Kost ;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2015 Sou Bunnbu ;;; ;;; This file is part of GNU Guix. ;;; @@ -588,12 +589,88 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." #:modules '((guix build utils)) #:local-build? #t)) +(define (gtk-icon-themes manifest) + "Return a derivation that unions all icon themes from manifest entries and +creates the GTK+ 'icon-theme.cache' file for each theme." + ;; Return as a monadic value the GTK+ package or store path referenced by the + ;; manifest ENTRY, or #f if not referenced. + (define (entry-lookup-gtk+ entry) + (define (find-among-packages packages) + (find (lambda (package) + (equal? "gtk+" (package-name package))) + packages)) + + (define (find-among-store-items items) + (find (lambda (item) + (equal? "gtk+" + (package-name->name+version + (store-path-package-name item)))) + items)) + + ;; TODO: Factorize. + (define references* + (store-lift references)) + + (with-monad %store-monad + (match (manifest-entry-item entry) + ((? package? package) + (match (package-transitive-inputs package) + (((labels packages . _) ...) + (return (find-among-packages packages))))) + ((? string? item) + (mlet %store-monad ((refs (references* item))) + (return (find-among-store-items refs))))))) + + (define (manifest-lookup-gtk+ manifest) + (anym %store-monad + entry-lookup-gtk+ (manifest-entries manifest))) + + (mlet %store-monad ((gtk+ (manifest-lookup-gtk+ manifest))) + (define build + #~(begin + (use-modules (guix build utils) + (guix build union) + (srfi srfi-26) + (ice-9 ftw)) + (let* ((destdir (string-append #$output "/share/icons")) + (icondirs (filter file-exists? + (map (cut string-append <> "/share/icons") + '#$(manifest-inputs manifest)))) + (update-icon-cache (string-append + #+gtk+ "/bin/gtk-update-icon-cache"))) + ;; XXX: Should move to (guix build utils). + (define ensure-writable-directory + (@@ (guix build profiles) ensure-writable-directory)) + + ;; Union all the icons. + (mkdir-p (string-append #$output "/share")) + (union-build destdir icondirs) + ;; Update the 'icon-theme.cache' file for each icon theme. + (for-each + (lambda (theme) + (let ((dir (string-append #$output "/share/icons/" theme))) + (ensure-writable-directory dir) + (system* update-icon-cache "-t" dir))) + (scandir destdir (negate (cut member <> '("." "..")))))))) + + ;; Don't run the hook when there's nothing to do. + (if gtk+ + (gexp->derivation "gtk-icon-themes" build + #:modules '((guix build utils) + (guix build union) + (guix build profiles) + (guix search-paths) + (guix records)) + #:local-build? #t) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. (list info-dir-file ghc-package-cache-file - ca-certificate-bundle)) + ca-certificate-bundle + gtk-icon-themes)) (define* (profile-derivation manifest #:key -- cgit v1.3 From eeae0b3c6ca1a0b86cb015ed45c638985ed7da30 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Wed, 27 May 2015 21:03:21 +0800 Subject: profiles: Use 'derivation?' to filter hooks. Fixes a regression introduced in 07eaecfa. * guix/profiles.scm (profile-derivation): Use 'derivation?' instead of 'gexp?' to filter hooks. --- guix/profiles.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 55c059860..aaf693363 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -685,9 +685,9 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (hook manifest)) hooks))))) (define inputs - (append (filter-map (lambda (gexp) - (and (gexp? gexp) - (gexp-input gexp))) + (append (filter-map (lambda (drv) + (and (derivation? drv) + (gexp-input drv))) extras) (manifest-inputs manifest))) -- cgit v1.3 From 102f7101b965be55ef1f80e80eec127a982b20a1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 May 2015 22:31:56 +0200 Subject: profiles: Don't assume all the inputs are of a package are packages. Reported by Ricardo Wurmus. * guix/profiles.scm (gtk-icon-themes)[entry-lookup-gtk+](find-among-packages): Rename to... (find-among-inputs): ... this. Check whether INPUT is a package before calling 'package-name'. Fixes a regression introduced in b04af0e. --- guix/profiles.scm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index aaf693363..c2cf1bf07 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -595,10 +595,11 @@ creates the GTK+ 'icon-theme.cache' file for each theme." ;; Return as a monadic value the GTK+ package or store path referenced by the ;; manifest ENTRY, or #f if not referenced. (define (entry-lookup-gtk+ entry) - (define (find-among-packages packages) - (find (lambda (package) - (equal? "gtk+" (package-name package))) - packages)) + (define (find-among-inputs inputs) + (find (lambda (input) + (and (package? input) + (string=? "gtk+" (package-name input)))) + inputs)) (define (find-among-store-items items) (find (lambda (item) @@ -615,8 +616,8 @@ creates the GTK+ 'icon-theme.cache' file for each theme." (match (manifest-entry-item entry) ((? package? package) (match (package-transitive-inputs package) - (((labels packages . _) ...) - (return (find-among-packages packages))))) + (((labels inputs . _) ...) + (return (find-among-inputs inputs))))) ((? string? item) (mlet %store-monad ((refs (references* item))) (return (find-among-store-items refs))))))) -- cgit v1.3 From 6a669bda51acb12b4ae4901c1df04fa5965ef1d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 May 2015 22:36:52 +0200 Subject: profiles: Export 'ensure-writable-directory' and use it. * guix/build/profiles.scm (ensure-writable-directory): Export. * guix/profiles.scm (gtk-icon-themes)[build]: Remove '@@' form and use (guix build profiles). --- guix/build/profiles.scm | 3 ++- guix/profiles.scm | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 2becc6b9a..6e316d5d2 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -24,7 +24,8 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) - #:export (build-profile)) + #:export (ensure-writable-directory + build-profile)) ;;; Commentary: ;;; diff --git a/guix/profiles.scm b/guix/profiles.scm index c2cf1bf07..0f73455d2 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -631,21 +631,21 @@ creates the GTK+ 'icon-theme.cache' file for each theme." #~(begin (use-modules (guix build utils) (guix build union) + (guix build profiles) (srfi srfi-26) (ice-9 ftw)) + (let* ((destdir (string-append #$output "/share/icons")) (icondirs (filter file-exists? (map (cut string-append <> "/share/icons") '#$(manifest-inputs manifest)))) (update-icon-cache (string-append #+gtk+ "/bin/gtk-update-icon-cache"))) - ;; XXX: Should move to (guix build utils). - (define ensure-writable-directory - (@@ (guix build profiles) ensure-writable-directory)) ;; Union all the icons. (mkdir-p (string-append #$output "/share")) (union-build destdir icondirs) + ;; Update the 'icon-theme.cache' file for each icon theme. (for-each (lambda (theme) -- cgit v1.3 From 1ba4796d135ba7a07f2e89126fba673601c321c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 28 May 2015 14:38:50 +0200 Subject: profiles: Deal with non-directory items in share/icons. Reported by Mark H Weaver . * guix/profiles.scm (gtk-icon-themes)[build]: Check whether DIR is a directory before calling 'ensure-writable-directory'. --- guix/profiles.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 0f73455d2..28150affb 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -649,9 +649,12 @@ creates the GTK+ 'icon-theme.cache' file for each theme." ;; Update the 'icon-theme.cache' file for each icon theme. (for-each (lambda (theme) - (let ((dir (string-append #$output "/share/icons/" theme))) - (ensure-writable-directory dir) - (system* update-icon-cache "-t" dir))) + (let ((dir (string-append destdir "/" theme))) + ;; Occasionally DESTDIR contains plain files, such as + ;; "abiword_48.png". Ignore these. + (when (file-is-directory? dir) + (ensure-writable-directory dir) + (system* update-icon-cache "-t" dir)))) (scandir destdir (negate (cut member <> '("." "..")))))))) ;; Don't run the hook when there's nothing to do. -- cgit v1.3 From a54bd6d72dc91f649fb2b6cb3c612da1639d9b72 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 28 May 2015 08:41:04 -0400 Subject: guix environment: Add --ad-hoc option. * guix/scripts/environment.scm (%options): Add "ad-hoc" option. (show-help): Display help for "--ad-hoc". (packages+propagated-inputs): New procedure. (guix-environment): Create ad hoc environment when asked. * doc/guix.texi ("invoking guix environment"): Document it. --- doc/guix.texi | 17 ++++++++++++++++- guix/scripts/environment.scm | 27 ++++++++++++++++++++++++--- 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 1956dbc42..2d10ec9b5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2381,7 +2381,7 @@ the @code{#:haddock-flags} parameter. If the file @code{Setup.hs} is not found, the build system looks for @code{Setup.lhs} instead. Which Haskell compiler is used can be specified with the @code{#:haskell} -parameter which defaults to @code{ghc}. +parameter which defaults to @code{ghc}. @end defvr Lastly, for packages that do not need anything as sophisticated, a @@ -3932,6 +3932,21 @@ evaluates to. @item -E @var{command} Execute @var{command} in the new environment. +@item --ad-hoc +Include all specified packages in the resulting environment, as if an +@i{ad hoc} package were defined with them as inputs. This option is +useful for quickly creating an environment without having to write a +package expression to contain the desired inputs. + +For instance, the command: + +@example +guix environment --ad-hoc guile guile-sdl -E guile +@end example + +runs @command{guile} in an environment where Guile and Guile-SDL are +available. + @item --pure Unset existing environment variables when building the new environment. This has the effect of creating an environment in which search paths diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d053daf02..42178091e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 David Thompson +;;; Copyright © 2014, 2015 David Thompson ;;; Copyright © 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. @@ -102,6 +102,9 @@ shell command in that environment.\n")) FILE evaluates to")) (display (_ " -E, --exec=COMMAND execute COMMAND in new environment")) + (display (_ " + --ad-hoc include all specified packages in the environment instead + of only their inputs")) (display (_ " --pure unset existing environment variables")) (display (_ " @@ -147,6 +150,9 @@ shell command in that environment.\n")) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '("ad-hoc") #f #f + (lambda (opt name arg result) + (alist-cons 'ad-hoc? #t result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -191,6 +197,18 @@ packages." (delete-duplicates (append-map transitive-inputs packages))) +(define (packages+propagated-inputs packages) + "Return a list containing PACKAGES plus all of their propagated inputs." + (delete-duplicates + (append packages + (map (match-lambda + ((or (_ (? package? package)) + (_ (? package? package) _)) + package) + (_ #f)) + (append-map package-transitive-propagated-inputs + packages))))) + (define (build-inputs inputs opts) "Build the packages in INPUTS using the build options in OPTS." (let ((substitutes? (assoc-ref opts 'substitutes?)) @@ -218,9 +236,12 @@ packages." (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (pure? (assoc-ref opts 'pure)) + (ad-hoc? (assoc-ref opts 'ad-hoc?)) (command (assoc-ref opts 'exec)) - (inputs (packages->transitive-inputs - (pick-all (options/resolve-packages opts) 'package))) + (packages (pick-all (options/resolve-packages opts) 'package)) + (inputs (if ad-hoc? + (packages+propagated-inputs packages) + (packages->transitive-inputs packages))) (drvs (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) -- cgit v1.3 From 307153c1ef16132fffebe96cc67ad662e37006a4 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Wed, 27 May 2015 21:08:31 +0300 Subject: emacs: Report about "search paths" after operation. * guix/scripts/package.scm: Export 'display-search-paths'. * emacs/guix-main.scm (process-package-actions): Use it. --- emacs/guix-main.scm | 3 ++- guix/scripts/package.scm | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm index b1662fbb8..c6e4a8259 100644 --- a/emacs/guix-main.scm +++ b/emacs/guix-main.scm @@ -878,7 +878,8 @@ OUTPUTS is a list of package outputs (may be an empty list)." (format #t (N_ "~a package in profile~%" "~a packages in profile~%" count) - count)))))))))) + count) + (display-search-paths entries profile)))))))))) (define (delete-generations* profile generations) "Delete GENERATIONS from PROFILE. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 9da6b9ec1..0df822ec1 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -53,6 +53,7 @@ roll-back delete-generation delete-generations + display-search-paths guix-package)) (define %store -- cgit v1.3 From 23185ceadcb522c702cde28be2b5a7379d4ee9f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 May 2015 21:54:28 +0200 Subject: ui: Do not call 'display-error' for SRFI-34 exceptions. * guix/ui.scm (report-load-error, warn-about-load-error, read/eval): Add clause for SRFI-34 exceptions. --- guix/ui.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 2140c2e50..94e2c4eec 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -229,6 +229,8 @@ ARGS is the list of arguments received by the 'throw' handler." (let ((loc (source-properties->location properties))) (format (current-error-port) (_ "~a: error: ~a~%") (location->string loc) message))) + (('srfi-34 obj) + (report-error (_ "exception thrown: ~s~%") obj)) ((error args ...) (report-error (_ "failed to load '~a':~%") file) (apply display-error frame (current-error-port) args)))) @@ -244,6 +246,9 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (let ((loc (source-properties->location properties))) (format (current-error-port) (_ "~a: warning: ~a~%") (location->string loc) message))) + (('srfi-34 obj) + (warning (_ "failed to load '~a': exception thrown: ~s~%") + file obj)) ((error args ...) (warning (_ "failed to load '~a':~%") file) (apply display-error #f (current-error-port) args)))) @@ -450,6 +455,8 @@ interpreted." (match args (('syntax-error proc message properties form . rest) (report-error (_ "syntax error: ~a~%") message)) + (('srfi-34 obj) + (report-error (_ "exception thrown: ~s~%") obj)) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) -- cgit v1.3 From 1a706ff5cf12202c80bcaafb77a3cab43bac6f4f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 May 2015 21:59:43 +0200 Subject: base32: Use a custom error condition instead of 'misc-error'. Suggested by Christopher Allan Webber . * guix/base32.scm (&invalid-base32-character): New error condition. (make-base32-string->bytevector): Use it instead of 'error'. * tests/base32.scm ("&invalid-base32-character"): New test. --- guix/base32.scm | 21 ++++++++++++++++++--- tests/base32.scm | 10 +++++++++- 2 files changed, 27 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/base32.scm b/guix/base32.scm index e0599dc01..7b2e2a671 100644 --- a/guix/base32.scm +++ b/guix/base32.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,8 @@ (define-module (guix base32) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-60) #:use-module (rnrs bytevectors) #:use-module (ice-9 vlist) @@ -25,7 +27,11 @@ bytevector->base32-string bytevector->nix-base32-string base32-string->bytevector - nix-base32-string->bytevector)) + nix-base32-string->bytevector + &invalid-base32-character + invalid-base32-character? + invalid-base32-character-value + invalid-base32-character-string)) ;;; Commentary: ;;; @@ -264,6 +270,12 @@ starting from the right of S." s) bv)) +;; Invalid base32 character error condition when decoding base32. +(define-condition-type &invalid-base32-character &error + invalid-base32-character? + (character invalid-base32-character-value) + (string invalid-base32-character-string)) + (define (make-base32-string->bytevector base32-string-unfold base32-chars) (let ((char->value (let loop ((i 0) (v vlist-null)) @@ -276,7 +288,10 @@ starting from the right of S." "Return the binary representation of base32 string S as a bytevector." (base32-string-unfold (lambda (chr) (or (and=> (vhash-assv chr char->value) cdr) - (error "invalid base32 character" chr))) + (raise (condition + (&invalid-base32-character + (character chr) + (string s)))))) s)))) (define base32-string->bytevector diff --git a/tests/base32.scm b/tests/base32.scm index 81d242355..dcd926f4b 100644 --- a/tests/base32.scm +++ b/tests/base32.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix base32) #:use-module (guix utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (ice-9 rdelim) #:use-module (ice-9 popen) @@ -77,6 +78,13 @@ ;; Examples from RFC 4648. (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) +(test-equal "&invalid-base32-character" + #\e + (guard (c ((invalid-base32-character? c) + (invalid-base32-character-value c))) + (nix-base32-string->bytevector + (string-append (make-string 51 #\a) "e")))) + ;; The following test requires `nix-hash' in $PATH. (unless %have-nix-hash? (test-skip 1)) -- cgit v1.3 From 91a0b9cc0bd60864aac43ca137d66f3aea1f92b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 May 2015 23:13:09 +0200 Subject: lint: 'validate-uri' really returns #f on failure. * guix/scripts/lint.scm (validate-uri): Always return #f on failure. --- guix/scripts/lint.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index cced1bda6..b04e39997 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -287,20 +287,22 @@ response from URI, and additional details, such as the actual HTTP response." (values 'unknown-protocol #f))))) (define (validate-uri uri package field) - "Return #t if the given URI can be reached, otherwise emit a + "Return #t if the given URI can be reached, otherwise return #f and emit a warning for PACKAGE mentionning the FIELD." (let-values (((status argument) (probe-uri uri))) (case status ((http-response) (or (= 200 (response-code argument)) - (emit-warning package - (format #f - (_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - field))) + (begin + (emit-warning package + (format #f + (_ "URI ~a not reachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + field) + #f))) ((ftp-response) (match argument (('ok) #t) @@ -309,7 +311,8 @@ warning for PACKAGE mentionning the FIELD." (format #f (_ "URI ~a not reachable: ~a (~s)") (uri->string uri) - code (string-trim-both message)))))) + code (string-trim-both message))) + #f))) ((getaddrinfo-error) (emit-warning package (format #f -- cgit v1.3 From 2b5115f8ba62f3d36f39c0c6ee3b49fbc04e986a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 May 2015 23:22:29 +0200 Subject: lint: source: Warn only when all the URIs are unreachable. * guix/scripts/lint.scm (call-with-accumulated-warnings): New procedure. (with-accumulated-warnings): New macro. (check-source): Add 'try-uris' and use it. Emit warnings only upon failure. --- guix/scripts/lint.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 48 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b04e39997..3b139ce6b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -28,6 +28,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix gnu-maintenance) + #:use-module (guix monads) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -41,6 +42,7 @@ #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-6) ;Unicode string ports #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -71,6 +73,25 @@ (package-full-name package) message))) +(define (call-with-accumulated-warnings thunk) + "Call THUNK, accumulating any warnings in the current state, using the state +monad." + (let ((port (open-output-string))) + (mlet %state-monad ((state (current-state)) + (result -> (parameterize ((guix-warning-port port)) + (thunk))) + (warning -> (get-output-string port))) + (mbegin %state-monad + (munless (string=? "" warning) + (set-current-state (cons warning state))) + (return result))))) + +(define-syntax-rule (with-accumulated-warnings exp ...) + "Evaluate EXP and accumulate warnings in the state monad." + (call-with-accumulated-warnings + (lambda () + exp ...))) + ;;; ;;; Checkers @@ -435,6 +456,16 @@ descriptions maintained upstream." (define (check-source package) "Emit a warning if PACKAGE has an invalid 'source' field, or if that 'source' is not reachable." + (define (try-uris uris) + (run-with-state + (anym %state-monad + (lambda (uri) + (with-accumulated-warnings + (validate-uri uri package 'source))) + (append-map (cut maybe-expand-mirrors <> %mirrors) + uris)) + '())) + (let ((origin (package-source package))) (when (and origin (eqv? (origin-method origin) url-fetch)) @@ -442,10 +473,24 @@ descriptions maintained upstream." (uris (if (list? strings) (map string->uri strings) (list (string->uri strings))))) + ;; Just make sure that at least one of the URIs is valid. - (any (cut validate-uri <> package 'source) - (append-map (cut maybe-expand-mirrors <> %mirrors) - uris)))))) + (call-with-values + (lambda () (try-uris uris)) + (lambda (success? warnings) + ;; When everything fails, report all of WARNINGS, otherwise don't + ;; report anything. + ;; + ;; XXX: Ideally we'd still allow warnings to be raised if *some* + ;; URIs are unreachable, but distinguish that from the error case + ;; where *all* the URIs are unreachable. + (unless success? + (emit-warning package + (_ "all the source URIs are unreachable:") + 'source) + (for-each (lambda (warning) + (display warning (guix-warning-port))) + (reverse warnings))))))))) (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." -- cgit v1.3 From d7bc3470b76268fb121868960aab04c88a4d712f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Jun 2015 21:50:07 +0200 Subject: gnu-maintenance: latest-release: Honor releases that are not in subdirs. Reported by Mark H Weaver. * guix/gnu-maintenance.scm (latest-release): Add 'result' parameter to 'loop'. When entering a sub-directory, use the current directory's latest release as 'result'. This fixes the code for 'gnu-pw-mgr' and 'sharutils'. --- guix/gnu-maintenance.scm | 61 +++++++++++++++++++++++++++--------------------- 1 file changed, 34 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 5cdda28bc..8d47cee48 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -357,7 +357,8 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) - (let loop ((directory directory)) + (let loop ((directory directory) + (result #f)) (let* ((entries (ftp-list conn directory)) ;; Filter out sub-directories that do not contain digits---e.g., @@ -369,32 +370,38 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (((? contains-digit? dir) 'directory . _) dir) (_ #f)) - entries))) - (match subdirs - (() - ;; No sub-directories, so assume that tarballs are here. - (let ((releases (filter-map (match-lambda - ((file 'file . _) - (and (release-file? project file) - (gnu-release - (package project) - (version - (tarball->version file)) - (directory directory) - (files (list file))))) - (_ #f)) - entries))) - (ftp-close conn) - (reduce latest-release #f (coalesce-releases releases)))) - ((subdirs ...) - ;; Assume that SUBDIRS correspond to versions, and jump into the - ;; one with the highest version number. - (let ((target (reduce latest #f subdirs))) - (if target - (loop (string-append directory "/" target)) - (begin - (ftp-close conn) - #f))))))))) + entries)) + + ;; Whether or not SUBDIRS is empty, compute the latest releases + ;; for the current directory. This is necessary for packages + ;; such as 'sharutils' that have a sub-directory that contains + ;; only an older release. + (releases (filter-map (match-lambda + ((file 'file . _) + (and (release-file? project file) + (gnu-release + (package project) + (version + (tarball->version file)) + (directory directory) + (files (list file))))) + (_ #f)) + entries))) + + ;; Assume that SUBDIRS correspond to versions, and jump into the + ;; one with the highest version number. + (let* ((release (reduce latest-release #f + (coalesce-releases releases))) + (result (if (and result release) + (latest-release release result) + (or release result))) + (target (reduce latest #f subdirs))) + (if target + (loop (string-append directory "/" target) + result) + (begin + (ftp-close conn) + result))))))) (define (gnu-release-archive-types release) "Return the available types of archives for RELEASE---a list of strings such -- cgit v1.3 From 74d441abeee257f5d7ec5bb5fa0db70bd26802b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Jun 2015 11:21:15 +0200 Subject: gexp: Export accessors. * guix/gexp.scm (local-file-file, local-file-name, local-file-recursive?): Export. --- guix/gexp.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index b08a36123..03b4cbf19 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -33,6 +33,9 @@ gexp-input? local-file local-file? + local-file-file + local-file-name + local-file-recursive? gexp->derivation gexp->file -- cgit v1.3 From 558e8b11d77ed79c1ae0baf5fda66cfc083bab4b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Jun 2015 11:45:27 +0200 Subject: gexp: Add 'plain-file'. * guix/gexp.scm (): New type. (plain-file, plain-file-compiler): New procedures. * tests/gexp.scm ("one plain file"): New test. * doc/guix.texi (G-Expressions): Document 'plain-file'. --- doc/guix.texi | 10 +++++++++- guix/gexp.scm | 30 +++++++++++++++++++++++++++++- tests/gexp.scm | 10 ++++++++++ 3 files changed, 48 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 2d10ec9b5..665bdb028 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2948,7 +2948,8 @@ derivations can be defined, such that these objects can also be inserted into gexps. Another useful type of high-level object that can be inserted in a gexp is @dfn{local files}, which allows files from the local file system to be added to the store and referred to by -derivations and such (see @code{local-file} below.) +derivations and such (see @code{local-file} and @code{plain-file} +below.) To illustrate the idea, here is an example of a gexp: @@ -3126,6 +3127,13 @@ This is the declarative counterpart of the @code{interned-file} monadic procedure (@pxref{The Store Monad, @code{interned-file}}). @end deffn +@deffn {Scheme Procedure} plain-file @var{name} @var{content} +Return an object representing a text file called @var{name} with the given +@var{content} (a string) to be added to the store. + +This is the declarative counterpart of @code{text-file}. +@end deffn + @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} Return an executable script @var{name} that runs @var{exp} using @var{guile} with @var{modules} in its search path. diff --git a/guix/gexp.scm b/guix/gexp.scm index 03b4cbf19..10056e5a1 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -31,12 +31,18 @@ gexp-input gexp-input? + local-file local-file? local-file-file local-file-name local-file-recursive? + plain-file + plain-file? + plain-file-name + plain-file-content + gexp->derivation gexp->file gexp->script @@ -140,7 +146,7 @@ cross-compiling.)" ;;; -;;; Local files. +;;; File declarations. ;;; (define-record-type @@ -169,6 +175,28 @@ This is the declarative counterpart of the 'interned-file' monadic procedure." (($ file name recursive?) (interned-file file name #:recursive? recursive?)))) +(define-record-type + (%plain-file name content references) + plain-file? + (name plain-file-name) ;string + (content plain-file-content) ;string + (references plain-file-references)) ;list (currently unused) + +(define (plain-file name content) + "Return an object representing a text file called NAME with the given +CONTENT (a string) to be added to the store. + +This is the declarative counterpart of 'text-file'." + ;; XXX: For now just ignore 'references' because it's not clear how to use + ;; them in a declarative context. + (%plain-file name content '())) + +(define-gexp-compiler (plain-file-compiler (file plain-file?) system target) + ;; "Compile" FILE by adding it to the store. + (match file + (($ name content references) + (text-file name content references)))) + ;;; ;;; Inputs & outputs. diff --git a/tests/gexp.scm b/tests/gexp.scm index f81ef3986..7e14073fd 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -109,6 +109,16 @@ (eq? x local))) (equal? `(display ,intd) (gexp->sexp* exp))))) +(test-assert "one plain file" + (let* ((file (plain-file "hi" "Hello, world!")) + (exp (gexp (display (ungexp file)))) + (expected (add-text-to-store %store "hi" "Hello, world!"))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((x "out")) + (eq? x file))) + (equal? `(display ,expected) (gexp->sexp* exp))))) + (test-assert "same input twice" (let ((exp (gexp (begin (display (ungexp coreutils)) -- cgit v1.3 From c058f4eca2cb17496cdcf1b1c755a04b9ab4b423 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 3 Jun 2015 01:18:26 -0400 Subject: licenses: Add the Open Publication License 1.0. * guix/licenses.scm (opl1.0+): New variable. --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 1be35001f..480442158 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -37,6 +37,7 @@ freetype gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ fdl1.3+ + opl1.0+ isc ijg ibmpl1.0 @@ -206,6 +207,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/fdl.html" "https://www.gnu.org/licenses/license-list#FDL")) +(define opl1.0+ + (license "Open Publication License 1.0 or later" + "http://opencontent.org/openpub/" + "https://www.gnu.org/licenses/license-list#OpenPublicationL")) + (define isc (license "ISC" "http://directory.fsf.org/wiki/License:ISC" -- cgit v1.3 From d2aa12250ece6d71ef1edee2ea2a69ccf70ac354 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Sat, 6 Jun 2015 18:32:03 +0300 Subject: guix package: Fix typo in --help message. * guix/scripts/package.scm (show-help): Align '--show' option properly. --- guix/scripts/package.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 0df822ec1..4ae511480 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -469,7 +469,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -A, --list-available[=REGEXP] list available packages matching REGEXP")) (display (_ " - --show=PACKAGE show details about PACKAGE")) + --show=PACKAGE show details about PACKAGE")) (newline) (show-build-options-help) (newline) -- cgit v1.3 From c63d94035f7cff02d885f9deaaf4011d52a1151d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Jun 2015 19:05:25 +0200 Subject: store: Add 'verify-store' RPC. * guix/store.scm (operation-id): Add 'verify-store'. (verify-store): New procedure. (set-build-options): Adjust comment. * tests/store.scm ("verify-store", "verify-store + check-contents"): New tests. --- .dir-locals.el | 2 +- guix/store.scm | 21 ++++++++++++++++++--- tests/store.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 7ac7e13ff..cbcb120ed 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -46,7 +46,7 @@ (eval . (put 'emacs-substitute-sexps 'scheme-indent-function 1)) (eval . (put 'emacs-substitute-variables 'scheme-indent-function 1)) (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1)) - (eval . (put 'with-derivation-substitute 'scheme-indent-function 1)) + (eval . (put 'with-derivation-substitute 'scheme-indent-function 2)) (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) (eval . (put 'with-monad 'scheme-indent-function 1)) diff --git a/guix/store.scm b/guix/store.scm index 8905a5a55..933708def 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -91,6 +91,7 @@ requisites referrers optimize-store + verify-store topologically-sorted valid-derivers query-derivation-outputs @@ -174,7 +175,8 @@ (query-valid-paths 31) (query-substitutable-paths 32) (query-valid-derivers 33) - (optimize-store 34)) + (optimize-store 34) + (verify-store 35)) (define-enumerate-type hash-algo ;; hash.hh @@ -497,8 +499,8 @@ encoding conversion errors." ;; Client-provided substitute URLs. For ;; unprivileged clients, these are considered - ;; "untrusted"; for root, they override the - ;; daemon's settings. + ;; "untrusted"; for "trusted" users, they override + ;; the daemon's settings. (substitute-urls %default-substitute-urls)) ;; Must be called after `open-connection'. @@ -769,6 +771,19 @@ Return #t on success." ;; Note: the daemon in Guix <= 0.8.2 does not implement this RPC. boolean) +(define verify-store + (let ((verify (operation (verify-store (boolean check-contents?) + (boolean repair?)) + "Verify the store." + boolean))) + (lambda* (store #:key check-contents? repair?) + "Verify the integrity of the store and return false if errors remain, +and true otherwise. When REPAIR? is true, repair any missing or altered store +items by substituting them (this typically requires root privileges because it +is not an atomic operation.) When CHECK-CONTENTS? is true, check the contents +of store items; this can take a lot of time." + (not (verify store check-contents? repair?))))) + (define (run-gc server action to-delete min-freed) "Perform the garbage-collector operation ACTION, one of the `gc-action' values. When ACTION is `delete-specific', the TO-DELETE is diff --git a/tests/store.scm b/tests/store.scm index eeceed45c..faa924fce 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -600,6 +600,60 @@ (null? (valid-derivers %store file)) (null? (referrers %store file)))))) +(test-assert "verify-store" + (let* ((text (random-text)) + (file1 (add-text-to-store %store "foo" text)) + (file2 (add-text-to-store %store "bar" (random-text) + (list file1)))) + (and (pk 'verify1 (verify-store %store)) ;hopefully OK ; + (begin + (delete-file file1) + (not (pk 'verify2 (verify-store %store)))) ;bad! ; + (begin + ;; Using 'add-text-to-store' here wouldn't work: It would succeed ; + ;; without actually creating the file. ; + (call-with-output-file file1 + (lambda (port) + (display text port))) + (pk 'verify3 (verify-store %store)))))) ;OK again + +(test-assert "verify-store + check-contents" + ;; XXX: This test is I/O intensive. + (with-store s + (let* ((text (random-text)) + (drv (build-expression->derivation + s "corrupt" + `(let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (display ,text port))) + #t) + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (file (derivation->output-path drv))) + (with-derivation-substitute drv text + (and (build-derivations s (list drv)) + (verify-store s #:check-contents? #t) ;should be OK + (begin + (chmod file #o644) + (call-with-output-file file + (lambda (port) + (display "corrupt!" port))) + #t) + + ;; Make sure the corruption is detected. We don't test repairing + ;; because only "trusted" users are allowed to do it, but we + ;; don't expose that notion of trusted users that nix-daemon + ;; supports because it seems dubious and redundant with what the + ;; OS provides (in Nix "trusted" users have additional + ;; privileges, such as overriding the set of substitute URLs, but + ;; we instead want to allow anyone to modify them, provided + ;; substitutes are signed by a root-approved key.) + (not (verify-store s #:check-contents? #t)) + + ;; Delete the corrupt item to leave the store in a clean state. + (delete-paths s (list file))))))) + (test-equal "store-lower" "Lowered." (let* ((add (store-lower text-file)) -- cgit v1.3 From 7770aafc7561897ff1d3c706420f76843c5182c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Jun 2015 18:56:04 +0200 Subject: guix gc: Add '--verify'. * guix/scripts/gc.scm (show-help, %options): Add --verify. (guix-gc): Handle it. * doc/guix.texi (Invoking guix gc): Document --verify, and move --optimize description right below it. --- doc/guix.texi | 57 +++++++++++++++++++++++++++++++++++++++++------------ guix/scripts/gc.scm | 22 +++++++++++++++++++++ 2 files changed, 66 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index f8da9c122..c10274663 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1541,8 +1541,9 @@ is achieved by running @code{guix package --delete-generations} The @command{guix gc} command has three modes of operation: it can be used to garbage-collect any dead files (the default), to delete specific -files (the @code{--delete} option), or to print garbage-collector -information. The available options are listed below: +files (the @code{--delete} option), to print garbage-collector +information, or for more advanced queries. The garbage collection +options are as follows: @table @code @item --collect-garbage[=@var{min}] @@ -1564,17 +1565,6 @@ Attempt to delete all the store files and directories specified as arguments. This fails if some of the files are not in the store, or if they are still live. -@item --optimize -@cindex deduplication -Optimize the store by hard-linking identical files---this is -@dfn{deduplication}. - -The daemon performs deduplication after each successful build or archive -import, unless it was started with @code{--disable-deduplication} -(@pxref{Invoking guix-daemon, @code{--disable-deduplication}}). Thus, -this option is primarily useful when the daemon was running with -@code{--disable-deduplication}. - @item --list-dead Show the list of dead files and directories still present in the store---i.e., files and directories no longer reachable from any root. @@ -1602,6 +1592,47 @@ of these, recursively. In other words, the returned list is the @end table +Lastly, the following options allow you to check the integrity of the +store and to control disk usage. + +@table @option + +@item --verify[=@var{options}] +@cindex integrity, of the store +@cindex integrity checking +Verify the integrity of the store. + +By default, make sure that all the store items marked as valid in the +daemon's database actually exist in @file{/gnu/store}. + +When provided, @var{options} must a comma-separated list containing one +or more of @code{contents} and @code{repair}. + +When passing @option{--verify=contents}, the daemon will compute the +content hash of each store item and compare it against its hash in the +database. Hash mismatches are reported as data corruptions. Because it +traverses @emph{all the files in the store}, this command can take a +long time, especially on systems with a slow disk drive. + +@cindex repairing the store +Using @option{--verify=repair} or @option{--verify=contents,repair} +causes the daemon to try to repair corrupt store items by fetching +substitutes for them (@pxref{Substitutes}). Because repairing is not +atomic, and thus potentially dangerous, it is available only to the +system administrator. + +@item --optimize +@cindex deduplication +Optimize the store by hard-linking identical files---this is +@dfn{deduplication}. + +The daemon performs deduplication after each successful build or archive +import, unless it was started with @code{--disable-deduplication} +(@pxref{Invoking guix-daemon, @code{--disable-deduplication}}). Thus, +this option is primarily useful when the daemon was running with +@code{--disable-deduplication}. + +@end table @node Invoking guix pull @section Invoking @command{guix pull} diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index a250cdc19..640389368 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -57,6 +57,11 @@ Invoke the garbage collector.\n")) (display (_ " --referrers list the referrers of PATHS")) (newline) + (display (_ " + --verify[=OPTS] verify the integrity of the store; OPTS is a + comma-separated combination of 'repair' and + 'contents'")) + (newline) (display (_ " -h, --help display this help and exit")) (display (_ " @@ -94,6 +99,17 @@ Invoke the garbage collector.\n")) (lambda (opt name arg result) (alist-cons 'action 'optimize (alist-delete 'action result)))) + (option '("verify") #f #t + (let ((not-comma (char-set-complement (char-set #\,)))) + (lambda (opt name arg result) + (let ((options (if arg + (map string->symbol + (string-tokenize arg not-comma)) + '()))) + (alist-cons 'action 'verify + (alist-cons 'verify-options options + (alist-delete 'action + result))))))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -177,6 +193,12 @@ Invoke the garbage collector.\n")) (list-relatives referrers)) ((optimize) (optimize-store store)) + ((verify) + (let ((options (assoc-ref opts 'verify-options))) + (exit + (verify-store store + #:check-contents? (memq 'contents options) + #:repair? (memq 'repair options))))) ((list-dead) (for-each (cut simple-format #t "~a~%" <>) (dead-paths store))) -- cgit v1.3 From 2a4e2e4b015ceeb5a0a55e9ab0484b5136c324cd Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Sun, 7 Jun 2015 11:46:06 +0300 Subject: guix: Clean up --help messages. * guix/scripts/import.scm (show-help): Add newline before a list of importers. * guix/scripts/lint.scm (show-help): Split a long description line. * guix/scripts/package.scm (show-help): Improve docstrings for --install and --remove options. * guix/scripts/system.scm (show-help): Format actions the same way as guix commands and importers are formatted. --- guix/scripts/import.scm | 1 + guix/scripts/lint.scm | 3 ++- guix/scripts/package.scm | 10 ++++++---- guix/scripts/system.scm | 13 +++++++------ 4 files changed, 16 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 06b4c1757..45ce092f1 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -86,6 +86,7 @@ rather than \\n." Run IMPORTER with ARGS.\n")) (newline) (display (_ "IMPORTER must be one of the importers listed below:\n")) + (newline) (format #t "~{ ~a~%~}" importers) (display (_ " -h, --help display this help and exit")) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 3b139ce6b..3740b71d5 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -575,7 +575,8 @@ descriptions maintained upstream." (define (show-help) (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... -Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n")) +Run a set of checkers on the specified package; if none is specified, +run the checkers on all packages.\n")) (display (_ " -c, --checkers=CHECKER1,CHECKER2... only run the specificed checkers")) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4ae511480..d9f38fb8b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -422,15 +422,17 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (substitutes? . #t))) (define (show-help) - (display (_ "Usage: guix package [OPTION]... PACKAGES... -Install, remove, or upgrade PACKAGES in a single transaction.\n")) + (display (_ "Usage: guix package [OPTION]... +Install, remove, or upgrade packages in a single transaction.\n")) (display (_ " - -i, --install=PACKAGE install PACKAGE")) + -i, --install PACKAGE ... + install PACKAGEs")) (display (_ " -e, --install-from-expression=EXP install the package EXP evaluates to")) (display (_ " - -r, --remove=PACKAGE remove PACKAGE")) + -r, --remove PACKAGE ... + remove PACKAGEs")) (display (_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b6d7d0d04..f7c9d83e9 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -368,18 +368,19 @@ boot directly to the kernel or to the bootloader." Build the operating system declared in FILE according to ACTION.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) + (newline) (display (_ "\ - - 'reconfigure', switch to a new operating system configuration\n")) + reconfigure switch to a new operating system configuration\n")) (display (_ "\ - - 'build', build the operating system without installing anything\n")) + build build the operating system without installing anything\n")) (display (_ "\ - - 'vm', build a virtual machine image that shares the host's store\n")) + vm build a virtual machine image that shares the host's store\n")) (display (_ "\ - - 'vm-image', build a freestanding virtual machine image\n")) + vm-image build a freestanding virtual machine image\n")) (display (_ "\ - - 'disk-image', build a disk image, suitable for a USB stick\n")) + disk-image build a disk image, suitable for a USB stick\n")) (display (_ "\ - - 'init', initialize a root file system to run GNU.\n")) + init initialize a root file system to run GNU.\n")) (show-build-options-help) (display (_ " -- cgit v1.3 From 751630c9c3f7f3e87dfccc5f5ba8cf61cdd6f8fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Jun 2015 22:49:50 +0200 Subject: monads: Allow n-ary '>>=' expressions. Suggested by Federico Beffa . * guix/monads.scm (bind-syntax): New macro. (with-monad): Use it instead of 'identifier-syntax'. * tests/monads.scm (">>= with more than two arguments"): New test. * doc/guix.texi (The Store Monad): Explain that there can be several MPROC. Add an example. --- doc/guix.texi | 23 ++++++++++++++++++----- guix/monads.scm | 27 +++++++++++++++++++++++++-- tests/monads.scm | 13 +++++++++++++ 3 files changed, 56 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index bcfa52d5b..85ccd4057 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2773,12 +2773,25 @@ in @var{monad}. Return a monadic value that encapsulates @var{val}. @end deffn -@deffn {Scheme Syntax} >>= @var{mval} @var{mproc} +@deffn {Scheme Syntax} >>= @var{mval} @var{mproc} ... @dfn{Bind} monadic value @var{mval}, passing its ``contents'' to monadic -procedure @var{mproc}@footnote{This operation is commonly referred to as -``bind'', but that name denotes an unrelated procedure in Guile. Thus -we use this somewhat cryptic symbol inherited from the Haskell -language.}. +procedures @var{mproc}@dots{}@footnote{This operation is commonly +referred to as ``bind'', but that name denotes an unrelated procedure in +Guile. Thus we use this somewhat cryptic symbol inherited from the +Haskell language.}. There can be one @var{mproc} or several of them, as +in this example: + +@example +(run-with-state + (with-monad %state-monad + (>>= (return 1) + (lambda (x) (return (+ 1 x))) + (lambda (x) (return (* 2 x))))) + 'some-state) + +@result{} 4 +@result{} some-state +@end example @end deffn @deffn {Scheme Syntax} mlet @var{monad} ((@var{var} @var{mval}) ...) @ diff --git a/guix/monads.scm b/guix/monads.scm index 424852543..2196a9c99 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -112,6 +112,29 @@ (lambda (s) (syntax-violation 'return "return used outside of 'with-monad'" s))) +(define-syntax-rule (bind-syntax bind) + "Return a macro transformer that handles the expansion of '>>=' expressions +using BIND as the binary bind operator. + +This macro exists to allow the expansion of n-ary '>>=' expressions, even +though BIND is simply binary, as in: + + (with-monad %state-monad + (>>= (return 1) + (lift 1+ %state-monad) + (lift 1+ %state-monad))) +" + (lambda (stx) + (define (expand body) + (syntax-case body () + ((_ mval mproc) + #'(bind mval mproc)) + ((x mval mproc0 mprocs (... ...)) + (expand #'(>>= (>>= mval mproc0) + mprocs (... ...)))))) + + (expand stx))) + (define-syntax with-monad (lambda (s) "Evaluate BODY in the context of MONAD, and return its result." @@ -120,13 +143,13 @@ (eq? 'macro (syntax-local-binding #'monad)) ;; MONAD is a syntax transformer, so we can obtain the bind and return ;; methods by directly querying it. - #'(syntax-parameterize ((>>= (identifier-syntax (monad %bind))) + #'(syntax-parameterize ((>>= (bind-syntax (monad %bind))) (return (identifier-syntax (monad %return)))) body ...)) ((_ monad body ...) ;; MONAD refers to the record that represents the monad at run ;; time, so use the slow method. - #'(syntax-parameterize ((>>= (identifier-syntax + #'(syntax-parameterize ((>>= (bind-syntax (monad-bind monad))) (return (identifier-syntax (monad-return monad)))) diff --git a/tests/monads.scm b/tests/monads.scm index 5529a6188..d3ef065f2 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -103,6 +103,19 @@ %monads %monad-run)) +(test-assert ">>= with more than two arguments" + (every (lambda (monad run) + (let ((1+ (lift1 1+ monad)) + (2* (lift1 (cut * 2 <>) monad))) + (with-monad monad + (let ((number (random 777))) + (= (run (>>= (return number) + 1+ 1+ 1+ + 2* 2* 2*)) + (* 8 (+ number 3))))))) + %monads + %monad-run)) + (test-assert "mbegin" (every (lambda (monad run) (with-monad monad -- cgit v1.3 From a4154748730b28fd98ff30d968c755c37802a49a Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sun, 26 Apr 2015 11:22:29 +0200 Subject: import: hackage: Refactor parsing code and add new options. * guix/import/cabal.scm: New file. * guix/import/hackage.scm: Update to use the new Cabal parsing module. * tests/hackage.scm: Update tests. * guix/scripts/import/hackage.scm: Add new '--cabal-environment' and '--stdin' options. * doc/guix.texi: ... and document them. * Makefile.am (MODULES): Add 'guix/import/cabal.scm', 'guix/import/hackage.scm' and 'guix/scripts/import/hackage.scm'. (SCM_TESTS): Add 'tests/hackage.scm'. --- Makefile.am | 4 + doc/guix.texi | 22 +- guix/import/cabal.scm | 815 ++++++++++++++++++++++++++++++++++++++++ guix/import/hackage.scm | 703 ++++------------------------------ guix/scripts/import/hackage.scm | 66 +++- tests/hackage.scm | 88 +++-- 6 files changed, 1017 insertions(+), 681 deletions(-) create mode 100644 guix/import/cabal.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 6478aeb8e..2b84467b0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -93,6 +93,8 @@ MODULES = \ guix/import/utils.scm \ guix/import/gnu.scm \ guix/import/snix.scm \ + guix/import/cabal.scm \ + guix/import/hackage.scm \ guix/scripts/download.scm \ guix/scripts/build.scm \ guix/scripts/archive.scm \ @@ -108,6 +110,7 @@ MODULES = \ guix/scripts/lint.scm \ guix/scripts/import/gnu.scm \ guix/scripts/import/nix.scm \ + guix/scripts/import/hackage.scm \ guix/scripts/environment.scm \ guix/scripts/publish.scm \ guix.scm \ @@ -178,6 +181,7 @@ SCM_TESTS = \ tests/build-utils.scm \ tests/packages.scm \ tests/snix.scm \ + tests/hackage.scm \ tests/store.scm \ tests/monads.scm \ tests/gexp.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index c62e44e34..be7a292f0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3754,16 +3754,30 @@ dependencies. Specific command-line options are: @table @code +@item --stdin +@itemx -s +Read a Cabal file from the standard input. @item --no-test-dependencies @itemx -t -Do not include dependencies only required to run the test suite. +Do not include dependencies required by the test suites only. +@item --cabal-environment=@var{alist} +@itemx -e @var{alist} +@var{alist} is a Scheme alist defining the environment in which the +Cabal conditionals are evaluated. The accepted keys are: @code{os}, +@code{arch}, @code{impl} and a string representing the name of a flag. +The value associated with a flag has to be either the symbol +@code{true} or @code{false}. The value associated with other keys +has to conform to the Cabal file format definition. The default value +associated with the keys @code{os}, @code{arch} and @code{impl} is +@samp{linux}, @samp{x86_64} and @samp{ghc} respectively. @end table The command below imports meta-data for the latest version of the -@code{HTTP} Haskell package without including test dependencies: +@code{HTTP} Haskell package without including test dependencies and +specifying the value of the flag @samp{network-uri} as @code{false}: @example -guix import hackage -t HTTP +guix import hackage -t -e "'((\"network-uri\" . false))" HTTP @end example A specific package version may optionally be specified by following the @@ -3772,8 +3786,6 @@ package name by a hyphen and a version number as in the following example: @example guix import hackage mtl-2.1.3.1 @end example - -Currently only indentation structured Cabal files are supported. @end table The structure of the @command{guix import} code is modular. It would be diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm new file mode 100644 index 000000000..dfeba8831 --- /dev/null +++ b/guix/import/cabal.scm @@ -0,0 +1,815 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa +;;; +;;; 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 cabal) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (system base lalr) + #:use-module (rnrs enums) + #:export (read-cabal + eval-cabal + + cabal-package? + cabal-package-name + cabal-package-version + cabal-package-license + cabal-package-home-page + cabal-package-source-repository + cabal-package-synopsis + cabal-package-description + cabal-package-executables + cabal-package-library + cabal-package-test-suites + cabal-package-flags + cabal-package-eval-environment + + cabal-source-repository? + cabal-source-repository-use-case + cabal-source-repository-type + cabal-source-repository-location + + cabal-flag? + cabal-flag-name + cabal-flag-description + cabal-flag-default + cabal-flag-manual + + cabal-dependency? + cabal-dependency-name + cabal-dependency-version + + cabal-executable? + cabal-executable-name + cabal-executable-dependencies + + cabal-library? + cabal-library-dependencies + + cabal-test-suite? + cabal-test-suite-name + cabal-test-suite-dependencies)) + +;; Part 1: +;; +;; Functions used to read a Cabal file. + +;; Comment: +;; +;; The use of virtual closing braces VCCURLY and some lexer functions were +;; inspired from http://hackage.haskell.org/package/haskell-src + +;; Object containing information about the structure of a block: (i) delimited +;; by braces or by indentation, (ii) minimum indentation. +(define-record-type + (make-parse-context mode indentation) + parse-context? + (mode parse-context-mode) ; 'layout or 'no-layout + (indentation parse-context-indentation)) ; #f for 'no-layout + +;; mode set universe +(define-enumeration context (layout no-layout) make-context) + +(define (make-stack) + "Creates a simple stack closure. Actions on the generated stack are +requested by calling it with one of the following symbols as the first +argument: 'empty?, 'push!, 'top, 'pop! and 'clear!. The action 'push! is the +only one requiring a second argument corresponding to the object to be added +to the stack." + (let ((stack '())) + (lambda (msg . args) + (cond ((eqv? msg 'empty?) (null? stack)) + ((eqv? msg 'push!) (set! stack (cons (first args) stack))) + ((eqv? msg 'top) (if (null? stack) '() (first stack))) + ((eqv? msg 'pop!) (match stack + ((e r ...) (set! stack (cdr stack)) e) + (_ #f))) + ((eqv? msg 'clear!) (set! stack '())) + (else #f))))) + +;; Stack to track the structure of nested blocks and simple interface +(define context-stack (make-parameter (make-stack))) + +(define (context-stack-empty?) ((context-stack) 'empty?)) + +(define (context-stack-push! e) ((context-stack) 'push! e)) + +(define (context-stack-top) ((context-stack) 'top)) + +(define (context-stack-pop!) ((context-stack) 'pop!)) + +(define (context-stack-clear!) ((context-stack) 'clear!)) + +;; Indentation of the line being parsed. +(define current-indentation (make-parameter 0)) + +;; Signal to reprocess the beginning of line, in case we need to close more +;; than one indentation level. +(define check-bol? (make-parameter #f)) + +;; Name of the file being parsed. Used in error messages. +(define cabal-file-name (make-parameter "unknowk")) + +;; Specify the grammar of a Cabal file and generate a suitable syntax analyser. +(define (make-cabal-parser) + "Generate a parser for Cabal files." + (lalr-parser + ;; --- token definitions + (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION + (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY) + (left: OR) + (left: PROPERTY AND) + (right: ELSE NOT)) + ;; --- rules + (body (properties sections) : (append $1 $2)) + (sections (sections flags) : (append $1 $2) + (sections source-repo) : (append $1 (list $2)) + (sections executables) : (append $1 $2) + (sections test-suites) : (append $1 $2) + (sections benchmarks) : (append $1 $2) + (sections lib-sec) : (append $1 (list $2)) + () : '()) + (flags (flags flag-sec) : (append $1 (list $2)) + (flag-sec) : (list $1)) + (flag-sec (FLAG OCURLY properties CCURLY) : `(section flag ,$1 ,$3) + (FLAG open properties close) : `(section flag ,$1 ,$3) + (FLAG) : `(section flag ,$1 '())) + (source-repo (SOURCE-REPO OCURLY properties CCURLY) + : `(section source-repository ,$1 ,$3) + (SOURCE-REPO open properties close) + : `(section source-repository ,$1 ,$3)) + (properties (properties PROPERTY) : (append $1 (list $2)) + (PROPERTY) : (list $1)) + (executables (executables exec-sec) : (append $1 (list $2)) + (exec-sec) : (list $1)) + (exec-sec (EXEC OCURLY exprs CCURLY) : `(section executable ,$1 ,$3) + (EXEC open exprs close) : `(section executable ,$1 ,$3)) + (test-suites (test-suites ts-sec) : (append $1 (list $2)) + (ts-sec) : (list $1)) + (ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3) + (TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3)) + (benchmarks (benchmarks bm-sec) : (append $1 (list $2)) + (bm-sec) : (list $1)) + (bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3) + (BENCHMARK open exprs close) : `(section benchmark ,$1 ,$3)) + (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$3) + (LIB open exprs close) : `(section library ,$3)) + (exprs (exprs PROPERTY) : (append $1 (list $2)) + (PROPERTY) : (list $1) + (exprs if-then-else) : (append $1 (list $2)) + (if-then-else) : (list $1) + (exprs if-then) : (append $1 (list $2)) + (if-then) : (list $1)) + (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY) + : `(if ,$2 ,$4 ,$8) + (IF tests open exprs close ELSE OCURLY exprs CCURLY) + : `(if ,$2 ,$4 ,$8) + ;; The 'open' token after 'tests' is shifted after an 'exprs' + ;; is found. This is because, instead of 'exprs' a 'OCURLY' + ;; token is a valid alternative. For this reason, 'open' + ;; pushes a with a line indentation equal to + ;; the indentation of 'exprs'. + ;; + ;; Differently from this, without the rule above this + ;; comment, when an 'ELSE' token is found, the 'open' token + ;; following the 'ELSE' would be shifted immediately, before + ;; the 'exprs' is found (because there are no other valid + ;; tokens). The 'open' would therefore create a + ;; with the indentation of 'ELSE' and not + ;; 'exprs', creating an inconsistency. We therefore allow + ;; mixed style conditionals. + (IF tests open exprs close ELSE open exprs close) + : `(if ,$2 ,$4 ,$8)) + (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ()) + (IF tests open exprs close) : `(if ,$2 ,$4 ())) + (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) + (TEST OPAREN ID RELATION VERSION CPAREN) + : `(,$1 ,(string-append $3 " " $4 " " $5)) + (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN) + : `(and (,$1 ,(string-append $3 " " $4 " " $5)) + (,$1 ,(string-append $3 " " $7 " " $8))) + (NOT tests) : `(not ,$2) + (tests AND tests) : `(and ,$1 ,$3) + (tests OR tests) : `(or ,$1 ,$3) + (OPAREN tests CPAREN) : $2) + (open () : (context-stack-push! + (make-parse-context (context layout) + (current-indentation)))) + (close (VCCURLY)))) + +(define (peek-next-line-indent port) + "This function can be called when the next character on PORT is #\newline +and returns the indentation of the line starting after the #\newline +character. Discard (and consume) empty and comment lines." + (let ((initial-newline (string (read-char port)))) + (let loop ((char (peek-char port)) + (word "")) + (cond ((eqv? char #\newline) (read-char port) + (loop (peek-char port) "")) + ((or (eqv? char #\space) (eqv? char #\tab)) + (let ((c (read-char port))) + (loop (peek-char port) (string-append word (string c))))) + ((comment-line port char) (loop (peek-char port) "")) + (else + (let ((len (string-length word))) + (unread-string (string-append initial-newline word) port) + len)))))) + +(define* (read-value port value min-indent #:optional (separator " ")) + "The next character on PORT must be #\newline. Append to VALUE the +following lines with indentation larger than MIN-INDENT." + (let loop ((val (string-trim-both value)) + (x (peek-next-line-indent port))) + (if (> x min-indent) + (begin + (read-char port) ; consume #\newline + (loop (string-append + val (if (string-null? val) "" separator) + (string-trim-both (read-delimited "\n" port 'peek))) + (peek-next-line-indent port))) + val))) + +(define (lex-white-space port bol) + "Consume white spaces and comment lines on PORT. If a new line is started return #t, +otherwise return BOL (beginning-of-line)." + (let loop ((c (peek-char port)) + (bol bol)) + (cond + ((and (not (eof-object? c)) + (or (char=? c #\space) (char=? c #\tab))) + (read-char port) + (loop (peek-char port) bol)) + ((and (not (eof-object? c)) (char=? c #\newline)) + (read-char port) + (loop (peek-char port) #t)) + ((comment-line port c) + (lex-white-space port bol)) + (else + bol)))) + +(define (lex-bol port) + "Process the beginning of a line on PORT: update current-indentation and +check the end of an indentation based context." + (let ((loc (make-source-location (cabal-file-name) (port-line port) + (port-column port) -1 -1))) + (current-indentation (source-location-column loc)) + (case (get-offside port) + ((less-than) + (check-bol? #t) ; need to check if closing more than 1 indent level. + (unless (context-stack-empty?) (context-stack-pop!)) + (make-lexical-token 'VCCURLY loc #f)) + (else + (lex-token port))))) + +(define (bol? port) (or (check-bol?) (= (port-column port) 0))) + +(define (comment-line port c) + "If PORT starts with a comment line, consume it up to, but not including +#\newline. C is the next character on PORT." + (cond ((and (not (eof-object? c)) (char=? c #\-)) + (read-char port) + (let ((c2 (peek-char port))) + (if (char=? c2 #\-) + (read-delimited "\n" port 'peek) + (begin (unread-char c port) #f)))) + (else #f))) + +(define-enumeration ordering (less-than equal greater-than) make-ordering) + +(define (get-offside port) + "In an indentation based context return the symbol 'greater-than, 'equal or +'less-than to signal if the current column number on PORT is greater-, equal-, +or less-than the indentation of the current context." + (let ((x (port-column port))) + (match (context-stack-top) + (($ 'layout indentation) + (cond + ((> x indentation) (ordering greater-than)) + ((= x indentation) (ordering equal)) + (else (ordering less-than)))) + (_ (ordering greater-than))))) + +;; (Semi-)Predicates for individual tokens. + +(define (is-relation? c) + (and (char? c) (any (cut char=? c <>) '(#\< #\> #\=)))) + +(define (make-rx-matcher pat) + "Compile PAT into a regular expression and creates a function matching a +string against the created regexp." + (let ((rx (make-regexp pat))) (cut regexp-exec rx <>))) + +(define is-property (make-rx-matcher "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) + +(define is-flag (make-rx-matcher "^[Ff]lag +([a-zA-Z0-9_-]+)")) + +(define is-src-repo + (make-rx-matcher "^[Ss]ource-[Rr]epository +([a-zA-Z0-9_-]+)")) + +(define is-exec (make-rx-matcher "^[Ee]xecutable +([a-zA-Z0-9_-]+)")) + +(define is-test-suite (make-rx-matcher "^[Tt]est-[Ss]uite +([a-zA-Z0-9_-]+)")) + +(define is-benchmark (make-rx-matcher "^[Bb]enchmark +([a-zA-Z0-9_-]+)")) + +(define is-lib (make-rx-matcher "^[Ll]ibrary *")) + +(define is-else (make-rx-matcher "^else")) + +(define (is-if s) (string=? s "if")) + +(define (is-and s) (string=? s "&&")) + +(define (is-or s) (string=? s "||")) + +(define (is-id s) + (let ((cabal-reserved-words + '("if" "else" "library" "flag" "executable" "test-suite" + "source-repository" "benchmark"))) + (and (every (cut string-ci<> s <>) cabal-reserved-words) + (not (char=? (last (string->list s)) #\:))))) + +(define (is-test s port) + (let ((tests-rx (make-regexp "os|arch|flag|impl")) + (c (peek-char port))) + (and (regexp-exec tests-rx s) (char=? #\( c)))) + +;; Lexers for individual tokens. + +(define (lex-relation loc port) + (make-lexical-token 'RELATION loc (read-while is-relation? port))) + +(define (lex-version loc port) + (make-lexical-token 'VERSION loc + (read-while char-numeric? port + (cut char=? #\. <>) char-numeric?))) + +(define* (read-while is? port #:optional + (is-if-followed-by? (lambda (c) #f)) + (is-allowed-follower? (lambda (c) #f))) + "Read from PORT as long as: (i) either the read character satisfies the +predicate IS?, or (ii) it satisfies the predicate IS-IF-FOLLOWED-BY? and the +character immediately following it satisfies IS-ALLOWED-FOLLOWER?. Returns a +string with the read characters." + (let loop ((c (peek-char port)) + (res '())) + (cond ((and (not (eof-object? c)) (is? c)) + (let ((c (read-char port))) + (loop (peek-char port) (append res (list c))))) + ((and (not (eof-object? c)) (is-if-followed-by? c)) + (let ((c (read-char port)) + (c2 (peek-char port))) + (if (and (not (eof-object? c2)) (is-allowed-follower? c2)) + (loop c2 (append res (list c))) + (begin (unread-char c) (list->string res))))) + (else (list->string res))))) + +(define (lex-property k-v-rx-res loc port) + (let ((key (string-downcase (match:substring k-v-rx-res 1))) + (value (match:substring k-v-rx-res 2))) + (make-lexical-token + 'PROPERTY loc + (list key `(,(read-value port value (current-indentation))))))) + +(define (lex-rx-res rx-res token loc) + (let ((name (string-downcase (match:substring rx-res 1)))) + (make-lexical-token token loc name))) + +(define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc)) + +(define (lex-src-repo src-repo-rx-res loc) + (lex-rx-res src-repo-rx-res 'SOURCE-REPO loc)) + +(define (lex-exec exec-rx-res loc) (lex-rx-res exec-rx-res 'EXEC loc)) + +(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc)) + +(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc)) + +(define (lex-lib loc) (make-lexical-token 'LIB loc #f)) + +(define (lex-else loc) (make-lexical-token 'ELSE loc #f)) + +(define (lex-if loc) (make-lexical-token 'IF loc #f)) + +(define (lex-and loc) (make-lexical-token 'AND loc #f)) + +(define (lex-or loc) (make-lexical-token 'OR loc #f)) + +(define (lex-id w loc) (make-lexical-token 'ID loc w)) + +(define (lex-test w loc) (make-lexical-token 'TEST loc (string->symbol w))) + +;; Lexer for tokens recognizable by single char. + +(define* (is-ref-char->token ref-char next-char token loc port + #:optional (hook-fn #f)) + "If the next character NEXT-CHAR on PORT is REF-CHAR, then read it, +execute HOOK-FN if it isn't #f and return a lexical token of type TOKEN with +location information LOC." + (cond ((char=? next-char ref-char) + (read-char port) + (when hook-fn (hook-fn)) + (make-lexical-token token loc (string next-char))) + (else #f))) + +(define (is-ocurly->token c loc port) + (is-ref-char->token #\{ c 'OCURLY loc port + (lambda () + (context-stack-push! (make-parse-context + (context no-layout) #f))))) + +(define (is-ccurly->token c loc port) + (is-ref-char->token #\} c 'CCURLY loc port (lambda () (context-stack-pop!)))) + +(define (is-oparen->token c loc port) + (is-ref-char->token #\( c 'OPAREN loc port)) + +(define (is-cparen->token c loc port) + (is-ref-char->token #\) c 'CPAREN loc port)) + +(define (is-not->token c loc port) + (is-ref-char->token #\! c 'NOT loc port)) + +(define (is-version? c) (char-numeric? c)) + +;; Main lexer functions + +(define (lex-single-char port loc) + "Process tokens which can be recognised by peeking the next character on +PORT. If no token can be recognized return #f. LOC is the current port +location." + (let* ((c (peek-char port))) + (cond ((eof-object? c) (read-char port) '*eoi*) + ((is-ocurly->token c loc port)) + ((is-ccurly->token c loc port)) + ((is-oparen->token c loc port)) + ((is-cparen->token c loc port)) + ((is-not->token c loc port)) + ((is-version? c) (lex-version loc port)) + ((is-relation? c) (lex-relation loc port)) + (else + #f)))) + +(define (lex-word port loc) + "Process tokens which can be recognized by reading the next word form PORT. +LOC is the current port location." + (let* ((w (read-delimited " ()\t\n" port 'peek))) + (cond ((is-if w) (lex-if loc)) + ((is-test w port) (lex-test w loc)) + ((is-and w) (lex-and loc)) + ((is-or w) (lex-or loc)) + ((is-id w) (lex-id w loc)) + (else (unread-string w port) #f)))) + +(define (lex-line port loc) + "Process tokens which can be recognised by reading a line from PORT. LOC is +the current port location." + (let* ((s (read-delimited "\n{}" port 'peek))) + (cond + ((is-property s) => (cut lex-property <> loc port)) + ((is-flag s) => (cut lex-flag <> loc)) + ((is-src-repo s) => (cut lex-src-repo <> loc)) + ((is-exec s) => (cut lex-exec <> loc)) + ((is-test-suite s) => (cut lex-test-suite <> loc)) + ((is-benchmark s) => (cut lex-benchmark <> loc)) + ((is-lib s) (lex-lib loc)) + ((is-else s) (lex-else loc)) + (else + #f)))) + +(define (lex-token port) + (let* ((loc (make-source-location (cabal-file-name) (port-line port) + (port-column port) -1 -1))) + (or (lex-single-char port loc) (lex-word port loc) (lex-line port loc)))) + +;; Lexer- and error-function generators + +(define (errorp) + "Generates the lexer error function." + (let ((p (current-error-port))) + (lambda (message . args) + (format p "~a" message) + (if (and (pair? args) (lexical-token? (car args))) + (let* ((token (car args)) + (source (lexical-token-source token)) + (line (source-location-line source)) + (column (source-location-column source))) + (format p "~a " (or (lexical-token-value token) + (lexical-token-category token))) + (when (and (number? line) (number? column)) + (format p "(at line ~a, column ~a)" (1+ line) column))) + (for-each display args)) + (format p "~%")))) + +(define (make-lexer port) + "Generate the Cabal lexical analyser reading from PORT." + (let ((p port)) + (lambda () + (let ((bol (lex-white-space p (bol? p)))) + (check-bol? #f) + (if bol (lex-bol p) (lex-token p)))))) + +(define* (read-cabal #:optional (port (current-input-port)) + (file-name #f)) + "Read a Cabal file from PORT. FILE-NAME is a string used in error messages. +If #f use the function 'port-filename' to obtain it." + (let ((cabal-parser (make-cabal-parser))) + (parameterize ((cabal-file-name + (or file-name (port-filename port) "standard input")) + (current-indentation 0) + (check-bol? #f) + (context-stack (make-stack))) + (cabal-parser (make-lexer port) (errorp))))) + +;; Part 2: +;; +;; Evaluate the S-expression returned by 'read-cabal'. + +;; This defines the object and interface that we provide to access the Cabal +;; file information. Note that this does not include all the pieces of +;; information of the Cabal file, but only the ones we currently are +;; interested in. +(define-record-type + (make-cabal-package name version license home-page source-repository + synopsis description + executables lib test-suites + flags eval-environment) + cabal-package? + (name cabal-package-name) + (version cabal-package-version) + (license cabal-package-license) + (home-page cabal-package-home-page) + (source-repository cabal-package-source-repository) + (synopsis cabal-package-synopsis) + (description cabal-package-description) + (executables cabal-package-executables) + (lib cabal-package-library) ; 'library' is a Scheme keyword + (test-suites cabal-package-test-suites) + (flags cabal-package-flags) + (eval-environment cabal-package-eval-environment)) ; alist + +(set-record-type-printer! + (lambda (package port) + (format port "#" + (cabal-package-name package) + (cabal-package-version package)))) + +(define-record-type + (make-cabal-source-repository use-case type location) + cabal-source-repository? + (use-case cabal-source-repository-use-case) + (type cabal-source-repository-type) + (location cabal-source-repository-location)) + +;; We need to be able to distinguish the value of a flag from the Scheme #t +;; and #f values. +(define-record-type + (make-cabal-flag name description default manual) + cabal-flag? + (name cabal-flag-name) + (description cabal-flag-description) + (default cabal-flag-default) ; 'true or 'false + (manual cabal-flag-manual)) ; 'true or 'false + +(set-record-type-printer! + (lambda (package port) + (format port "#" + (cabal-flag-name package) + (cabal-flag-default package)))) + +(define-record-type + (make-cabal-dependency name version) + cabal-dependency? + (name cabal-dependency-name) + (version cabal-dependency-version)) + +(define-record-type + (make-cabal-executable name dependencies) + cabal-executable? + (name cabal-executable-name) + (dependencies cabal-executable-dependencies)) ; list of + +(define-record-type + (make-cabal-library dependencies) + cabal-library? + (dependencies cabal-library-dependencies)) ; list of + +(define-record-type + (make-cabal-test-suite name dependencies) + cabal-test-suite? + (name cabal-test-suite-name) + (dependencies cabal-test-suite-dependencies)) ; list of + +(define (cabal-flags->alist flag-list) + "Retrun an alist associating the flag name to its default value from a +list of objects." + (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag))) + flag-list)) + +(define (eval-cabal cabal-sexp env) + "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals +and return a 'cabal-package' object. The values of all tests can be +overwritten by specifying the desired value in ENV. ENV must be an alist. +The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag. The +value associated with a flag has to be either \"true\" or \"false\". The +value associated with other keys has to conform to the Cabal file format +definition." + (define (os name) + (let ((env-os (or (assoc-ref env "os") "linux"))) + (string-match env-os name))) + + (define (arch name) + (let ((env-arch (or (assoc-ref env "arch") "x86_64"))) + (string-match env-arch name))) + + (define (comp-name+version haskell) + "Extract the compiler name and version from the string HASKELL." + (let* ((matcher-fn (make-rx-matcher "([a-zA-Z0-9_]+)-([0-9.]+)")) + (name (or (and=> (matcher-fn haskell) (cut match:substring <> 1)) + haskell)) + (version (and=> (matcher-fn haskell) (cut match:substring <> 2)))) + (values name version))) + + (define (comp-spec-name+op+version spec) + "Extract the compiler specification from SPEC. Return the compiler name, +the ordering operation and the version." + (let* ((with-ver-matcher-fn (make-rx-matcher + "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *")) + (without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)")) + (name (or (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 1)) + (match:substring (without-ver-matcher-fn spec) 1))) + (operator (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 2))) + (version (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 3)))) + (values name operator version))) + + (define (impl haskell) + (let*-values (((comp-name comp-ver) + (comp-name+version (or (assoc-ref env "impl") "ghc"))) + ((spec-name spec-op spec-ver) + (comp-spec-name+op+version haskell))) + (if (and spec-ver comp-ver) + (eval-string + (string-append "(string" spec-op " \"" comp-name "\"" + " \"" spec-name "-" spec-ver "\")")) + (string-match spec-name comp-name)))) + + (define (cabal-flags) + (make-cabal-section cabal-sexp 'flag)) + + (define (flag name) + (let ((value (or (assoc-ref env name) + (assoc-ref (cabal-flags->alist (cabal-flags)) name)))) + (if (eq? value 'false) #f #t))) + + (define (eval sexp) + (match sexp + (() '()) + ;; nested 'if' + ((('if predicate true-group false-group) rest ...) + (append (if (eval predicate) + (eval true-group) + (eval false-group)) + (eval rest))) + (('if predicate true-group false-group) + (if (eval predicate) + (eval true-group) + (eval false-group))) + (('flag name) (flag name)) + (('os name) (os name)) + (('arch name) (arch name)) + (('impl name) (impl name)) + (('not name) (not (eval name))) + ;; 'and' and 'or' aren't functions, thus we can't use apply + (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args))) + (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args))) + ;; no need to evaluate flag parameters + (('section 'flag name parameters) + (list 'section 'flag name parameters)) + ;; library does not have a name parameter + (('section 'library parameters) + (list 'section 'library (eval parameters))) + (('section type name parameters) + (list 'section type name (eval parameters))) + (((? string? name) values) + (list name values)) + ((element rest ...) + (cons (eval element) (eval rest))) + (_ (raise (condition + (&message (message "Failed to evaluate Cabal file. \ +See the manual for limitations."))))))) + + (define (cabal-evaluated-sexp->package evaluated-sexp) + (let* ((name (lookup-join evaluated-sexp "name")) + (version (lookup-join evaluated-sexp "version")) + (license (lookup-join evaluated-sexp "license")) + (home-page (lookup-join evaluated-sexp "homepage")) + (home-page-or-hackage + (if (string-null? home-page) + (string-append "http://hackage.haskell.org/package/" name) + home-page)) + (source-repository (make-cabal-section evaluated-sexp + 'source-repository)) + (synopsis (lookup-join evaluated-sexp "synopsis")) + (description (lookup-join evaluated-sexp "description")) + (executables (make-cabal-section evaluated-sexp 'executable)) + (lib (make-cabal-section evaluated-sexp 'library)) + (test-suites (make-cabal-section evaluated-sexp 'test-suite)) + (flags (make-cabal-section evaluated-sexp 'flag)) + (eval-environment '())) + (make-cabal-package name version license home-page-or-hackage + source-repository synopsis description executables lib + test-suites flags eval-environment))) + + ((compose cabal-evaluated-sexp->package eval) cabal-sexp)) + +(define (make-cabal-section sexp section-type) + "Given an SEXP as produced by 'read-cabal', produce a list of objects +pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: +'executable, 'flag, 'test-suite, 'source-repository or 'library." + (filter-map (cut match <> + (('section (? (cut equal? <> section-type)) name parameters) + (case section-type + ((test-suite) (make-cabal-test-suite + name (dependencies parameters))) + ((executable) (make-cabal-executable + name (dependencies parameters))) + ((source-repository) (make-cabal-source-repository + name + (lookup-join parameters "type") + (lookup-join parameters "location"))) + ((flag) + (let* ((default (lookup-join parameters "default")) + (default-true-or-false + (if (and default (string-ci=? "false" default)) + 'false + 'true)) + (description (lookup-join parameters "description")) + (manual (lookup-join parameters "manual")) + (manual-true-or-false + (if (and manual (string-ci=? "true" manual)) + 'true + 'false))) + (make-cabal-flag name description + default-true-or-false + manual-true-or-false))) + (else #f))) + (('section (? (cut equal? <> section-type) lib) parameters) + (make-cabal-library (dependencies parameters))) + (_ #f)) + sexp)) + +(define* (lookup-join key-values-list key #:optional (delimiter " ")) + "Lookup and joint all values pertaining to keys of value KEY in +KEY-VALUES-LIST. The optional DELIMITER is used to specify a delimiter string +to be added between the values found in different key/value pairs." + (string-join + (filter-map (cut match <> + (((? (lambda(x) (equal? x key))) value) + (string-join value delimiter)) + (_ #f)) + key-values-list) + delimiter)) + +(define dependency-name-version-rx + (make-regexp "([a-zA-Z0-9_-]+) *(.*)")) + +(define (dependencies key-values-list) + "Return a list of 'cabal-dependency' objects for the dependencies found in +KEY-VALUES-LIST." + (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",") + (char-set-complement (char-set #\,))))) + (map (lambda (d) + (let ((rx-result (regexp-exec dependency-name-version-rx d))) + (make-cabal-dependency + (match:substring rx-result 1) + (match:substring rx-result 2)))) + deps))) + +;;; cabal.scm ends here diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 1b27803db..b5574a8d9 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -18,28 +18,19 @@ (define-module (guix import hackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 receive) - #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) #:use-module ((guix download) #:select (download-to-store)) #:use-module ((guix utils) #:select (package-name->name+version)) #:use-module (guix import utils) + #:use-module (guix import cabal) #:use-module (guix store) #:use-module (guix hash) #:use-module (guix base32) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (hackage->guix-package)) -;; Part 1: -;; -;; Functions used to read a Cabal file. - (define ghc-standard-libraries ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as ;; some packages list it. @@ -75,588 +66,12 @@ (define package-name-prefix "ghc-") -(define key-value-rx - ;; Regular expression matching "key: value" - (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) - -(define sections-rx - ;; Regular expression matching a section "head sub-head ..." - (make-regexp "([a-zA-Z0-9\\(\\)-]+)")) - -(define comment-rx - ;; Regexp matching Cabal comment lines. - (make-regexp "^ *--")) - -(define (has-key? line) - "Check if LINE includes a key." - (regexp-exec key-value-rx line)) - -(define (comment-line? line) - "Check if LINE is a comment line." - (regexp-exec comment-rx line)) - -(define (line-indentation+rest line) - "Returns two results: The number of indentation spaces and the rest of the -line (without indentation)." - (let loop ((line-lst (string->list line)) - (count 0)) - ;; Sometimes values are spread over multiple lines and new lines start - ;; with a comma ',' with the wrong indentation. See e.g. haddock-api. - (if (or (null? line-lst) - (not (or - (eqv? (first line-lst) #\space) - (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal - (eqv? (first line-lst) #\tab)))) - (values count (list->string line-lst)) - (loop (cdr line-lst) (+ count 1))))) - -(define (multi-line-value lines seed) - "Function to read a value split across multiple lines. LINES are the -remaining input lines to be read. SEED is the value read on the same line as -the key. Return two values: A list with values and the remaining lines to be -processed." - (define (multi-line-value-with-min-indent lines seed min-indent) - (if (null? lines) - (values '() '()) - (let-values (((current-indent value) (line-indentation+rest (first lines))) - ((next-line-indent next-line-value) - (if (null? (cdr lines)) - (values #f "") - (line-indentation+rest (second lines))))) - (if (or (not next-line-indent) (< next-line-indent min-indent) - (regexp-exec condition-rx next-line-value)) - (values (reverse (cons value seed)) (cdr lines)) - (multi-line-value-with-min-indent (cdr lines) (cons value seed) - min-indent))))) - - (let-values (((current-indent value) (line-indentation+rest (first lines)))) - (multi-line-value-with-min-indent lines seed current-indent))) - -(define (read-cabal port) - "Parses a Cabal file from PORT. Return a list of list pairs: - -(((head1 sub-head1 ... key1) (value)) - ((head2 sub-head2 ... key2) (value2)) - ...). - -We try do deduce the Cabal format from the following document: -https://www.haskell.org/cabal/users-guide/developing-packages.html - -Keys are case-insensitive. We therefore lowercase them. Values are -case-sensitive. Currently only indentation-structured files are parsed. -Braces structured files are not handled." ;" <- make emacs happy. - (define (read-and-trim-line port) - (let ((line (read-line port))) - (if (string? line) - (string-trim-both line #\return) - line))) - - (define (strip-insignificant-lines port) - (let loop ((line (read-and-trim-line port)) - (result '())) - (cond - ((eof-object? line) - (reverse result)) - ((or (string-null? line) (comment-line? line)) - (loop (read-and-trim-line port) result)) - (else - (loop (read-and-trim-line port) (cons line result)))))) - - (let loop - ((lines (strip-insignificant-lines port)) - (indents '()) ; only includes indents at start of section heads. - (sections '()) - (result '())) - (let-values - (((current-indent line) - (if (null? lines) - (values 0 "") - (line-indentation+rest (first lines)))) - ((next-line-indent next-line) - (if (or (null? lines) (null? (cdr lines))) - (values 0 "") - (line-indentation+rest (second lines))))) - (if (null? lines) - (reverse result) - (let ((rx-result (has-key? line))) - (cond - (rx-result - (let ((key (string-downcase (match:substring rx-result 1))) - (value (match:substring rx-result 2))) - (cond - ;; Simple single line "key: value". - ((= next-line-indent current-indent) - (loop (cdr lines) indents sections - (cons - (list (reverse (cons key sections)) (list value)) - result))) - ;; Multi line "key: value\n value cont...". - ((> next-line-indent current-indent) - (let*-values (((value-lst lines) - (multi-line-value (cdr lines) - (if (string-null? value) - '() - `(,value))))) - ;; multi-line-value returns to the first line after the - ;; multi-value. - (loop lines indents sections - (cons - (list (reverse (cons key sections)) value-lst) - result)))) - ;; Section ended. - (else - ;; Indentation is reduced. Check by how many levels. - (let* ((idx (and=> (list-index - (lambda (x) (= next-line-indent x)) - indents) - (cut + <> - (if (has-key? next-line) 1 0)))) - (sec - (if idx - (drop sections idx) - (raise - (condition - (&message - (message "unable to parse Cabal file")))))) - (ind (drop indents idx))) - (loop (cdr lines) ind sec - (cons - (list (reverse (cons key sections)) (list value)) - result))))))) - ;; Start of a new section. - ((or (null? indents) - (> current-indent (first indents))) - (loop (cdr lines) (cons current-indent indents) - (cons (string-downcase line) sections) result)) - (else - (loop (cdr lines) indents - (cons (string-downcase line) (cdr sections)) - result)))))))) - -(define condition-rx - ;; Regexp for conditionals. - (make-regexp "^if +(.*)$")) - -(define (split-section section) - "Split SECTION in individual words with exception for the predicate of an -'if' conditional." - (let ((rx-result (regexp-exec condition-rx section))) - (if rx-result - `("if" ,(match:substring rx-result 1)) - (map match:substring (list-matches sections-rx section))))) - -(define (join-sections sec1 sec2) - (fold-right cons sec2 sec1)) - -(define (pre-process-keys key) - (match key - (() '()) - ((sec1 rest ...) - (join-sections (split-section sec1) (pre-process-keys rest))))) - -(define (pre-process-entry-keys entry) - (match entry - ((key value) - (list (pre-process-keys key) value)) - (() '()))) - -(define (pre-process-entries-keys entries) - "ENTRIES is a list of list pairs, a keys list and a valules list, as -produced by 'read-cabal'. Split each element of the keys list into individual -words. This pre-processing is used to read flags." - (match entries - ((entry rest ...) - (cons (pre-process-entry-keys entry) - (pre-process-entries-keys rest))) - (() - '()))) - -(define (get-flags pre-processed-entries) - "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values -list, as produced by 'read-cabal' and pre-processed by -'pre-process-entries-keys'. Return a list of pairs with the name of flags and -their default value (one of \"False\" or \"True\") as specified in the Cabal file: - -((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy - (match pre-processed-entries - (() '()) - (((("flag" flag-name "default") (flag-val)) rest ...) - (cons (cons flag-name flag-val) - (get-flags rest))) - ((entry rest ... ) - (get-flags rest)) - (_ #f))) - -;; Part 2: -;; -;; Functions to read information from the Cabal object created by 'read-cabal' -;; and convert Cabal format dependencies conditionals into equivalent -;; S-expressions. - -(define tests-rx - ;; Cabal test keywords - (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)")) - -(define parens-rx - ;; Parentheses within conditions - (make-regexp "\\((.+)\\)")) - -(define or-rx - ;; OR operator in conditions - (make-regexp " +\\|\\| +")) - -(define and-rx - ;; AND operator in conditions - (make-regexp " +&& +")) - -(define not-rx - ;; NOT operator in conditions - (make-regexp "^!.+")) - -(define (bi-op-args str match-lst) - "Return a list with the arguments of (logic) bianry operators. MATCH-LST -is the result of 'list-match' against a binary operator regexp on STR." - (let ((operators (length match-lst))) - (map (lambda (from to) - (substring str from to)) - (cons 0 (map match:end match-lst)) - (append (map match:start match-lst) (list (string-length str)))))) - -(define (bi-op->sexp-like bi-op args) - "BI-OP is a string with the name of a Scheme operator which in a Cabal file -is represented by a binary operator. ARGS are the arguments of said operator. -Return a string representing an S-expression of the operator applied to its -arguments." - (if (= (length args) 1) - (first args) - (string-append "(" bi-op - (fold (lambda (arg seed) (string-append seed " " arg)) - "" args) ")"))) - -(define (not->sexp-like arg) - "If the string ARG is prefixed by a Cabal negation operator, convert it to -an equivalent Scheme S-expression string." - (if (regexp-exec not-rx arg) - (string-append "(not " - (substring arg 1 (string-length arg)) - ")") - arg)) - -(define (parens-less-cond->sexp-like conditional) - "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme -syntax. This procedure accepts only simple conditionals without parentheses." - ;; The outher operation is the one with the lowest priority: OR - (bi-op->sexp-like - "or" - ;; each OR argument may be an AND operation - (map (lambda (or-arg) - (let ((m-lst (list-matches and-rx or-arg))) - ;; is there an AND operation? - (if (> (length m-lst) 0) - (bi-op->sexp-like - "and" - ;; expand NOT operators when there are ANDs - (map not->sexp-like (bi-op-args or-arg m-lst))) - ;; ... and when there aren't. - (not->sexp-like or-arg)))) - ;; list of OR arguments - (bi-op-args conditional (list-matches or-rx conditional))))) - -(define test-keyword-ornament "__") - -(define (conditional->sexp-like conditional) - "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme -syntax." - ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests - ;; keywords so that parentheses are only used to set precedences. This - ;; substantially simplify parsing. - (let ((conditional - (regexp-substitute/global #f tests-rx conditional - 'pre 1 test-keyword-ornament 2 - test-keyword-ornament 'post))) - (let loop ((sub-cond conditional)) - (let ((rx-result (regexp-exec parens-rx sub-cond))) - (cond - (rx-result - (parens-less-cond->sexp-like - (string-append - (match:prefix rx-result) - (loop (match:substring rx-result 1)) - (match:suffix rx-result)))) - (else - (parens-less-cond->sexp-like sub-cond))))))) - -(define (eval-flags sexp-like-cond flags) - "SEXP-LIKE-COND is a string representing an S-expression conditional. FLAGS -is a list of flag name and value pairs as produced by 'get-flags'. Substitute -\"#t\" or \"#f\" according to the value of flags. (Default to \"True\")." - (fold-right - (lambda (flag sexp) - (match flag - ((name . value) - (let ((rx (make-regexp - (string-append "flag" test-keyword-ornament name - test-keyword-ornament)))) - (regexp-substitute/global - #f rx sexp - 'pre (if (string-ci= value "False") "#f" "#t") 'post))) - (_ sexp))) - sexp-like-cond - (cons '("[a-zA-Z0-9_-]+" . "True") flags))) - -(define (eval-tests->sexp sexp-like-cond) - "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and -\"arch(...)\" with equivalent Scheme checks. Retrun an S-expression." - (with-input-from-string - (fold-right - (lambda (test sexp) - (match test - ((type pre-match post-match) - (let ((rx (make-regexp - (string-append type test-keyword-ornament "(\\w+)" - test-keyword-ornament)))) - (regexp-substitute/global - #f rx sexp - 'pre pre-match 2 post-match 'post))) - (_ sexp))) - sexp-like-cond - ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux". - '(("(os|arch)" "(string-match \"" "\" (%current-system))"))) - read)) - -(define (eval-impl sexp-like-cond) - "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND. -Assume the module declaring the generated package includes a local variable -called \"haskell-implementation\" with a string value of the form NAME-VERSION -against which we compare." - (with-output-to-string - (lambda () - (write - (with-input-from-string - (fold-right - (lambda (test sexp) - (match test - ((pre-match post-match) - (let ((rx-with-version - (make-regexp - (string-append - "impl" test-keyword-ornament - "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" - test-keyword-ornament))) - (rx-without-version - (make-regexp - (string-append "impl" test-keyword-ornament "(\\w+)" - test-keyword-ornament)))) - (if (regexp-exec rx-with-version sexp) - (regexp-substitute/global - #f rx-with-version sexp - 'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post) - (regexp-substitute/global - #f rx-without-version sexp - 'pre pre-match "-match \"" 1 "\" " post-match ")" 'post)))) - (_ sexp))) - sexp-like-cond - '(("(string" "haskell-implementation"))) - read))))) - -(define (eval-cabal-keywords sexp-like-cond flags) - ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags)) - sexp-like-cond)) - -(define (key->values meta key) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return the list of values associated with a specific KEY (a string)." - (match meta - (() '()) - (((((? (lambda(x) (equal? x key)))) v) r ...) - v) - (((k v) r ...) - (key->values (cdr meta) key)) - (_ "key Not fount"))) - -(define (key-start-end->entries meta key-start-rx key-end-rx) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return all entries whose keys list starts with KEY-START and ends with -KEY-END." - (let ((pred - (lambda (x) - (and (regexp-exec key-start-rx (first x)) - (regexp-exec key-end-rx (last x)))))) - ;; (equal? (list key-start key-end) (list (first x) (last x)))))) - (match meta - (() '()) - ((((? pred k) v) r ...) - (cons `(,k ,v) - (key-start-end->entries (cdr meta) key-start-rx key-end-rx))) - (((k v) r ...) - (key-start-end->entries (cdr meta) key-start-rx key-end-rx)) - (_ "key Not fount")))) - -(define else-rx - (make-regexp "^else$")) - -(define (count-if-else rx-result-ls) - (apply + (map (lambda (m) (if m 1 0)) rx-result-ls))) - -(define (analyze-entry-cond entry) - (let* ((keys (first entry)) - (vals (second entry)) - (rx-cond-result - (map (cut regexp-exec condition-rx <>) keys)) - (rx-else-result - (map (cut regexp-exec else-rx <>) keys)) - (cond-no (count-if-else rx-cond-result)) - (else-no (count-if-else rx-else-result)) - (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result)) - (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result)) - (key-cond - (cond - ((or (and cond-idx else-idx (< cond-idx else-idx)) - (and cond-idx (not else-idx))) - (match:substring - (receive (head tail) - (split-at rx-cond-result cond-idx) (first tail)))) - ((or (and cond-idx else-idx (> cond-idx else-idx)) - (and (not cond-idx) else-idx)) - (match:substring - (receive (head tail) - (split-at rx-else-result else-idx) (first tail)))) - (else - "")))) - (values keys vals rx-cond-result - rx-else-result cond-no else-no key-cond))) - -(define (remove-cond entry cond) - (match entry - ((k v) - (list (cdr (member cond k)) v)))) - -(define (group-and-reduce-level entries group group-cond) - (let loop - ((true-group group) - (false-group '()) - (entries entries)) - (if (null? entries) - (values (reverse true-group) (reverse false-group) entries) - (let*-values (((entry) (first entries)) - ((keys vals rx-cond-result rx-else-result - cond-no else-no key-cond) - (analyze-entry-cond entry))) - (cond - ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond)) - (loop (cons (remove-cond entry group-cond) true-group) false-group - (cdr entries))) - ((and (>= (+ cond-no else-no) 1) (string= key-cond "else")) - (loop true-group (cons (remove-cond entry "else") false-group) - (cdr entries))) - (else - (values (reverse true-group) (reverse false-group) entries))))))) - -(define dependencies-rx - (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?")) - (define (hackage-name->package-name name) + "Given the NAME of a Cabal package, return the corresponding Guix name." (if (string-prefix? package-name-prefix name) (string-downcase name) (string-append package-name-prefix (string-downcase name)))) -(define (split-and-filter-dependencies ls names-to-filter) - "Split the comma separated list of dependencies LS coming from the Cabal -file, filter packages included in NAMES-TO-FILTER and return a list with -inputs suitable for the Guix package. Currently the version information is -discarded." - (define (split-at-comma-and-filter d) - (fold - (lambda (m seed) - (let* ((name (string-downcase (match:substring m 1))) - (pkg-name (hackage-name->package-name name))) - (if (member name names-to-filter) - seed - (cons (list pkg-name (list 'unquote (string->symbol pkg-name))) - seed)))) - '() - (list-matches dependencies-rx d))) - - (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '() ls)) - -(define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t)) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return an S-expression containing the list of dependencies as expected by the -'inputs' field of a package. The generated S-expressions may include -conditionals as defined in the cabal file. During this process we discard the -version information of the packages." - (define (take-dependencies meta) - (let ((key-start-exe (make-regexp "executable")) - (key-start-lib (make-regexp "library")) - (key-start-tests (make-regexp "test-suite")) - (key-end (make-regexp "build-depends"))) - (append - (key-start-end->entries meta key-start-exe key-end) - (key-start-end->entries meta key-start-lib key-end) - (if include-test-dependencies? - (key-start-end->entries meta key-start-tests key-end) - '())))) - - (let ((flags (get-flags (pre-process-entries-keys meta))) - (augmented-ghc-std-libs (append (key->values meta "name") - ghc-standard-libraries))) - (delete-duplicates - (let loop ((entries (take-dependencies meta)) - (result '())) - (if (null? entries) - (reverse result) - (let*-values (((entry) (first entries)) - ((keys vals rx-cond-result rx-else-result - cond-no else-no key-cond) - (analyze-entry-cond entry))) - (cond - ((= (+ cond-no else-no) 0) - (loop (cdr entries) - (append - (split-and-filter-dependencies vals - augmented-ghc-std-libs) - result))) - (else - (let-values (((true-group false-group entries) - (group-and-reduce-level entries '() - key-cond)) - ((cond-final) (eval-cabal-keywords - (conditional->sexp-like - (last (split-section key-cond))) - flags))) - (loop entries - (cond - ((or (eq? cond-final #t) (equal? cond-final '(not #f))) - (append (loop true-group '()) result)) - ((or (eq? cond-final #f) (equal? cond-final '(not #t))) - (append (loop false-group '()) result)) - (else - (let ((true-group-result (loop true-group '())) - (false-group-result (loop false-group '()))) - (cond - ((and (null? true-group-result) - (null? false-group-result)) - result) - ((null? false-group-result) - (cons `(unquote-splicing - (when ,cond-final ,true-group-result)) - result)) - ((null? true-group-result) - (cons `(unquote-splicing - (unless ,cond-final ,false-group-result)) - result)) - (else - (cons `(unquote-splicing - (if ,cond-final - ,true-group-result - ,false-group-result)) - result)))))))))))))))) - -;; Part 3: -;; -;; Retrive the desired package and its Cabal file from -;; http://hackage.haskell.org and construct the Guix package S-expression. - (define (hackage-fetch name-version) "Return the Cabal file for the package NAME-VERSION, or #f on failure. If the version part is omitted from the package name, then return the latest @@ -696,33 +111,63 @@ version." ((lst ...) `(list ,@(map string->license lst))) (_ #f))) -(define* (hackage-module->sexp meta #:key (include-test-dependencies? #t)) - "Return the `package' S-expression for a Cabal package. META is the + +(define (cabal-dependencies->names cabal include-test-dependencies?) + "Return the list of dependencies names from the CABAL package object. If +INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test +suites." + (let* ((lib (cabal-package-library cabal)) + (lib-deps (if (pair? lib) + (map cabal-dependency-name + (append-map cabal-library-dependencies lib)) + '())) + (exe (cabal-package-executables cabal)) + (exe-deps (if (pair? exe) + (map cabal-dependency-name + (append-map cabal-executable-dependencies exe)) + '())) + (ts (cabal-package-test-suites cabal)) + (ts-deps (if (pair? ts) + (map cabal-dependency-name + (append-map cabal-test-suite-dependencies ts)) + '()))) + (if include-test-dependencies? + (delete-duplicates (append lib-deps exe-deps ts-deps)) + (delete-duplicates (append lib-deps exe-deps))))) + +(define (filter-dependencies dependencies own-name) + "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a +list with the names of dependencies. OWN-NAME is the name of the Cabal +package being processed and is used to filter references to itself." + (filter (lambda (d) (not (member (string-downcase d) + (cons own-name ghc-standard-libraries)))) + dependencies)) + +(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t)) + "Return the `package' S-expression for a Cabal package. CABAL is the representation of a Cabal file as produced by 'read-cabal'." (define name - (first (key->values meta "name"))) + (cabal-package-name cabal)) (define version - (first (key->values meta "version"))) - - (define description - (let*-values (((description) (key->values meta "description")) - ((lines last) - (split-at description (- (length description) 1)))) - (fold-right (lambda (line seed) (string-append line "\n" seed)) - (first last) lines))) + (cabal-package-version cabal)) (define source-url (string-append "http://hackage.haskell.org/package/" name "/" name "-" version ".tar.gz")) - ;; Several packages do not have an official home-page other than on Hackage. - (define home-page - (let ((home-page-entry (key->values meta "homepage"))) - (if (null? home-page-entry) - (string-append "http://hackage.haskell.org/package/" name) - (first home-page-entry)))) + (define dependencies + (let ((names + (map hackage-name->package-name + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + (cut cabal-dependencies->names <> + include-test-dependencies?)) + cabal)))) + (map (lambda (name) + (list name (list 'unquote (string->symbol name)))) + names))) (define (maybe-inputs input-type inputs) (match inputs @@ -732,6 +177,11 @@ representation of a Cabal file as produced by 'read-cabal'." (list (list input-type (list 'quasiquote inputs)))))) + (define (maybe-arguments) + (if (not include-test-dependencies?) + '((arguments `(#:tests? #f))) + '())) + (let ((tarball (with-store store (download-to-store store source-url)))) `(package @@ -746,22 +196,33 @@ representation of a Cabal file as produced by 'read-cabal'." (bytevector->nix-base32-string (file-sha256 tarball)) "failed to download tar archive"))))) (build-system haskell-build-system) - ,@(maybe-inputs 'inputs - (dependencies-cond->sexp meta - #:include-test-dependencies? - include-test-dependencies?)) - (home-page ,home-page) - (synopsis ,@(key->values meta "synopsis")) - (description ,description) - (license ,(string->license (key->values meta "license")))))) - -(define* (hackage->guix-package module-name - #:key (include-test-dependencies? #t)) - "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return -the `package' S-expression corresponding to that package, or #f on failure." - (let ((module-meta (hackage-fetch module-name))) - (and=> module-meta (cut hackage-module->sexp <> - #:include-test-dependencies? - include-test-dependencies?)))) + ,@(maybe-inputs 'inputs dependencies) + ,@(maybe-arguments) + (home-page ,(cabal-package-home-page cabal)) + (synopsis ,(cabal-package-synopsis cabal)) + (description ,(cabal-package-description cabal)) + (license ,(string->license (cabal-package-license cabal)))))) + +(define* (hackage->guix-package package-name #:key + (include-test-dependencies? #t) + (port #f) + (cabal-environment '())) + "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the +called with keyword parameter PORT, from PORT. Return the `package' +S-expression corresponding to that package, or #f on failure. +CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal +conditionals are evaluated. The accepted keys are: \"os\", \"arch\", \"impl\" +and the name of a flag. The value associated with a flag has to be either the +symbol 'true' or 'false'. The value associated with other keys has to conform +to the Cabal file format definition. The default value associated with the +keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" +respectively." + (let ((cabal-meta (if port + (read-cabal port) + (hackage-fetch package-name)))) + (and=> cabal-meta (compose (cut hackage-module->sexp <> + #:include-test-dependencies? + include-test-dependencies?) + (cut eval-cabal <> cabal-environment))))) ;;; cabal.scm ends here diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index f7c18cd3b..e5e9b0ed6 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -34,7 +34,9 @@ ;;; (define %default-options - '((include-test-dependencies? . #t))) + '((include-test-dependencies? . #t) + (read-from-stdin? . #f) + ('cabal-environment . '()))) (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME @@ -45,8 +47,13 @@ package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available version.\n")) (display (_ " + -e ALIST, --cabal-environment=ALIST + specify environment for Cabal evaluation")) + (display (_ " -h, --help display this help and exit")) (display (_ " + -s, --stdin read from standard input")) + (display (_ " -t, --no-test-dependencies don't include test only dependencies")) (display (_ " -V, --version display version information and exit")) @@ -67,6 +74,16 @@ version.\n")) (alist-cons 'include-test-dependencies? #f (alist-delete 'include-test-dependencies? result)))) + (option '(#\s "stdin") #f #f + (lambda (opt name arg result) + (alist-cons 'read-from-stdin? #t + (alist-delete 'read-from-stdin? + result)))) + (option '(#\e "cabal-environment") #t #f + (lambda (opt name arg result) + (alist-cons 'cabal-environment (read/eval arg) + (alist-delete 'cabal-environment + result)))) %standard-import-options)) @@ -84,23 +101,42 @@ version.\n")) (alist-cons 'argument arg result)) %default-options)) + (define (run-importer package-name opts error-fn) + (let ((sexp (hackage->guix-package + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?) + #:port (if (assoc-ref opts 'read-from-stdin?) + (current-input-port) + #f) + #:cabal-environment + (assoc-ref opts 'cabal-environment)))) + (unless sexp (error-fn)) + sexp)) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) value) (_ #f)) (reverse opts)))) - (match args - ((package-name) - (let ((sexp (hackage->guix-package - package-name - #:include-test-dependencies? - (assoc-ref opts 'include-test-dependencies?)))) - (unless sexp - (leave (_ "failed to download cabal file for package '~a'~%") - package-name)) - sexp)) - (() - (leave (_ "too few arguments~%"))) - ((many ...) - (leave (_ "too many arguments~%")))))) + (if (assoc-ref opts 'read-from-stdin?) + (match args + (() + (run-importer "stdin" opts + (lambda () + (leave (_ "failed to import cabal file from '~a'~%")) + package-name))) + ((many ...) + (leave (_ "too many arguments~%")))) + (match args + ((package-name) + (run-importer package-name opts + (lambda () + (leave + (_ "failed to download cabal file for package '~a'~%")) + package-name))) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%"))))))) diff --git a/tests/hackage.scm b/tests/hackage.scm index 23b854caa..229bee35e 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (test-hackage) + #:use-module (guix import cabal) #:use-module (guix import hackage) #:use-module (guix tests) #:use-module (srfi srfi-64) @@ -35,44 +36,44 @@ executable cabal mtl >= 2.0 && < 3 ") -;; Use TABs to indent lines and to separate keys from value. (define test-cabal-2 - "name: foo -version: 1.0.0 -homepage: http://test.org -synopsis: synopsis -description: description -license: BSD3 -executable cabal - build-depends: HTTP >= 4000.2.5 && < 4000.3, - mtl >= 2.0 && < 3 -") - -;; Use indentation with comma as found, e.g., in 'haddock-api'. -(define test-cabal-3 "name: foo version: 1.0.0 homepage: http://test.org synopsis: synopsis description: description license: BSD3 -executable cabal - build-depends: - HTTP >= 4000.2.5 && < 4000.3 - , mtl >= 2.0 && < 3 +executable cabal { +build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +} ") -(define test-cond-1 - "(os(darwin) || !(flag(debug))) && flag(cips)") - -(define read-cabal - (@@ (guix import hackage) read-cabal)) - -(define eval-cabal-keywords - (@@ (guix import hackage) eval-cabal-keywords)) - -(define conditional->sexp-like - (@@ (guix import hackage) conditional->sexp-like)) +;; A fragment of a real Cabal file with minor modification to check precedence +;; of 'and' over 'or'. +(define test-read-cabal-1 + "name: test-me +library + -- Choose which library versions to use. + if flag(base4point8) + Build-depends: base >= 4.8 && < 5 + else + if flag(base4) + Build-depends: base >= 4 && < 4.8 + else + if flag(base3) + Build-depends: base >= 3 && < 4 + else + Build-depends: base < 3 + if flag(base4point8) || flag(base4) && flag(base3) + Build-depends: random + Build-depends: containers + + -- Modules that are always built. + Exposed-Modules: + Test.QuickCheck.Exception +") (test-begin "hackage") @@ -115,18 +116,25 @@ executable cabal (test-assert "hackage->guix-package test 2" (eval-test-with-cabal test-cabal-2)) -(test-assert "hackage->guix-package test 3" - (eval-test-with-cabal test-cabal-3)) - -(test-assert "conditional->sexp-like" - (match - (eval-cabal-keywords - (conditional->sexp-like test-cond-1) - '(("debug" . "False"))) - (('and ('or ('string-match "darwin" ('%current-system)) ('not '#f)) '#t) +(test-assert "read-cabal test 1" + (match (call-with-input-string test-read-cabal-1 read-cabal) + ((("name" ("test-me")) + ('section 'library + (('if ('flag "base4point8") + (("build-depends" ("base >= 4.8 && < 5"))) + (('if ('flag "base4") + (("build-depends" ("base >= 4 && < 4.8"))) + (('if ('flag "base3") + (("build-depends" ("base >= 3 && < 4"))) + (("build-depends" ("base < 3")))))))) + ('if ('or ('flag "base4point8") + ('and ('flag "base4") ('flag "base3"))) + (("build-depends" ("random"))) + ()) + ("build-depends" ("containers")) + ("exposed-modules" ("Test.QuickCheck.Exception"))))) #t) - (x - (pk 'fail x #f)))) + (x (pk 'fail x #f)))) (test-end "hackage") -- cgit v1.3 From 7522a0160be6888416a54b9e241d124839750e60 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jun 2015 10:25:16 +0200 Subject: ui: Replace the global 'symlink' binding. * guix/ui.scm (symlink): Set! the global symlink. --- guix/ui.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 94e2c4eec..11af646a6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -45,7 +45,6 @@ #:use-module (ice-9 regex) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) - #:replace (symlink) #:export (_ N_ P_ @@ -294,7 +293,9 @@ Report bugs to: ~a.") %guix-bug-report-address) General help using GNU software: ")) (newline)) -(define symlink +(set! symlink + ;; We 'set!' the global binding because (gnu build ...) modules and similar + ;; typically don't use (guix ui). (let ((real-symlink (@ (guile) symlink))) (lambda (target link) "This is a 'symlink' replacement that provides proper error reporting." -- cgit v1.3 From 78acff7c11507c68b63ad289b2bbe396602b9dcf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jun 2015 10:31:47 +0200 Subject: guix system: init: Overwrite the items in the target store. Fixes . Reported by Eric Bavier . * guix/scripts/system.scm (copy-item): Check whether DEST exists and remove it if it does. --- guix/scripts/system.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f7c9d83e9..aa9b3f838 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -76,6 +76,13 @@ (let ((dest (string-append target item)) (state (string-append target "/var/guix"))) (format log-port "copying '~a'...~%" item) + + ;; Remove DEST if it exists to make sure that (1) we do not fail badly + ;; while trying to overwrite it (see ), and + ;; (2) we end up with the right contents. + (when (file-exists? dest) + (delete-file-recursively dest)) + (copy-recursively item dest #:log (%make-void-port "w")) -- cgit v1.3