diff options
| author | Ludovic Courtès | 2015-03-18 18:11:02 +0100 |
|---|---|---|
| committer | Ludovic Courtès | 2015-03-18 18:11:02 +0100 |
| commit | 381c540b937a5e6e8b7007c9c0271ee816bf5417 (patch) | |
| tree | 27191f25f05bbfd48dbf47bbd29f72cb7521482f /guix | |
| parent | 49689377a3bab8da08436455ca14a0432fa0e95f (diff) | |
| parent | f401b1e9934a6594d6d7586922aa987e0b24839b (diff) | |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/python.scm | 13 | ||||
| -rw-r--r-- | guix/build/cmake-build-system.scm | 4 | ||||
| -rw-r--r-- | guix/build/ruby-build-system.scm | 4 | ||||
| -rw-r--r-- | guix/derivations.scm | 16 | ||||
| -rw-r--r-- | guix/gexp.scm | 236 | ||||
| -rw-r--r-- | guix/licenses.scm | 29 | ||||
| -rw-r--r-- | guix/packages.scm | 33 | ||||
| -rw-r--r-- | guix/pk-crypto.scm | 4 | ||||
| -rw-r--r-- | guix/profiles.scm | 33 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 37 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 3 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 7 | ||||
| -rw-r--r-- | guix/serialization.scm | 44 | ||||
| -rw-r--r-- | guix/store.scm | 19 |
14 files changed, 298 insertions, 184 deletions
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index e8af9f814..37108650d 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; @@ -76,7 +76,10 @@ prepended to the name." (substring name (string-length old-prefix)) name)))) (arguments - (let ((arguments (package-arguments p))) + (let ((arguments (package-arguments p)) + (python (if (promise? python) + (force python) + python))) (if (member #:python arguments) (substitute-keyword-arguments arguments ((#:python p) python)) (append arguments `(#:python ,python))))) @@ -86,7 +89,11 @@ prepended to the name." p))) (define package-with-python2 - (cut package-with-explicit-python <> (default-python2) "python-" "python2-")) + ;; Note: delay call to 'default-python2' until after the 'arguments' field + ;; of packages is accessed to avoid a circular dependency when evaluating + ;; the top-level of (gnu packages python). + (cut package-with-explicit-python <> (delay (default-python2)) + "python-" "python2-")) (define* (lower name #:key source inputs native-inputs outputs system target diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm index 08ae73ef8..d8d437c65 100644 --- a/guix/build/cmake-build-system.scm +++ b/guix/build/cmake-build-system.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2014 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2014, 2015 Andreas Enge <andreas@enge.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,8 +60,6 @@ ;; enable verbose output from builds "-DCMAKE_VERBOSE_MAKEFILE=ON" ,@configure-flags))) - (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH")) - (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH")) (format #t "running 'cmake' with arguments ~s~%" args) (zero? (apply system* "cmake" args))))) diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 1310c4a0b..a143df467 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -58,11 +58,11 @@ directory." (define* (install #:key source inputs outputs #:allow-other-keys) (let* ((ruby-version - (match:substring (string-match "ruby-(.*)$" + (match:substring (string-match "ruby-(.*)\\.[0-9]$" (assoc-ref inputs "ruby")) 1)) (out (assoc-ref outputs "out")) - (gem-home (string-append out "/lib/ruby/gems/" ruby-version))) + (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0"))) (setenv "GEM_HOME" gem-home) (mkdir-p gem-home) (zero? (system* "gem" "install" "--local" diff --git a/guix/derivations.scm b/guix/derivations.scm index e5922365a..4b0048b54 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -97,6 +97,9 @@ build-derivations built-derivations + %graft? + set-grafting + build-expression->derivation) ;; Re-export it from here for backward compatibility. @@ -1287,3 +1290,16 @@ ALLOWED-REFERENCES, and LOCAL-BUILD?." (define built-derivations (store-lift build-derivations)) + +;; The following might feel more at home in (guix packages) but since (guix +;; gexp), which is a lower level, needs them, we put them here. + +(define %graft? + ;; Whether to honor package grafts by default. + (make-parameter #t)) + +(define (set-grafting enable?) + "This monadic procedure enables grafting when ENABLE? is true, and disables +it otherwise. It returns the previous setting." + (lambda (store) + (values (%graft? enable?) store))) diff --git a/guix/gexp.scm b/guix/gexp.scm index 1e2634210..f8646a081 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -20,7 +20,6 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) - #:use-module (guix packages) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -29,13 +28,20 @@ #:use-module (ice-9 match) #:export (gexp gexp? + + gexp-input + gexp-input? + gexp->derivation gexp->file gexp->script text-file* imported-files imported-modules - compiled-modules)) + compiled-modules + + define-gexp-compiler + gexp-compiler?)) ;;; Commentary: ;;; @@ -79,12 +85,74 @@ (set-record-type-printer! <gexp> write-gexp) + +;;; +;;; Methods. +;;; + +;; Compiler for a type of objects that may be introduced in a gexp. +(define-record-type <gexp-compiler> + (gexp-compiler predicate lower) + gexp-compiler? + (predicate gexp-compiler-predicate) + (lower gexp-compiler-lower)) + +(define %gexp-compilers + ;; List of <gexp-compiler>. + '()) + +(define (register-compiler! compiler) + "Register COMPILER as a gexp compiler." + (set! %gexp-compilers (cons compiler %gexp-compilers))) + +(define (lookup-compiler object) + "Search a compiler for OBJECT. Upon success, return the three argument +procedure to lower it; otherwise return #f." + (any (match-lambda + (($ <gexp-compiler> predicate lower) + (and (predicate object) lower))) + %gexp-compilers)) + +(define-syntax-rule (define-gexp-compiler (name (param predicate) + system target) + body ...) + "Define NAME as a compiler for objects matching PREDICATE encountered in +gexps. BODY must return a derivation for PARAM, an object that matches +PREDICATE, for SYSTEM and TARGET (the latter of which is #f except when +cross-compiling.)" + (begin + (define name + (gexp-compiler predicate + (lambda (param system target) + body ...))) + (register-compiler! name))) + + +;;; +;;; Inputs & outputs. +;;; + +;; The input of a gexp. +(define-record-type <gexp-input> + (%gexp-input thing output native?) + gexp-input? + (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ... + (output gexp-input-output) ;string + (native? gexp-input-native?)) ;Boolean + +(define* (gexp-input thing ;convenience procedure + #:optional (output "out") + #:key native?) + "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines +whether this should be considered a \"native\" input or not." + (%gexp-input thing output native?)) + ;; Reference to one of the derivation's outputs, for gexps used in ;; derivations. -(define-record-type <output-ref> - (output-ref name) - output-ref? - (name output-ref-name)) +(define-record-type <gexp-output> + (gexp-output name) + gexp-output? + (name gexp-output-name)) (define raw-derivation (store-lift derivation)) @@ -97,15 +165,11 @@ the cross-compilation target triplet." (with-monad %store-monad (sequence %store-monad (map (match-lambda - (((? package? package) sub-drv ...) - (mlet %store-monad - ((drv (if target - (package->cross-derivation package target - system) - (package->derivation package system)))) - (return `(,drv ,@sub-drv)))) - (((? origin? origin) sub-drv ...) - (mlet %store-monad ((drv (origin->derivation origin))) + ((and ((? derivation?) sub-drv ...) input) + (return input)) + ((and ((? struct? thing) sub-drv ...) input) + (mlet* %store-monad ((lower -> (lookup-compiler thing)) + (drv (lower thing system target))) (return `(,drv ,@sub-drv)))) (input (return input))) @@ -133,18 +197,22 @@ names and file names suitable for the #:allowed-references argument to (match-lambda ((? string? output) (return output)) - ((? package? package) - (mlet %store-monad ((drv - (if target - (package->cross-derivation package target - #:system system - #:graft? #f) - (package->derivation package system - #:graft? #f)))) + (thing + (mlet* %store-monad ((lower -> (lookup-compiler thing)) + (drv (lower thing system target))) (return (derivation->output-path drv)))))) (sequence %store-monad (map lower lst)))) +(define default-guile-derivation + ;; Here we break the abstraction by talking to the higher-level layer. + ;; Thus, do the resolution lazily to hide the circular dependency. + (let ((proc (delay + (let ((iface (resolve-interface '(guix packages)))) + (module-ref iface 'default-guile-derivation))))) + (lambda (system) + ((force proc) system)))) + (define* (gexp->derivation name exp #:key system (target 'current) @@ -247,8 +315,7 @@ The other arguments are as for 'derivation'." (return #f))) (guile (if guile-for-build (return guile-for-build) - (package->derivation (default-guile) - system)))) + (default-guile-derivation system)))) (mbegin %store-monad (set-grafting graft?) ;restore the initial setting (raw-derivation name @@ -281,20 +348,27 @@ The other arguments are as for 'derivation'." references." (define (add-reference-inputs ref result) (match ref - (((? derivation?) (? string?)) - (cons ref result)) - (((? package?) (? string?)) - (cons ref result)) - (((? origin?) (? string?)) - (cons ref result)) - ((? gexp? exp) + (($ <gexp-input> (? derivation? drv) output) + (cons `(,drv ,output) result)) + (($ <gexp-input> (? gexp? exp)) (append (gexp-inputs exp references) result)) - (((? string? file)) - (if (direct-store-path? file) - (cons ref result) + (($ <gexp-input> (? string? str)) + (if (direct-store-path? str) + (cons `(,str) result) result)) - ((refs ...) - (fold-right add-reference-inputs result refs)) + (($ <gexp-input> (? struct? thing) output) + (if (lookup-compiler thing) + ;; THING is a derivation, or a package, or an origin, etc. + (cons `(,thing ,output) result) + result)) + (($ <gexp-input> (lst ...) output native?) + (fold-right add-reference-inputs result + ;; XXX: For now, automatically convert LST to a list of + ;; gexp-inputs. + (map (match-lambda + ((? gexp-input? x) x) + (x (%gexp-input x "out" native?))) + lst))) (_ ;; Ignore references to other kinds of objects. result))) @@ -310,10 +384,17 @@ references." "Return the outputs referred to by EXP as a list of strings." (define (add-reference-output ref result) (match ref - (($ <output-ref> name) + (($ <gexp-output> name) (cons name result)) - ((? gexp? exp) + (($ <gexp-input> (? gexp? exp)) (append (gexp-outputs exp) result)) + (($ <gexp-input> (lst ...) output native?) + ;; XXX: Automatically convert LST. + (add-reference-output (map (match-lambda + ((? gexp-input? x) x) + (x (%gexp-input x "out" native?))) + lst) + result)) ((lst ...) (fold-right add-reference-output result lst)) (_ @@ -330,30 +411,34 @@ and in the current monad setting (system type, etc.)" (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref - (((? derivation? drv) (? string? output)) + (($ <gexp-input> (? derivation? drv) output) (return (derivation->output-path drv output))) - (((? package? p) (? string? output)) - (package-file p - #:output output - #:system system - #:target (if native? #f target))) - (((? origin? o) (? string? output)) - (mlet %store-monad ((drv (origin->derivation o))) - (return (derivation->output-path drv output)))) - (($ <output-ref> output) + (($ <gexp-output> output) ;; Output file names are not known in advance but the daemon defines ;; an environment variable for each of them at build time, so use ;; that trick. (return `((@ (guile) getenv) ,output))) - ((? gexp? exp) + (($ <gexp-input> (? gexp? exp) output n?) (gexp->sexp exp #:system system - #:target (if native? #f target))) - (((? string? str)) - (return (if (direct-store-path? str) str ref))) - ((refs ...) + #:target (if (or n? native?) #f target))) + (($ <gexp-input> (refs ...) output n?) (sequence %store-monad - (map (cut reference->sexp <> native?) refs))) + (map (lambda (ref) + ;; XXX: Automatically convert REF to an gexp-input. + (reference->sexp + (if (gexp-input? ref) + ref + (%gexp-input ref "out" n?)) + native?)) + refs))) + (($ <gexp-input> (? struct? thing) output n?) + (let ((lower (lookup-compiler thing)) + (target (if (or n? native?) #f target))) + (mlet %store-monad ((drv (lower thing system target))) + (return (derivation->output-path drv output))))) + (($ <gexp-input> x) + (return x)) (x (return x))))) @@ -364,28 +449,6 @@ and in the current monad setting (system type, etc.)" (gexp-native-references exp)))))) (return (apply (gexp-proc exp) args)))) -(define (canonicalize-reference ref) - "Return a canonical variant of REF, which adds any missing output part in -package/derivation references." - (match ref - ((? package? p) - `(,p "out")) - ((? origin? o) - `(,o "out")) - ((? derivation? d) - `(,d "out")) - (((? package?) (? string?)) - ref) - (((? origin?) (? string?)) - ref) - (((? derivation?) (? string?)) - ref) - ((? string? s) - (if (direct-store-path? s) `(,s) s)) - ((refs ...) - (map canonicalize-reference refs)) - (x x))) - (define (syntax-location-string s) "Return a string representing the source code location of S." (let ((props (syntax-source s))) @@ -441,21 +504,21 @@ package/derivation references." ungexp-native ungexp-native-splicing output) ((ungexp output) - #'(output-ref "out")) + #'(gexp-output "out")) ((ungexp output name) - #'(output-ref name)) + #'(gexp-output name)) ((ungexp thing) - #'thing) + #'(%gexp-input thing "out" #f)) ((ungexp drv-or-pkg out) - #'(list drv-or-pkg out)) + #'(%gexp-input drv-or-pkg out #f)) ((ungexp-splicing lst) - #'lst) + #'(%gexp-input lst "out" #f)) ((ungexp-native thing) - #'thing) + #'(%gexp-input thing "out" #t)) ((ungexp-native drv-or-pkg out) - #'(list drv-or-pkg out)) + #'(%gexp-input drv-or-pkg out #t)) ((ungexp-native-splicing lst) - #'lst))) + #'(%gexp-input lst "out" #t)))) (define (substitute-ungexp exp substs) ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with @@ -506,8 +569,7 @@ package/derivation references." (sexp (substitute-references #'exp (zip escapes formals))) (refs (map escape->ref normals)) (nrefs (map escape->ref natives))) - #`(make-gexp (map canonicalize-reference (list #,@refs)) - (map canonicalize-reference (list #,@nrefs)) + #`(make-gexp (list #,@refs) (list #,@nrefs) (lambda #,formals #,sexp))))))) diff --git a/guix/licenses.scm b/guix/licenses.scm index 157e74bf3..1be35001f 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; @@ -24,7 +24,9 @@ agpl3 agpl3+ asl2.0 boost1.0 - bsd-2 bsd-3 bsd-4 bsd-style + bsd-2 bsd-3 bsd-4 + non-copyleft + bsd-style ;deprecated! cc0 cddl1.0 cecill-c @@ -42,6 +44,7 @@ ipa lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ mpl1.1 mpl2.0 + ms-pl ncsa openldap2.8 openssl psfl public-domain @@ -105,16 +108,23 @@ "http://directory.fsf.org/wiki/License:BSD_4Clause" "https://www.gnu.org/licenses/license-list#OriginalBSD")) -(define* (bsd-style uri #:optional (comment "")) - "Return a BSD-style license, whose full text can be found at URI, -which may be a file:// URI pointing the package's tree." - (license "BSD-style" +(define* (non-copyleft uri #:optional (comment "")) + "Return a lax, permissive, non-copyleft license (for example a variant of +the 3-clause BSD license or the Expat license), whose full text can be found +at URI, which may be a file:// URI pointing the package's tree." + (license "non-copyleft" uri (string-append - "This is a BSD-style, non-copyleft free software license. " + "This is a lax, non-copyleft free software license. " "Check the URI for details. " comment))) +(define bsd-style + ;; This alias is kept for backward-compatibility. Do not use it for new + ;; packages: it is ambiguous, as rightfully explained at + ;; <http://www.gnu.org/philosophy/words-to-avoid.html#BSD-style>. + non-copyleft) + (define cc0 (license "CC0" "http://directory.fsf.org/wiki/License:CC0" @@ -261,6 +271,11 @@ which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:MPLv2.0" "https://www.gnu.org/licenses/license-list#MPL-2.0")) +(define ms-pl + (license "Ms-PL" ;Microsoft Public License + "http://directory.fsf.org/wiki/License:MsPL" + "http://www.gnu.org/licenses/license-list.html#ms-pl")) + (define ncsa (license "NCSA/University of Illinois Open Source License" "http://directory.fsf.org/wiki/License:IllinoisNCSA" diff --git a/guix/packages.scm b/guix/packages.scm index fc5264673..ec0e79d08 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -22,6 +22,7 @@ #:use-module (guix records) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix base32) #:use-module (guix derivations) #:use-module (guix build-system) @@ -103,7 +104,6 @@ &package-cross-build-system-error package-cross-build-system-error? - %graft? package->bag bag->derivation bag-transitive-inputs @@ -112,9 +112,8 @@ bag-transitive-target-inputs default-guile - + default-guile-derivation set-guile-for-build - set-grafting package-file package->derivation package->cross-derivation @@ -344,6 +343,12 @@ derivations." (let ((distro (resolve-interface '(gnu packages commencement)))) (module-ref distro 'guile-final))) +(define* (default-guile-derivation #:optional (system (%current-system))) + "Return the derivation for SYSTEM of the default Guile package used to run +the build code of derivation." + (package->derivation (default-guile) system + #:graft? #f)) + ;; TODO: Rewrite using %STORE-MONAD and gexps. (define* (patch-and-repack store source patches #:key @@ -678,10 +683,6 @@ information in exceptions." (package package) (input x))))))) -(define %graft? - ;; Whether to honor package grafts by default. - (make-parameter #t)) - (define* (package->bag package #:optional (system (%current-system)) (target (%current-target-system)) @@ -918,12 +919,6 @@ code of derivations to GUILE, a package object." (let ((guile (package-derivation store guile))) (values (%guile-for-build guile) store)))) -(define (set-grafting enable?) - "This monadic procedure enables grafting when ENABLE? is true, and disables -it otherwise. It returns the previous setting." - (lambda (store) - (values (%graft? enable?) store))) - (define* (package-file package #:optional file #:key @@ -952,6 +947,13 @@ cross-compilation target triplet." (define package->cross-derivation (store-lift package-cross-derivation)) +(define-gexp-compiler (package-compiler (package package?) system target) + ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for + ;; TARGET. This is used when referring to a package from within a gexp. + (if target + (package->cross-derivation package target system) + (package->derivation package system))) + (define patch-and-repack* (store-lift patch-and-repack)) @@ -989,5 +991,10 @@ outside of the store) or SOURCE itself (if SOURCE is already a store item.)" (interned-file file (basename file) #:recursive? #t)))) +(define-gexp-compiler (origin-compiler (origin origin?) system target) + ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring + ;; to an origin from within a gexp. + (origin->derivation origin system)) + (define package-source-derivation (store-lower origin->derivation)) diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 7306b6692..f90c2e61d 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -251,8 +251,8 @@ must be a symbol: 'dsa, 'ecc, or 'rsa." (bytevector->base16-string bv)))) (define (key-type sexp) - "Return a symbol denoting the type of key representing by SEXP--e.g., 'rsa', -'ecc'--or #f if SEXP does not denote a valid key." + "Return a symbol denoting the type of public or private key represented by +SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key." (case (canonical-sexp-nth-data sexp 0) ((public-key private-key) (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0)) diff --git a/guix/profiles.scm b/guix/profiles.scm index d62674923..465aaf947 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -155,9 +155,9 @@ omitted or #f, use the first output of PACKAGE." (let ((deps (map (match-lambda ((label package) - `(,package "out")) + (gexp-input package)) ((label package output) - `(,package ,output))) + (gexp-input package output))) (package-transitive-propagated-inputs package)))) (manifest-entry (name (package-name package)) @@ -356,22 +356,12 @@ replace it." ;;; (define (manifest-inputs manifest) - "Return the list of inputs for MANIFEST. Each input has one of the -following forms: - - (PACKAGE OUTPUT-NAME) - -or - - STORE-PATH -" + "Return a list of <gexp-input> objects for MANIFEST." (append-map (match-lambda - (($ <manifest-entry> name version - output (? package? package) deps) - `((,package ,output) ,@deps)) - (($ <manifest-entry> name version output path deps) - ;; Assume PATH and DEPS are already valid. - `(,path ,@deps))) + (($ <manifest-entry> name version output thing deps) + ;; THING may be a package or a file name. In the latter case, + ;; assume it's already valid. Ditto for DEPS. + (cons (gexp-input thing output) deps))) (manifest-entries manifest))) (define (info-dir-file manifest) @@ -487,16 +477,11 @@ CA-CERTIFICATE-BUNDLE? is #f." (ca-certificate-bundle manifest) (return #f)))) (define inputs - ;; XXX: Here we use tuples of the form (DIR "out") just so that the list - ;; is unambiguous for the gexp code when MANIFEST has a single input - ;; denoted as a string (the pattern (DRV STRING) is normally - ;; interpreted in a gexp as "the STRING output of DRV".). See - ;; <http://lists.gnu.org/archive/html/guix-devel/2014-12/msg00292.html>. (append (if info-dir - `((,info-dir "out")) + (list (gexp-input info-dir)) '()) (if ca-cert-bundle - `((,ca-cert-bundle "out")) + (list (gexp-input ca-cert-bundle)) '()) (manifest-inputs manifest))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c96ca351c..80ae92441 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -220,21 +220,22 @@ packages." (define (handle-argument arg result) (alist-cons 'package arg result)) - (with-store store - (let* ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument)) - (pure? (assoc-ref opts 'pure)) - (command (assoc-ref opts 'exec)) - (inputs (packages->transitive-inputs - (pick-all (options/resolve-packages opts) 'package))) - (drvs (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (build-inputs inputs opts))))) - (cond ((assoc-ref opts 'dry-run?) - #t) - ((assoc-ref opts 'search-paths) - (show-search-paths inputs drvs pure?)) - (else - (create-environment inputs drvs pure?) - (system command)))))) + (with-error-handling + (with-store store + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (pure? (assoc-ref opts 'pure)) + (command (assoc-ref opts 'exec)) + (inputs (packages->transitive-inputs + (pick-all (options/resolve-packages opts) 'package))) + (drvs (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (build-inputs inputs opts))))) + (cond ((assoc-ref opts 'dry-run?) + #t) + ((assoc-ref opts 'search-paths) + (show-search-paths inputs drvs pure?)) + (else + (create-environment inputs drvs pure?) + (system command))))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index fef05635b..69717b631 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -47,7 +47,8 @@ check-inputs-should-be-native check-patches check-synopsis-style - check-home-page)) + check-home-page + check-source)) ;;; diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 903564cc4..50e3db2fb 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -631,7 +631,12 @@ found." (assoc-ref (daemon-options) option)) (define %cache-url - (match (and=> (find-daemon-option "substitute-urls") + (match (and=> (string-append + ;; TODO: Uncomment the following lines when multiple + ;; substitute sources are supported. + ;; (find-daemon-option "untrusted-substitute-urls") ;client + ;; " " + (find-daemon-option "substitute-urls")) ;admin string-tokenize) ((url) url) diff --git a/guix/serialization.scm b/guix/serialization.scm index 4f82c0686..a99f53ee0 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -29,7 +29,8 @@ #:export (write-int read-int write-long-long read-long-long write-padding - write-string read-string read-latin1-string + write-string + read-string read-latin1-string read-maybe-utf8-string write-string-list read-string-list write-string-pairs write-store-path read-store-path @@ -109,28 +110,41 @@ (bytevector-copy! s 0 b 8 l) (put-bytevector p b))) -(define (read-string p) +(define (read-byte-string p) (let* ((len (read-int p)) (m (modulo len 8)) - (bv (get-bytevector-n* p len)) - (str (utf8->string bv))) + (bv (get-bytevector-n* p len))) (or (zero? m) (get-bytevector-n* p (- 8 m))) - str)) + bv)) -(define (read-latin1-string p) - (let* ((len (read-int p)) - (m (modulo len 8)) - ;; Note: do not use 'get-string-n' to work around Guile bug - ;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for - ;; a discussion. - (str (get-bytevector-n* p len))) - (or (zero? m) - (get-bytevector-n* p (- 8 m))) +(define (read-string p) + (utf8->string (read-byte-string p))) +(define (read-latin1-string p) + "Read an ISO-8859-1 string from P." + ;; Note: do not use 'get-string-n' to work around Guile bug + ;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for + ;; a discussion. + (let ((bv (read-byte-string p))) ;; XXX: Rewrite using (ice-9 iconv) when the minimum requirement is ;; upgraded to Guile >= 2.0.9. - (list->string (map integer->char (bytevector->u8-list str))))) + (list->string (map integer->char (bytevector->u8-list bv))))) + +(define (read-maybe-utf8-string p) + "Read a serialized string from port P. Attempt to decode it as UTF-8 and +substitute invalid byte sequences with question marks. This is a +\"permissive\" UTF-8 decoder." + ;; XXX: We rely on the port's decoding mechanism to do permissive decoding + ;; and substitute invalid byte sequences with question marks, but this is + ;; not very efficient. Eventually Guile may provide a lightweight + ;; permissive UTF-8 decoder. + (let* ((bv (read-byte-string p)) + (port (with-fluids ((%default-port-encoding "UTF-8") + (%default-port-conversion-strategy + 'substitute)) + (open-bytevector-input-port bv)))) + (get-string-all port))) (define (write-string-list l p) (write-int (length l) p) diff --git a/guix/store.scm b/guix/store.scm index d88fb3ea5..45c555b12 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -418,15 +418,18 @@ encoding conversion errors." (write-padding len p) #f)) ((= k %stderr-next) - ;; Log a string. - (let ((s (read-latin1-string p))) + ;; Log a string. Build logs are usually UTF-8-encoded, but they + ;; may also contain arbitrary byte sequences that should not cause + ;; this to fail. Thus, use the permissive + ;; 'read-maybe-utf8-string'. + (let ((s (read-maybe-utf8-string p))) (display s (current-build-output-port)) (when (string-any %newlines s) (flush-output-port (current-build-output-port))) #f)) ((= k %stderr-error) ;; Report an error. - (let ((error (read-latin1-string p)) + (let ((error (read-maybe-utf8-string p)) ;; Currently the daemon fails to send a status code for early ;; errors like DB schema version mismatches, so check for EOF. (status (if (and (>= (nix-server-minor-version server) 8) @@ -456,7 +459,7 @@ encoding conversion errors." (print-build-trace #t) (build-cores (current-processor-count)) (use-substitutes? #t) - (binary-caches '())) ; client "untrusted" cache URLs + (substitute-urls '())) ; client "untrusted" cache URLs ;; Must be called after `open-connection'. (define socket @@ -481,10 +484,10 @@ encoding conversion errors." (when (>= (nix-server-minor-version server) 10) (send (boolean use-substitutes?))) (when (>= (nix-server-minor-version server) 12) - (let ((pairs (if timeout - `(("build-timeout" . ,(number->string timeout)) - ,@binary-caches) - binary-caches))) + (let ((pairs `(,@(if timeout + `(("build-timeout" . ,(number->string timeout))) + '()) + ("substitute-urls" . ,(string-join substitute-urls))))) (send (string-pairs pairs)))) (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) |