diff options
Diffstat (limited to 'guix')
82 files changed, 3602 insertions, 1881 deletions
diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 550f92bc7f..228b4e60d2 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -39,6 +39,7 @@ (define %ant-build-system-modules ;; Build-side modules imported by default. `((guix build ant-build-system) + (guix build java-utils) (guix build syscalls) ,@%gnu-build-system-modules)) @@ -93,11 +94,13 @@ (define* (ant-build store name inputs #:key (tests? #t) - (test-target "tests") + (test-target "check") (configure-flags ''()) (make-flags ''()) (build-target "jar") (jar-name #f) + (source-dir "src") + (test-dir "src/test") (phases '(@ (guix build ant-build-system) %standard-phases)) (outputs '("out")) @@ -106,6 +109,7 @@ (guile #f) (imported-modules %ant-build-system-modules) (modules '((guix build ant-build-system) + (guix build java-utils) (guix build utils)))) "Build SOURCE with INPUTS." (define builder @@ -126,6 +130,8 @@ #:test-target ,test-target #:build-target ,build-target #:jar-name ,jar-name + #:source-dir ,source-dir + #:test-dir ,test-dir #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f28c098ea2..ec8b64497f 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,9 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-separated-name->name+version))) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) @@ -163,39 +166,40 @@ set up using CL source package conventions." (match-lambda ((name content . rest) (let* ((is-package? (package? content)) - (new-content (if is-package? (transform content) content)) - (new-name (if (and is-package? - (string-prefix? from-prefix name)) - (package-name new-content) - name))) - `(,new-name ,new-content ,@rest))))) + (new-content (if is-package? (transform content) content))) + `(,name ,new-content ,@rest))))) ;; Special considerations for source packages: CL inputs become - ;; propagated, and un-handled arguments are removed. Native inputs are - ;; removed as are extraneous outputs. + ;; propagated, and un-handled arguments are removed. + (define new-propagated-inputs (if target-is-source? (map rewrite - (filter (match-lambda - ((_ input . _) - (has-from-build-system? input))) - (package-inputs pkg))) - '())) - - (define new-inputs + (append + (filter (match-lambda + ((_ input . _) + (has-from-build-system? input))) + (append (package-inputs pkg) + ;; The native inputs might be needed just + ;; to load the system. + (package-native-inputs pkg))) + (package-propagated-inputs pkg))) + + (map rewrite (package-propagated-inputs pkg)))) + + (define (new-inputs inputs-getter) (if target-is-source? (map rewrite (filter (match-lambda ((_ input . _) (not (has-from-build-system? input)))) - (package-inputs pkg))) - (map rewrite (package-inputs pkg)))) + (inputs-getter pkg))) + (map rewrite (inputs-getter pkg)))) (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:special-dependencies #:asd-file - #:test-only-systems #:lisp) + '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) (package-arguments pkg)) (package-arguments pkg))) @@ -213,11 +217,9 @@ set up using CL source package conventions." (arguments (substitute-keyword-arguments base-arguments ((#:phases phases) (list phases-transformer phases)))) - (inputs new-inputs) + (inputs (new-inputs package-inputs)) (propagated-inputs new-propagated-inputs) - (native-inputs (if target-is-source? - '() - (map rewrite (package-native-inputs pkg)))) + (native-inputs (new-inputs package-native-inputs)) (outputs (if target-is-source? '("out") (package-outputs pkg))))) @@ -233,10 +235,10 @@ set up using CL source package conventions." (properties (alist-delete variant properties))) pkg)) -(define (lower lisp-implementation) +(define (lower lisp-type) (lambda* (name #:key source inputs outputs native-inputs system target - (lisp (default-lisp (string->symbol lisp-implementation))) + (lisp (default-lisp (string->symbol lisp-type))) #:allow-other-keys #:rest arguments) "Return a bag for NAME" @@ -252,20 +254,19 @@ set up using CL source package conventions." '()) ,@inputs ,@(standard-packages))) - (build-inputs `((,lisp-implementation ,lisp) + (build-inputs `((,lisp-type ,lisp) ,@native-inputs)) (outputs outputs) - (build (asdf-build lisp-implementation)) + (build (asdf-build lisp-type)) (arguments (strip-keyword-arguments private-keywords arguments)))))) -(define (asdf-build lisp-implementation) +(define (asdf-build lisp-type) (lambda* (store name inputs #:key source outputs (tests? #t) - (special-dependencies ''()) (asd-file #f) - (test-only-systems ''()) - (lisp lisp-implementation) + (asd-system-name #f) + (test-asd-file #f) (phases '(@ (guix build asdf-build-system) %standard-phases)) (search-paths '()) @@ -274,26 +275,36 @@ set up using CL source package conventions." (imported-modules %asdf-build-system-modules) (modules %asdf-build-modules)) + (define system-name + (or asd-system-name + (string-drop + ;; NAME is the value returned from `package-full-name'. + (hyphen-separated-name->name+version name) + (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix. + (define builder `(begin (use-modules ,@modules) - (asdf-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:lisp ,lisp - #:special-dependencies ,special-dependencies - #:asd-file ,asd-file - #:test-only-systems ,test-only-systems - #:system ,system - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (parameterize ((%lisp (string-append + (assoc-ref %build-inputs ,lisp-type) + "/bin/" ,lisp-type)) + (%lisp-type ,lisp-type)) + (asdf-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) source) + (source source)) + #:asd-file ,(or asd-file (string-append system-name ".asd")) + #:asd-system-name ,system-name + #:test-asd-file ,test-asd-file + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs)))) (define guile-for-build (match guile diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index a7982002b6..9a46ecfd26 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -83,6 +83,8 @@ (phases '(@ (guix build emacs-build-system) %standard-phases)) (outputs '("out")) + (include ''("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) + (exclude ''("^\\.dir-locals\\.el$" "-pkg\\.el$" "^[^/]*tests?\\.el$")) (search-paths '()) (system (%current-system)) (guile #f) @@ -108,6 +110,8 @@ #:tests? ,tests? #:phases ,phases #:outputs %outputs + #:include ,include + #:exclude ,exclude #:search-paths ',(map search-path-specification->sexp search-paths) #:inputs %build-inputs))) diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index f4f57b5ad5..34a22ecffa 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -15,7 +16,6 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - (define-module (guix build-system ocaml) #:use-module (guix store) #:use-module (guix utils) @@ -25,7 +25,10 @@ #:use-module (guix build-system gnu) #:use-module (guix packages) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (%ocaml-build-system-modules + package-with-ocaml4.01 + strip-ocaml4.01-variant ocaml-build ocaml-build-system)) @@ -71,6 +74,77 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml-findlib))) +(define (default-ocaml4.01) + (let ((ocaml (resolve-interface '(gnu packages ocaml)))) + (module-ref ocaml 'ocaml-4.01))) + +(define (default-ocaml4.01-findlib) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml4.01-findlib))) + +(define* (package-with-explicit-ocaml ocaml findlib old-prefix new-prefix + #:key variant-property) + "Return a procedure of one argument, P. The procedure creates a package +with the same fields as P, which is assumed to use OCAML-BUILD-SYSTEM, such +that it is compiled with OCAML and FINDLIB instead. The inputs are changed +recursively accordingly. If the name of P starts with OLD-PREFIX, this is +replaced by NEW-PREFIX; otherwise, NEW-PREFIX is prepended to the name. + +When VARIANT-PROPERTY is present, it is used as a key to search for +pre-defined variants of this transformation recorded in the 'properties' field +of packages. The property value must be the promise of a package. This is a +convenient way for package writers to force the transformation to use +pre-defined variants." + (define package-variant + (if variant-property + (lambda (package) + (assq-ref (package-properties package) + variant-property)) + (const #f))) + + (define (transform p) + (cond + ;; If VARIANT-PROPERTY is present, use that. + ((package-variant p) + => force) + + ;; Otherwise build the new package object graph. + ((eq? (package-build-system p) ocaml-build-system) + (package + (inherit p) + (location (package-location p)) + (name (let ((name (package-name p))) + (string-append new-prefix + (if (string-prefix? old-prefix name) + (substring name + (string-length old-prefix)) + name)))) + (arguments + (let ((ocaml (if (promise? ocaml) (force ocaml) ocaml)) + (findlib (if (promise? findlib) (force findlib) findlib))) + (ensure-keyword-arguments (package-arguments p) + `(#:ocaml ,ocaml + #:findlib ,findlib)))))) + (else p))) + + (define (cut? p) + (or (not (eq? (package-build-system p) ocaml-build-system)) + (package-variant p))) + + (package-mapping transform cut?)) + +(define package-with-ocaml4.01 + (package-with-explicit-ocaml (delay (default-ocaml4.01)) + (delay (default-ocaml4.01-findlib)) + "ocaml-" "ocaml4.01-" + #:variant-property 'ocaml4.01-variant)) + +(define (strip-ocaml4.01-variant p) + "Remove the 'ocaml4.01-variant' property from P." + (package + (inherit p) + (properties (alist-delete 'ocaml4.01-variant (package-properties p))))) + (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 17173f121e..ffed837313 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -83,54 +83,43 @@ pre-defined variants of this transformation recorded in the 'properties' field of packages. The property value must be the promise of a package. This is a convenient way for package writers to force the transformation to use pre-defined variants." - (define transform - ;; Memoize the transformations. Failing to do that, we would build a huge - ;; object graph with lots of duplicates, which in turns prevents us from - ;; benefiting from memoization in 'package-derivation'. - (mlambdaq (p) - (let* ((rewrite-if-package - (lambda (content) - ;; CONTENT may be a file name, in which case it is returned, - ;; or a package, which is rewritten with the new PYTHON and - ;; NEW-PREFIX. - (if (package? content) - (transform content) - content))) - (rewrite - (match-lambda - ((name content . rest) - (append (list name (rewrite-if-package content)) rest))))) - - (cond - ;; If VARIANT-PROPERTY is present, use that. - ((and variant-property - (assoc-ref (package-properties p) variant-property)) - => force) - - ;; Otherwise build the new package object graph. - ((eq? (package-build-system p) python-build-system) - (package - (inherit p) - (location (package-location p)) - (name (let ((name (package-name p))) - (string-append new-prefix - (if (string-prefix? old-prefix name) - (substring name - (string-length old-prefix)) - name)))) - (arguments - (let ((python (if (promise? python) - (force python) - python))) - (ensure-keyword-arguments (package-arguments p) - `(#:python ,python)))) - (inputs (map rewrite (package-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))))) - (else - p))))) - - transform) + (define package-variant + (if variant-property + (lambda (package) + (assq-ref (package-properties package) + variant-property)) + (const #f))) + + (define (transform p) + (cond + ;; If VARIANT-PROPERTY is present, use that. + ((package-variant p) + => force) + + ;; Otherwise build the new package object graph. + ((eq? (package-build-system p) python-build-system) + (package + (inherit p) + (location (package-location p)) + (name (let ((name (package-name p))) + (string-append new-prefix + (if (string-prefix? old-prefix name) + (substring name + (string-length old-prefix)) + name)))) + (arguments + (let ((python (if (promise? python) + (force python) + python))) + (ensure-keyword-arguments (package-arguments p) + `(#:python ,python)))))) + (else p))) + + (define (cut? p) + (or (not (eq? (package-build-system p) python-build-system)) + (package-variant p))) + + (package-mapping transform cut?)) (define package-with-python2 ;; Note: delay call to 'default-python2' until after the 'arguments' field diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 00a4a46d81..4042630a10 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -35,7 +35,8 @@ ;; ;; Code: -(define (default-build.xml jar-name prefix) +(define* (default-build.xml jar-name prefix #:optional + (source-dir ".") (test-dir "./test")) "Create a simple build.xml with standard targets for Ant." (call-with-output-file "build.xml" (lambda (port) @@ -47,6 +48,10 @@ (value "${basedir}/build/jar"))) (property (@ (name "dist.dir") (value ,prefix))) + (property (@ (name "test.home") + (value ,test-dir))) + (property (@ (name "test.classes.dir") + (value "${basedir}/build/test-classes"))) ;; respect the CLASSPATH environment variable (property (@ (name "build.sysclasspath") @@ -58,10 +63,39 @@ (target (@ (name "compile")) (mkdir (@ (dir "${classes.dir}"))) (javac (@ (includeantruntime "false") - (srcdir "src") + (srcdir ,source-dir) (destdir "${classes.dir}") (classpath (@ (refid "classpath")))))) + (target (@ (name "compile-tests")) + (mkdir (@ (dir "${test.classes.dir}"))) + (javac (@ (includeantruntime "false") + (srcdir ,test-dir) + (destdir "${test.classes.dir}")) + (classpath + (pathelement (@ (path "${env.CLASSPATH}"))) + (pathelement (@ (location "${classes.dir}"))) + (pathelement (@ (location "${test.classes.dir}")))))) + + (target (@ (name "check") + (depends "compile-tests")) + (mkdir (@ (dir "${test.home}/test-reports"))) + (junit (@ (printsummary "true") + (showoutput "true") + (fork "yes") + (haltonfailure "yes")) + (classpath + (pathelement (@ (path "${env.CLASSPATH}"))) + (pathelement (@ (location "${test.home}/resources"))) + (pathelement (@ (location "${classes.dir}"))) + (pathelement (@ (location "${test.classes.dir}")))) + (formatter (@ (type "plain") + (usefile "true"))) + (batchtest (@ (fork "yes") + (todir "${test.home}/test-reports")) + (fileset (@ (dir "${test.home}/java")) + (include (@ (name "**/*Test.java" ))))))) + (target (@ (name "jar") (depends "compile")) (mkdir (@ (dir "${jar.dir}"))) @@ -98,11 +132,13 @@ to the default GNU unpack strategy." ((assq-ref gnu:%standard-phases 'unpack) #:source source))) (define* (configure #:key inputs outputs (jar-name #f) - #:allow-other-keys) + (source-dir "src") + (test-dir "src/test") #:allow-other-keys) (when jar-name (default-build.xml jar-name (string-append (assoc-ref outputs "out") - "/share/java"))) + "/share/java") + source-dir test-dir)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) (setenv "CLASSPATH" (generate-classpath inputs))) diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 085d073dea..c5e820a00a 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix build utils) #:use-module (guix build lisp-utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) @@ -42,50 +43,42 @@ (define %object-prefix "/lib") -(define (source-install-prefix lisp) - (string-append %install-prefix "/" lisp "-source")) +(define (%lisp-source-install-prefix) + (string-append %source-install-prefix "/" (%lisp-type) "-source")) (define %system-install-prefix - (string-append %install-prefix "/systems")) + (string-append %source-install-prefix "/systems")) -(define (output-path->package-name path) - (package-name->name+version (strip-store-file-name path))) - -(define (outputs->name outputs) - (output-path->package-name - (assoc-ref outputs "out"))) - -(define (lisp-source-directory output lisp name) - (string-append output (source-install-prefix lisp) "/" name)) +(define (lisp-source-directory output name) + (string-append output (%lisp-source-install-prefix) "/" name)) (define (source-directory output name) - (string-append output %install-prefix "/source/" name)) + (string-append output %source-install-prefix "/source/" name)) -(define (library-directory output lisp) +(define (library-directory output) (string-append output %object-prefix - "/" lisp)) + "/" (%lisp-type))) (define (output-translation source-path - object-output - lisp) + object-output) "Return a translation for the system's source path to it's binary output." `((,source-path :**/ :*.*.*) - (,(library-directory object-output lisp) + (,(library-directory object-output) :**/ :*.*.*))) -(define (source-asd-file output lisp name asd-file) - (string-append (lisp-source-directory output lisp name) "/" asd-file)) - -(define (copy-files-to-output outputs output name) - "Copy all files from OUTPUT to \"out\". Create an extra link to any -system-defining files in the source to a convenient location. This is done -before any compiling so that the compiled source locations will be valid." - (let* ((out (assoc-ref outputs output)) - (source (getcwd)) - (target (source-directory out name)) - (system-path (string-append out %system-install-prefix))) +(define (source-asd-file output name asd-file) + (string-append (lisp-source-directory output name) "/" asd-file)) + +(define (copy-files-to-output out name) + "Copy all files from the current directory to OUT. Create an extra link to +any system-defining files in the source to a convenient location. This is +done before any compiling so that the compiled source locations will be +valid." + (let ((source (getcwd)) + (target (source-directory out name)) + (system-path (string-append out %system-install-prefix))) (copy-recursively source target) (mkdir-p system-path) (for-each @@ -97,45 +90,38 @@ before any compiling so that the compiled source locations will be valid." (define* (install #:key outputs #:allow-other-keys) "Copy and symlink all the source files." - (copy-files-to-output outputs "out" (outputs->name outputs))) - -(define* (copy-source #:key outputs lisp #:allow-other-keys) - "Copy the source to \"out\"." - (let* ((out (assoc-ref outputs "out")) - (name (remove-lisp-from-name (output-path->package-name out) lisp)) - (install-path (string-append out %install-prefix))) - (copy-files-to-output outputs "out" name) + (define output (assoc-ref outputs "out")) + (copy-files-to-output output + (package-name->name+version + (strip-store-file-name output)))) + +(define* (copy-source #:key outputs asd-system-name #:allow-other-keys) + "Copy the source to the library output." + (let* ((out (library-output outputs)) + (install-path (string-append out %source-install-prefix))) + (copy-files-to-output out asd-system-name) ;; Hide the files from asdf (with-directory-excursion install-path - (rename-file "source" (string-append lisp "-source")) + (rename-file "source" (string-append (%lisp-type) "-source")) (delete-file-recursively "systems"))) #t) -(define* (build #:key outputs inputs lisp asd-file +(define* (build #:key outputs inputs asd-file asd-system-name #:allow-other-keys) "Compile the system." - (let* ((out (assoc-ref outputs "out")) - (name (remove-lisp-from-name (output-path->package-name out) lisp)) - (source-path (lisp-source-directory out lisp name)) + (let* ((out (library-output outputs)) + (source-path (lisp-source-directory out asd-system-name)) (translations (wrap-output-translations `(,(output-translation source-path - out - lisp)))) - (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + out)))) + (asd-file (source-asd-file out asd-system-name asd-file))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) - ;; We don't need this if we have the asd file, and it can mess with the - ;; load ordering we're trying to enforce - (unless asd-file - (prepend-to-source-registry (string-append source-path "//"))) - (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache - (parameterize ((%lisp (string-append - (assoc-ref inputs lisp) "/bin/" lisp))) - (compile-system name lisp asd-file)) + (compile-system asd-system-name asd-file) ;; As above, ecl will sometimes create this even though it doesn't use it @@ -144,56 +130,48 @@ before any compiling so that the compiled source locations will be valid." (delete-file-recursively cache-directory)))) #t) -(define* (check #:key lisp tests? outputs inputs asd-file +(define* (check #:key tests? outputs inputs asd-file asd-system-name + test-asd-file #:allow-other-keys) "Test the system." - (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp)) - (out (assoc-ref outputs "out")) - (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + (let* ((out (library-output outputs)) + (asd-file (source-asd-file out asd-system-name asd-file)) + (test-asd-file + (and=> test-asd-file + (cut source-asd-file out asd-system-name <>)))) (if tests? - (parameterize ((%lisp (string-append - (assoc-ref inputs lisp) "/bin/" lisp))) - (test-system name lisp asd-file)) + (test-system asd-system-name asd-file test-asd-file) (format #t "test suite not run~%"))) #t) -(define* (patch-asd-files #:key outputs +(define* (create-asd-file #:key outputs inputs - lisp - special-dependencies - test-only-systems + asd-file + asd-system-name #:allow-other-keys) - "Patch any asd files created by the compilation process so that they can -find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only -included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP -implementation itself provides." - (let* ((out (assoc-ref outputs "out")) - (name (remove-lisp-from-name (output-path->package-name out) lisp)) - (registry (lset-difference - (lambda (input system) - (match input - ((name . path) (string=? name system)))) - (lisp-dependencies lisp inputs) - test-only-systems)) - (lisp-systems (map first registry))) - - (for-each - (lambda (asd-file) - (patch-asd-file asd-file registry lisp - (append lisp-systems special-dependencies))) - (find-files out "\\.asd$"))) + "Create a system definition file for the built system." + (let*-values (((out) (library-output outputs)) + ((_ version) (package-name->name+version + (strip-store-file-name out))) + ((new-asd-file) (string-append + (library-directory out) + "/" (normalize-string asd-system-name) + ".asd"))) + + (make-asd-file new-asd-file + #:system asd-system-name + #:version version + #:inputs inputs + #:system-asd-file asd-file)) #t) -(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys) +(define* (symlink-asd-files #:key outputs #:allow-other-keys) "Create an extra reference to the system in a convenient location." - (let* ((out (assoc-ref outputs "out"))) + (let* ((out (library-output outputs))) (for-each (lambda (asd-file) - (substitute* asd-file - ((";;; Built for.*") "") ; remove potential non-determinism - (("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" end))) (receive (new-asd-file asd-file-directory) - (bundle-asd-file out asd-file lisp) + (bundle-asd-file out asd-file) (mkdir-p asd-file-directory) (symlink asd-file new-asd-file) ;; Update the source registry for future phases which might want to @@ -201,15 +179,14 @@ implementation itself provides." (prepend-to-source-registry (string-append asd-file-directory "/")))) - (find-files (string-append out %object-prefix) "\\.asd$")) -) + (find-files (string-append out %object-prefix) "\\.asd$"))) #t) -(define* (cleanup-files #:key outputs lisp - #:allow-other-keys) +(define* (cleanup-files #:key outputs + #:allow-other-keys) "Remove any compiled files which are not a part of the final bundle." - (let ((out (assoc-ref outputs "out"))) - (match lisp + (let ((out (library-output outputs))) + (match (%lisp-type) ("sbcl" (for-each (lambda (file) @@ -219,10 +196,9 @@ implementation itself provides." ("ecl" (for-each delete-file (append (find-files out "\\.fas$") - (find-files out "\\.o$") - (find-files out "\\.a$"))))) + (find-files out "\\.o$"))))) - (with-directory-excursion (library-directory out lisp) + (with-directory-excursion (library-directory out) (for-each (lambda (file) (rename-file file @@ -237,9 +213,9 @@ implementation itself provides." (string<> ".." file))))))) #t) -(define* (strip #:key lisp #:allow-other-keys #:rest args) +(define* (strip #:rest args) ;; stripping sbcl binaries removes their entry program and extra systems - (or (string=? lisp "sbcl") + (or (string=? (%lisp-type) "sbcl") (apply (assoc-ref gnu:%standard-phases 'strip) args))) (define %standard-phases/source @@ -257,8 +233,8 @@ implementation itself provides." (add-before 'build 'copy-source copy-source) (replace 'check check) (replace 'strip strip) - (add-after 'check 'link-dependencies patch-asd-files) - (add-after 'link-dependencies 'cleanup cleanup-files) + (add-after 'check 'create-asd-file create-asd-file) + (add-after 'create-asd-file 'cleanup cleanup-files) (add-after 'cleanup 'create-symlinks symlink-asd-files))) (define* (asdf-build #:key inputs diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index e948cd03d3..247a687d80 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; @@ -48,11 +48,19 @@ refers to." str)) (define* (display-tabulated lst - #:key (columns 3) - (column-width (/ 78 columns))) - "Display the list of string LST in COLUMNS columns of COLUMN-WIDTH -characters." + #:key + (terminal-width 80) + (column-gap 2)) + "Display the list of string LST in as many columns as needed given +TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." (define len (length lst)) + (define column-width + ;; The width of a column. Assume all the columns have the same width + ;; (GNU ls is smarter than that.) + (+ column-gap (reduce max 0 (map string-length lst)))) + (define columns + (max 1 + (quotient terminal-width column-width))) (define pad (if (zero? (modulo len columns)) 0 @@ -81,16 +89,30 @@ characters." (() (display-tabulated (scandir "."))) (files - (let ((files (filter (lambda (file) - (catch 'system-error - (lambda () - (lstat file)) - (lambda args - (let ((errno (system-error-errno args))) - (format (current-error-port) "~a: ~a~%" - file (strerror errno)) - #f)))) - files))) + (let ((files (append-map (lambda (file) + (catch 'system-error + (lambda () + (match (stat:type (lstat file)) + ('directory + ;; Like GNU ls, list the contents of + ;; FILE rather than FILE itself. + (match (scandir file + (match-lambda + ((or "." "..") #f) + (_ #t))) + (#f + (list file)) + ((files ...) + (map (cut string-append file "/" <>) + files)))) + (_ + (list file)))) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + '())))) + files))) (display-tabulated files))))) (define (ls-command . files) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index f11d858749..139b40321f 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -116,12 +117,12 @@ directory = '" port) (close-pipe port) result))) -;; Example dir-name: "/gnu/store/hwlr49riz3la33m6in2n898ly045ylld-rust-rand-0.3.15". (define (generate-checksums dir-name src-name) - "Given DIR-NAME, checksum all the files in it one by one and put the - result into the file \".cargo-checksum.json\" in the same directory. - Also includes the checksum of an extra file SRC-NAME as if it was - part of the directory DIR-NAME with name \"package\"." + "Given DIR-NAME, a store directory, checksum all the files in it one +by one and put the result into the file \".cargo-checksum.json\" in +the same directory. Also includes the checksum of an extra file +SRC-NAME as if it was part of the directory DIR-NAME with name +\"package\"." (let* ((file-names (find-files dir-name ".")) (dir-prefix-name (string-append dir-name "/")) (dir-prefix-name-len (string-length dir-prefix-name)) diff --git a/guix/build/download.scm b/guix/build/download.scm index e3d5244590..ce4708a873 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -140,6 +140,13 @@ Otherwise return STORE-PATH." (string-drop base 32))) store-path)) +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + (define* (progress-proc file size #:optional (log-port (current-output-port)) #:key (abbreviation basename)) @@ -389,7 +396,21 @@ host name without trailing dot." ;;(set-log-level! 10) ;;(set-log-procedure! log) - (handshake session) + (catch 'gnutls-error + (lambda () + (handshake session)) + (lambda (key err proc . rest) + (cond ((eq? err error/warning-alert-received) + ;; Like Wget, do no stop upon non-fatal alerts such as + ;; 'alert-description/unrecognized-name'. + (format (current-error-port) + "warning: TLS warning alert received: ~a~%" + (alert-description->string (alert-get session))) + (handshake session)) + (else + ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't + ;; provide a binding for this. + (apply throw key err proc rest))))) ;; Verify the server's certificate if needed. (when verify-certificate? diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 44e8b0d31e..50af4be363 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -47,10 +47,12 @@ (define (store-file->elisp-source-file file) "Convert FILE, a store file name for an Emacs Lisp source file, into a file name that has been stripped of the hash and version number." - (let-values (((name version) - (package-name->name+version - (strip-store-file-name file)))) - (string-append name ".el"))) + (let ((suffix ".el")) + (let-values (((name version) + (package-name->name+version + (basename + (strip-store-file-name file) suffix)))) + (string-append name suffix)))) (define* (unpack #:key source #:allow-other-keys) "Unpack SOURCE into the build directory. SOURCE may be a compressed @@ -93,14 +95,30 @@ store in '.el' files." (substitute-cmd)))) #t)) -(define* (install #:key outputs #:allow-other-keys) +(define* (install #:key outputs + (include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) + (exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$" "^[^/]*tests?\\.el$")) + #:allow-other-keys) "Install the package contents." + + (define source (getcwd)) + + (define (install-file? file stat) + (let ((stripped-file (string-trim (string-drop file (string-length source)) #\/))) + (and (any (cut string-match <> stripped-file) include) + (not (any (cut string-match <> stripped-file) exclude))))) + (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) - (src-dir (getcwd)) - (tgt-dir (string-append out %install-suffix "/" elpa-name-ver))) - (copy-recursively src-dir tgt-dir) - #t)) + (target-directory (string-append out %install-suffix "/" elpa-name-ver))) + (for-each + (lambda (file) + (let* ((stripped-file (string-drop file (string-length source))) + (target-file (string-append target-directory stripped-file))) + (format #t "`~a' -> `~a'~%" file target-file) + (install-file file (dirname target-file)))) + (find-files source install-file?))) + #t) (define* (move-doc #:key outputs #:allow-other-keys) "Move info files from the ELPA package directory to the info directory." diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm new file mode 100644 index 0000000000..402d377bf8 --- /dev/null +++ b/guix/build/java-utils.scm @@ -0,0 +1,55 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix build java-utils) + #:use-module (guix build utils) + #:export (ant-build-javadoc + install-jars + install-javadoc)) + +;; Copied from haskell-build-system.scm +(define (package-name-version store-dir) + "Given a store directory STORE-DIR return 'name-version' of the package." + (let* ((base (basename store-dir))) + (string-drop base (+ 1 (string-index base #\-))))) + +(define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) + #:allow-other-keys) + (zero? (apply system* `("ant" ,target ,@make-flags)))) + +(define* (install-jars jar-directory) + "Install jar files from JAR-DIRECTORY to the default target directory. This +is used in case the build.xml does not include an install target." + (lambda* (#:key outputs #:allow-other-keys) + (let ((share (string-append (assoc-ref outputs "out") + "/share/java"))) + (for-each (lambda (f) (install-file f share)) + (find-files jar-directory "\\.jar$")) + #t))) + +(define* (install-javadoc apidoc-directory) + "Install the APIDOC-DIRECTORY to the target directory. This is used to +install javadocs when this is not done by the install target." + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (docs (string-append (or (assoc-ref outputs "doc") out) + "/share/doc/" (package-name-version out) "/"))) + (mkdir-p docs) + (copy-recursively apidoc-directory docs) + #t))) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 55a07c7207..21cb620d59 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,13 +18,15 @@ (define-module (guix build lisp-utils) #:use-module (ice-9 format) + #:use-module (ice-9 hash-table) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (guix build utils) #:export (%lisp - %install-prefix + %lisp-type + %source-install-prefix lisp-eval-program compile-system test-system @@ -32,15 +34,16 @@ generate-executable-wrapper-system generate-executable-entry-point generate-executable-for-system - patch-asd-file - bundle-install-prefix - lisp-dependencies + %bundle-install-prefix bundle-asd-file - remove-lisp-from-name wrap-output-translations prepend-to-source-registry build-program - build-image)) + build-image + make-asd-file + valid-char-set + normalize-string + library-output)) ;;; Commentary: ;;; @@ -54,102 +57,164 @@ ;; File name of the Lisp compiler. (make-parameter "lisp")) -(define %install-prefix "/share/common-lisp") - -(define (bundle-install-prefix lisp) - (string-append %install-prefix "/" lisp "-bundle-systems")) +(define %lisp-type + ;; String representing the class of implementation being used. + (make-parameter "lisp")) -(define (remove-lisp-from-name name lisp) - (string-drop name (1+ (string-length lisp)))) +;; The common parent for Lisp source files, as will as the symbolic +;; link farm for system definition (.asd) files. +(define %source-install-prefix "/share/common-lisp") + +(define (%bundle-install-prefix) + (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems")) + +(define (library-output outputs) + "If a `lib' output exists, build things there. Otherwise use `out'." + (or (assoc-ref outputs "lib") (assoc-ref outputs "out"))) + +;; See nix/libstore/store-api.cc#checkStoreName. +(define valid-char-set + (string->char-set + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?=")) + +(define (normalize-string str) + "Replace invalid characters in STR with a hyphen." + (string-join (string-tokenize str valid-char-set) "-")) + +(define (inputs->asd-file-map inputs) + "Produce a hash table of the form (system . asd-file), where system is the +name of an ASD system, and asd-file is the full path to its definition." + (alist->hash-table + (filter-map + (match-lambda + ((_ . path) + (let ((prefix (string-append path (%bundle-install-prefix)))) + (and (directory-exists? prefix) + (match (find-files prefix "\\.asd$") + ((asd-file) + (cons + (string-drop-right (basename asd-file) 4) ; drop ".asd" + asd-file)) + (_ #f)))))) + inputs))) (define (wrap-output-translations translations) `(:output-translations ,@translations :inherit-configuration)) -(define (lisp-eval-program lisp program) +(define (lisp-eval-program program) "Evaluate PROGRAM with a given LISP implementation." (unless (zero? (apply system* - (lisp-invoke lisp (format #f "~S" program)))) - (error "lisp-eval-program failed!" lisp program))) - -(define (lisp-invoke lisp program) + (lisp-invocation program))) + (error "lisp-eval-program failed!" (%lisp) program))) + +(define (spread-statements program argument-name) + "Return a list with the statements from PROGRAM spread between +ARGUMENT-NAME, a string representing the argument a lisp implementation uses +to accept statements to be evaluated before starting." + (append-map (lambda (statement) + (list argument-name (format #f "~S" statement))) + program)) + +(define (lisp-invocation program) "Return a list of arguments for system* determining how to invoke LISP with PROGRAM." - (match lisp - ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program)) - ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")))) + (match (%lisp-type) + ("sbcl" `(,(%lisp) "--non-interactive" + ,@(spread-statements program "--eval"))) + ("ecl" `(,(%lisp) + ,@(spread-statements program "--eval") + "--eval" "(quit)")) + (_ (error "The LISP provided is not supported at this time.")))) (define (asdf-load-all systems) (map (lambda (system) - `(funcall - (find-symbol - (symbol-name :load-system) - (symbol-name :asdf)) - ,system)) + `(asdf:load-system ,system)) systems)) -(define (compile-system system lisp asd-file) +(define (compile-system system asd-file) "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE -first if SYSTEM is defined there." - (lisp-eval-program lisp - `(progn - (require :asdf) - (in-package :asdf) - ,@(if asd-file - `((load ,asd-file)) - '()) - (in-package :cl-user) - (funcall (find-symbol - (symbol-name :operate) - (symbol-name :asdf)) - (find-symbol - (symbol-name :compile-bundle-op) - (symbol-name :asdf)) - ,system) - (funcall (find-symbol - (symbol-name :operate) - (symbol-name :asdf)) - (find-symbol - (symbol-name :deliver-asd-op) - (symbol-name :asdf)) - ,system)))) - -(define (test-system system lisp asd-file) - "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first -if SYSTEM is defined there." - (lisp-eval-program lisp - `(progn - (require :asdf) - (in-package :asdf) - ,@(if asd-file - `((load ,asd-file)) - '()) - (in-package :cl-user) - (funcall (find-symbol - (symbol-name :test-system) - (symbol-name :asdf)) - ,system)))) +first." + (lisp-eval-program + `((require :asdf) + (let ((*package* (find-package :asdf))) + (load ,asd-file)) + (asdf:operate 'asdf:compile-bundle-op ,system)))) + +(define (system-dependencies system asd-file) + "Return the dependencies of SYSTEM, as reported by +asdf:system-depends-on. First load the system's ASD-FILE." + (define deps-file ".deps.sexp") + (define program + `((require :asdf) + (let ((*package* (find-package :asdf))) + (load ,asd-file)) + (with-open-file + (stream ,deps-file :direction :output) + (format stream + "~s~%" + (asdf:system-depends-on + (asdf:find-system ,system)))))) + + (dynamic-wind + (lambda _ + (lisp-eval-program program)) + (lambda _ + (call-with-input-file deps-file read)) + (lambda _ + (when (file-exists? deps-file) + (delete-file deps-file))))) + +(define (compiled-system system) + (let ((system (basename system))) ; this is how asdf handles slashes + (match (%lisp-type) + ("sbcl" (string-append system "--system")) + (_ system)))) + +(define* (generate-system-definition system + #:key version dependencies) + `(asdf:defsystem + ,(normalize-string system) + :class asdf/bundle:prebuilt-system + :version ,version + :depends-on ,dependencies + :components ((:compiled-file ,(compiled-system system))) + ,@(if (string=? "ecl" (%lisp-type)) + `(:lib ,(string-append system ".a")) + '()))) + +(define (test-system system asd-file test-asd-file) + "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first. +Also load TEST-ASD-FILE if necessary." + (lisp-eval-program + `((require :asdf) + (let ((*package* (find-package :asdf))) + (load ,asd-file) + ,@(if test-asd-file + `((load ,test-asd-file)) + ;; Try some likely files. + (map (lambda (file) + `(when (uiop:file-exists-p ,file) + (load ,file))) + (list + (string-append system "-tests.asd") + (string-append system "-test.asd") + "tests.asd" + "test.asd")))) + (asdf:test-system ,system)))) (define (string->lisp-keyword . strings) "Return a lisp keyword for the concatenation of STRINGS." (string->symbol (apply string-append ":" strings))) -(define (generate-executable-for-system type system lisp) - "Use LISP to generate an executable, whose TYPE can be \"image\" or -\"program\". The latter will always be standalone. Depends on having created -a \"SYSTEM-exec\" system which contains the entry program." +(define (generate-executable-for-system type system) + "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or +'asdf:program-op. The latter will always be standalone. Depends on having +created a \"SYSTEM-exec\" system which contains the entry program." (lisp-eval-program - lisp - `(progn - (require :asdf) - (funcall (find-symbol - (symbol-name :operate) - (symbol-name :asdf)) - (find-symbol - (symbol-name ,(string->lisp-keyword type "-op")) - (symbol-name :asdf)) - ,(string-append system "-exec"))))) + `((require :asdf) + (asdf:operate ',type ,(string-append system "-exec"))))) (define (generate-executable-wrapper-system system dependencies) "Generates a system which can be used by asdf to produce an image or program @@ -183,65 +248,59 @@ ENTRY-PROGRAM for SYSTEM within the current directory." (declare (ignorable arguments)) ,@entry-program)))))))) -(define (wrap-perform-method lisp registry dependencies file-name) - "Creates a wrapper method which allows the system to locate its dependent -systems from REGISTRY, an alist of the same form as %outputs, which contains -lisp systems which the systems is dependent on. All DEPENDENCIES which the -system depends on will the be loaded before this system." - (let* ((system (string-drop-right (basename file-name) 4)) - (system-symbol (string->lisp-keyword system))) - - `(defmethod asdf:perform :before - (op (c (eql (asdf:find-system ,system-symbol)))) - (asdf/source-registry:ensure-source-registry) - ,@(map (match-lambda - ((name . path) - (let ((asd-file (string-append path - (bundle-install-prefix lisp) - "/" name ".asd"))) - `(setf - (gethash ,name - asdf/source-registry:*source-registry*) - ,(string->symbol "#p") - ,(bundle-asd-file path asd-file lisp))))) - registry) - ,@(map (lambda (system) - `(asdf:load-system ,(string->lisp-keyword system))) - dependencies)))) - -(define (patch-asd-file asd-file registry lisp dependencies) - "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD." - (chmod asd-file #o644) - (let ((port (open-file asd-file "a"))) - (dynamic-wind - (lambda _ #t) - (lambda _ - (display - (replace-escaped-macros - (format #f "~%~y~%" - (wrap-perform-method lisp registry - dependencies asd-file))) - port)) - (lambda _ (close-port port)))) - (chmod asd-file #o444)) - -(define (lisp-dependencies lisp inputs) - "Determine which inputs are lisp system dependencies, by using the convention -that a lisp system dependency will resemble \"system-LISP\"." - (filter-map (match-lambda - ((name . value) - (and (string-prefix? lisp name) - (string<> lisp name) - `(,(remove-lisp-from-name name lisp) - . ,value)))) - inputs)) - -(define (bundle-asd-file output-path original-asd-file lisp) +(define (generate-dependency-links registry system) + "Creates a program which populates asdf's source registry from REGISTRY, an +alist of dependency names to corresponding asd files. This allows the system +to locate its dependent systems." + `(progn + (asdf/source-registry:ensure-source-registry) + ,@(map (match-lambda + ((name . asd-file) + `(setf + (gethash ,name + asdf/source-registry:*source-registry*) + ,(string->symbol "#p") + ,asd-file))) + registry))) + +(define* (make-asd-file asd-file + #:key system version inputs + (system-asd-file #f)) + "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the +system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS." + (define dependencies + (let ((deps + (system-dependencies system system-asd-file))) + (if (eq? 'NIL deps) + '() + (map normalize-string deps)))) + + (define lisp-input-map + (inputs->asd-file-map inputs)) + + (define registry + (filter-map hash-get-handle + (make-list (length dependencies) + lisp-input-map) + dependencies)) + + (call-with-output-file asd-file + (lambda (port) + (display + (replace-escaped-macros + (format #f "~y~%~y~%" + (generate-system-definition system + #:version version + #:dependencies dependencies) + (generate-dependency-links registry system))) + port)))) + +(define (bundle-asd-file output-path original-asd-file) "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two values: the asd file itself and the directory in which it resides." (let ((bundle-asd-path (string-append output-path - (bundle-install-prefix lisp)))) + (%bundle-install-prefix)))) (values (string-append bundle-asd-path "/" (basename original-asd-file)) bundle-asd-path))) @@ -256,19 +315,22 @@ which are not nested." (setenv "CL_SOURCE_REGISTRY" (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") "")))) -(define* (build-program lisp program #:key inputs +(define* (build-program program outputs #:key + (dependency-prefixes (list (library-output outputs))) (dependencies (list (basename program))) entry-program #:allow-other-keys) "Generate an executable program containing all DEPENDENCIES, and which will execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments' -has been bound to the command-line arguments which were passed." - (generate-executable lisp program - #:inputs inputs +has been bound to the command-line arguments which were passed. Link in any +asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are +retained." + (generate-executable program #:dependencies dependencies + #:dependency-prefixes dependency-prefixes #:entry-program entry-program - #:type "program") + #:type 'asdf:program-op) (let* ((name (basename program)) (bin-directory (dirname program))) (with-directory-excursion bin-directory @@ -276,16 +338,18 @@ has been bound to the command-line arguments which were passed." name))) #t) -(define* (build-image lisp image #:key inputs +(define* (build-image image outputs #:key + (dependency-prefixes (list (library-output outputs))) (dependencies (list (basename image))) #:allow-other-keys) "Generate an image, possibly standalone, which contains all DEPENDENCIES, -placing the result in IMAGE.image." - (generate-executable lisp image - #:inputs inputs +placing the result in IMAGE.image. Link in any asd files from +DEPENDENCY-PREFIXES to ensure references to those libraries are retained." + (generate-executable image #:dependencies dependencies + #:dependency-prefixes dependency-prefixes #:entry-program '(nil) - #:type "image") + #:type 'asdf:image-op) (let* ((name (basename image)) (bin-directory (dirname image))) (with-directory-excursion bin-directory @@ -293,14 +357,16 @@ placing the result in IMAGE.image." (string-append name ".image")))) #t) -(define* (generate-executable lisp out-file #:key inputs +(define* (generate-executable out-file #:key dependencies + dependency-prefixes entry-program type #:allow-other-keys) - "Generate an executable by using asdf's TYPE-op, containing whithin the + "Generate an executable by using asdf operation TYPE, containing whithin the image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an -executable." +executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure +references to those libraries are retained." (let* ((bin-directory (dirname out-file)) (name (basename out-file))) (mkdir-p bin-directory) @@ -319,9 +385,25 @@ executable." `(((,bin-directory :**/ :*.*.*) (,bin-directory :**/ :*.*.*))))))) - (parameterize ((%lisp (string-append - (assoc-ref inputs lisp) "/bin/" lisp))) - (generate-executable-for-system type name lisp)) + (generate-executable-for-system type name) + + (let* ((after-store-prefix-index + (string-index out-file #\/ + (1+ (string-length (%store-directory))))) + (output (string-take out-file after-store-prefix-index)) + (hidden-asd-links (string-append output "/.asd-files"))) + + (mkdir-p hidden-asd-links) + (for-each + (lambda (path) + (for-each + (lambda (asd-file) + (symlink asd-file + (string-append hidden-asd-links + "/" (basename asd-file)))) + (find-files (string-append path (%bundle-install-prefix)) + "\\.asd$"))) + dependency-prefixes)) (delete-file (string-append bin-directory "/" name "-exec.asd")) (delete-file (string-append bin-directory "/" name "-exec.lisp")))) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 42eabfaf19..5c96fe9067 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -75,14 +75,14 @@ definitions for all the SEARCH-PATHS." ;; 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. + ;; first positional parameter of the calling script, so we cannot 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 +# GUIX_PROFILE=/path/to/profile \\ # source /path/to/profile/etc/profile # # When GUIX_PROFILE is undefined, the various environment variables refer diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 6034e93cbf..d2e0404b14 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build pull) + #:use-module (guix modules) #:use-module (guix build utils) #:use-module (system base compile) #:use-module (ice-9 ftw) @@ -35,6 +36,56 @@ ;;; ;;; Code: +(define (depends-on-guile-ssh? file) + "Return true if FILE is a Scheme source file that depends, directly or +indirectly, on Guile-SSH." + (find (match-lambda + (('ssh _ ...) #t) + (_ #f)) + (source-module-closure file #:select? (const #t)))) + +(define (all-scheme-files directory) + "Return a sorted list of Scheme files found in DIRECTORY." + ;; Load guix/ modules before gnu/ modules to get somewhat steadier + ;; progress reporting. + (sort (filter (cut string-suffix? ".scm" <>) + (find-files directory "\\.scm")) + (let ((guix (string-append directory "/guix")) + (gnu (string-append directory "/gnu"))) + (lambda (a b) + (or (and (string-prefix? guix a) + (string-prefix? gnu b)) + (string<? a b)))))) + +(cond-expand + (guile-2.2 (use-modules (language tree-il optimize) + (language cps optimize))) + (else #f)) + +(define %default-optimizations + ;; Default optimization options (equivalent to -O2 on Guile 2.2). + (cond-expand + (guile-2.2 (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) + (else '()))) + +(define %lightweight-optimizations + ;; Lightweight optimizations (like -O0, but with partial evaluation). + (let loop ((opts %default-optimizations) + (result '())) + (match opts + (() (reverse result)) + ((#:partial-eval? _ rest ...) + (loop rest `(#t #:partial-eval? ,@result))) + ((kw _ rest ...) + (loop rest `(#f ,kw ,@result)))))) + +(define (optimization-options file) + (if (string-contains file "gnu/packages/") + %lightweight-optimizations ;build faster + '())) + + (define* (build-guix out source #:key system @@ -55,7 +106,8 @@ containing the source code. Write any debugging output to DEBUG-PORT." (setvbuf (current-error-port) _IOLBF) (with-directory-excursion source - (format #t "copying and compiling to '~a'...~%" out) + (format #t "copying and compiling to '~a' with Guile ~a...~%" + out (version)) ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm. (copy-recursively "guix" (string-append out "/guix") @@ -92,17 +144,12 @@ containing the source code. Write any debugging output to DEBUG-PORT." ;; Compile the .scm files. Load all the files before compiling them to ;; work around <http://bugs.gnu.org/15602> (FIXME). - (let* ((files - ;; Load guix/ modules before gnu/ modules to get somewhat steadier - ;; progress reporting. - (sort (filter (cut string-suffix? ".scm" <>) - (find-files out "\\.scm")) - (let ((guix (string-append out "/guix")) - (gnu (string-append out "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (string<? a b)))))) + ;; Filter out files depending on Guile-SSH when Guile-SSH is missing. + (let* ((files (remove (if (false-if-exception + (resolve-interface '(ssh session))) + (const #f) + depends-on-guile-ssh?) + (all-scheme-files out))) (total (length files))) (let loop ((files files) (completed 0)) @@ -140,7 +187,7 @@ containing the source code. Write any debugging output to DEBUG-PORT." (parameterize ((current-warning-port (%make-void-port "w"))) (compile-file file #:output-file go - #:opts %auto-compilation-options))) + #:opts (optimization-options file)))) (with-mutex mutex (set! completed (+ 1 completed)))) files)))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 5aae1530f4..0529c228a5 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,8 +45,6 @@ MNT_EXPIRE UMOUNT_NOFOLLOW restart-on-EINTR - mount - umount mount-points swapon swapoff @@ -83,17 +82,11 @@ PF_PACKET AF_PACKET - IFF_UP - IFF_BROADCAST - IFF_LOOPBACK all-network-interface-names network-interface-names - network-interface-flags network-interface-netmask loopback-network-interface? network-interface-address - set-network-interface-flags - set-network-interface-address set-network-interface-netmask set-network-interface-up configure-network-interface @@ -149,8 +142,19 @@ ;;; Commentary: ;;; ;;; This module provides bindings to libc's syscall wrappers. It uses the -;;; FFI, and thus requires a dynamically-linked Guile. (For statically-linked -;;; Guile, we instead apply 'guile-linux-syscalls.patch'.) +;;; FFI, and thus requires a dynamically-linked Guile. +;;; +;;; Some syscalls are already defined in statically-linked Guile by applying +;;; 'guile-linux-syscalls.patch'. +;;; +;;; Visibility of syscall's symbols shared between this module and static Guile +;;; is a bit delicate. It is handled by 'define-as-needed' macro. +;;; +;;; This macro is used to export symbols in dynamic Guile context, and to +;;; re-export them in static Guile context. +;;; +;;; This way, even if they don't appear in #:export list, it is safe to use +;;; syscalls from this module in static or dynamic Guile context. ;;; ;;; Code: @@ -409,6 +413,25 @@ the returned procedure is called." (error (format #f "~a: syscall->procedure failed: ~s" name args)))))) +(define-syntax define-as-needed + (syntax-rules () + "Define VARIABLE. If VARIABLE already exists in (guile) then re-export it, + otherwise export the newly-defined VARIABLE." + ((_ (proc args ...) body ...) + (define-as-needed proc (lambda* (args ...) body ...))) + ((_ variable value) + (begin + (when (module-defined? the-scm-module 'variable) + (re-export variable)) + + (define variable + (if (module-defined? the-scm-module 'variable) + (module-ref the-scm-module 'variable) + value)) + + (unless (module-defined? the-scm-module 'variable) + (export variable)))))) + ;;; ;;; File systems. @@ -461,48 +484,50 @@ the returned procedure is called." (define MNT_EXPIRE 4) (define UMOUNT_NOFOLLOW 8) -(define mount +(define-as-needed (mount source target type + #:optional (flags 0) options + #:key (update-mtab? #f)) + "Mount device SOURCE on TARGET as a file system TYPE. +Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h> +constants, and OPTIONS may be a string. When FLAGS contains +MS_REMOUNT, SOURCE and TYPE are ignored. When UPDATE-MTAB? is true, +update /etc/mtab. Raise a 'system-error' exception on error." + ;; XXX: '#:update-mtab?' is not implemented by core 'mount'. (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *)))) - (lambda* (source target type #:optional (flags 0) options - #:key (update-mtab? #f)) - "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS -may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a -string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When -UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on -error." - (let-values (((ret err) - (proc (if source - (string->pointer source) - %null-pointer) - (string->pointer target) - (if type - (string->pointer type) - %null-pointer) - flags - (if options - (string->pointer options) - %null-pointer)))) - (unless (zero? ret) - (throw 'system-error "mount" "mount ~S on ~S: ~A" - (list source target (strerror err)) - (list err))) - (when update-mtab? - (augment-mtab source target type options)))))) - -(define umount - (let ((proc (syscall->procedure int "umount2" `(* ,int)))) - (lambda* (target #:optional (flags 0) - #:key (update-mtab? #f)) - "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* + (let-values (((ret err) + (proc (if source + (string->pointer source) + %null-pointer) + (string->pointer target) + (if type + (string->pointer type) + %null-pointer) + flags + (if options + (string->pointer options) + %null-pointer)))) + (unless (zero? ret) + (throw 'system-error "mount" "mount ~S on ~S: ~A" + (list source target (strerror err)) + (list err))) + (when update-mtab? + (augment-mtab source target type options))))) + +(define-as-needed (umount target + #:optional (flags 0) + #:key (update-mtab? #f)) + "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* constants from <sys/mount.h>." - (let-values (((ret err) - (proc (string->pointer target) flags))) - (unless (zero? ret) - (throw 'system-error "umount" "~S: ~A" - (list target (strerror err)) - (list err))) - (when update-mtab? - (remove-from-mtab target)))))) + ;; XXX: '#:update-mtab?' is not implemented by core 'umount'. + (let ((proc (syscall->procedure int "umount2" `(* ,int)))) + (let-values (((ret err) + (proc (string->pointer target) flags))) + (unless (zero? ret) + (throw 'system-error "umount" "~S: ~A" + (list target (strerror err)) + (list err))) + (when update-mtab? + (remove-from-mtab target))))) (define (mount-points) "Return the mounts points for currently mounted file systems." @@ -537,6 +562,34 @@ constants from <sys/mount.h>." (list device (strerror err)) (list err))))))) +(define-as-needed RB_AUTOBOOT #x01234567) +(define-as-needed RB_HALT_SYSTEM #xcdef0123) +(define-as-needed RB_ENABLED_CAD #x89abcdef) +(define-as-needed RB_DISABLE_CAD 0) +(define-as-needed RB_POWER_OFF #x4321fedc) +(define-as-needed RB_SW_SUSPEND #xd000fce2) +(define-as-needed RB_KEXEC #x45584543) + +(define-as-needed (reboot #:optional (cmd RB_AUTOBOOT)) + (let ((proc (syscall->procedure int "reboot" (list int)))) + (let-values (((ret err) (proc cmd))) + (unless (zero? ret) + (throw 'system-error "reboot" "~S: ~A" + (list cmd (strerror err)) + (list err)))))) + +(define-as-needed (load-linux-module data #:optional (options "")) + (let ((proc (syscall->procedure int "init_module" + (list '* unsigned-long '*)))) + (let-values (((ret err) + (proc (bytevector->pointer data) + (bytevector-length data) + (string->pointer options)))) + (unless (zero? ret) + (throw 'system-error "load-linux-module" "~A" + (list (strerror err)) + (list err)))))) + (define (kernel? pid) "Return #t if PID designates a \"kernel thread\" rather than a normal user-land process." @@ -873,9 +926,9 @@ exception if it's already taken." ;; Flags and constants from <net/if.h>. -(define IFF_UP #x1) ;Interface is up -(define IFF_BROADCAST #x2) ;Broadcast address valid. -(define IFF_LOOPBACK #x8) ;Is a loopback net. +(define-as-needed IFF_UP #x1) ;Interface is up +(define-as-needed IFF_BROADCAST #x2) ;Broadcast address valid. +(define-as-needed IFF_LOOPBACK #x8) ;Is a loopback net. (define IF_NAMESIZE 16) ;maximum interface name size @@ -1022,7 +1075,7 @@ that are not up." (else (loop interfaces)))))))) -(define (network-interface-flags socket name) +(define-as-needed (network-interface-flags socket name) "Return a number that is the bit-wise or of 'IFF*' flags for network interface NAME." (let ((req (make-bytevector ifreq-struct-size))) @@ -1033,8 +1086,8 @@ interface NAME." (bytevector->pointer req)))) (if (zero? ret) - ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of - ;; 'struct ifreq', and it's a short int. + ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the + ;; beginning of 'struct ifreq', and it's a short int. (bytevector-sint-ref req IF_NAMESIZE (native-endianness) (sizeof short)) @@ -1050,7 +1103,7 @@ interface NAME." (close-port sock) (not (zero? (logand flags IFF_LOOPBACK))))) -(define (set-network-interface-flags socket name flags) +(define-as-needed (set-network-interface-flags socket name flags) "Set the flag of network interface NAME to FLAGS." (let ((req (make-bytevector ifreq-struct-size))) (bytevector-copy! (string->utf8 name) 0 req 0 @@ -1067,7 +1120,7 @@ interface NAME." (list name (strerror err)) (list err)))))) -(define (set-network-interface-address socket name sockaddr) +(define-as-needed (set-network-interface-address socket name sockaddr) "Set the address of network interface NAME to SOCKADDR." (let ((req (make-bytevector ifreq-struct-size))) (bytevector-copy! (string->utf8 name) 0 req 0 diff --git a/guix/build/union.scm b/guix/build/union.scm index a2ea72e1f5..18167fa3e3 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -47,31 +47,34 @@ (loop (cons file files))))))) (define (file-is-directory? file) - (eq? 'directory (stat:type (stat file)))) + (match (stat file #f) + (#f #f) ;maybe a dangling symlink + (st (eq? 'directory (stat:type st))))) (define (file=? file1 file2) "Return #t if FILE1 and FILE2 are regular files and their contents are identical, #f otherwise." - (let ((st1 (stat file1)) - (st2 (stat file2))) + (let ((st1 (stat file1 #f)) + (st2 (stat file2 #f))) ;; When deduplication is enabled, identical files share the same inode. - (or (= (stat:ino st1) (stat:ino st2)) - (and (eq? (stat:type st1) 'regular) - (eq? (stat:type st2) 'regular) - (= (stat:size st1) (stat:size st2)) - (call-with-input-file file1 - (lambda (port1) - (call-with-input-file file2 - (lambda (port2) - (define len 8192) - (define buf1 (make-bytevector len)) - (define buf2 (make-bytevector len)) - (let loop () - (let ((n1 (get-bytevector-n! port1 buf1 0 len)) - (n2 (get-bytevector-n! port2 buf2 0 len))) - (and (equal? n1 n2) - (or (eof-object? n1) - (loop))))))))))))) + (and st1 st2 + (or (= (stat:ino st1) (stat:ino st2)) + (and (eq? (stat:type st1) 'regular) + (eq? (stat:type st2) 'regular) + (= (stat:size st1) (stat:size st2)) + (call-with-input-file file1 + (lambda (port1) + (call-with-input-file file2 + (lambda (port2) + (define len 8192) + (define buf1 (make-bytevector len)) + (define buf2 (make-bytevector len)) + (let loop () + (let ((n1 (get-bytevector-n! port1 buf1 0 len)) + (n2 (get-bytevector-n! port2 buf2 0 len))) + (and (equal? n1 n2) + (or (eof-object? n1) + (loop)))))))))))))) (define* (union-build output inputs #:key (log-port (current-error-port)) diff --git a/guix/cache.scm b/guix/cache.scm new file mode 100644 index 0000000000..1dc0083f1d --- /dev/null +++ b/guix/cache.scm @@ -0,0 +1,113 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix cache) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (obsolete? + delete-file* + file-expiration-time + remove-expired-cache-entries + maybe-remove-expired-cache-entries)) + +;;; Commentary: +;;; +;;; This module provides tools to manage a simple on-disk cache consisting of +;;; individual files. +;;; +;;; Code: + +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + +(define (obsolete? date now ttl) + "Return #t if DATE is obsolete compared to NOW + TTL seconds." + (time>? (subtract-duration now (make-time time-duration 0 ttl)) + (make-time time-monotonic 0 date))) + +(define (delete-file* file) + "Like 'delete-file', but does not raise an error when FILE does not exist." + (catch 'system-error + (lambda () + (delete-file file)) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args))))) + +(define (file-expiration-time ttl) + "Return a procedure that, when passed a file, returns its \"expiration +time\" computed as its last-access time + TTL seconds." + (lambda (file) + (match (stat file #f) + (#f 0) ;FILE may have been deleted in the meantime + (st (+ (stat:atime st) ttl))))) + +(define* (remove-expired-cache-entries entries + #:key + (now (current-time time-monotonic)) + (entry-expiration + (file-expiration-time 3600)) + (delete-entry delete-file*)) + "Given ENTRIES, a list of file names, remove those whose expiration time, +as returned by ENTRY-EXPIRATION, has passed. Use DELETE-ENTRY to delete +them." + (for-each (lambda (entry) + (when (<= (entry-expiration entry) (time-second now)) + (delete-entry entry))) + entries)) + +(define* (maybe-remove-expired-cache-entries cache + cache-entries + #:key + (entry-expiration + (file-expiration-time 3600)) + (delete-entry delete-file*) + (cleanup-period (* 24 3600))) + "Remove expired narinfo entries from the cache if deemed necessary. Call +CACHE-ENTRIES with CACHE to retrieve the list of cache entries. + +ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the +expiration time of that entry in seconds since the Epoch. DELETE-ENTRY is a +procedure that removes the entry passed as an argument. Finally, +CLEANUP-PERIOD denotes the minimum time between two cache cleanups." + (define now + (current-time time-monotonic)) + + (define expiry-file + (string-append cache "/last-expiry-cleanup")) + + (define last-expiry-date + (catch 'system-error + (lambda () + (call-with-input-file expiry-file read)) + (const 0))) + + (when (obsolete? last-expiry-date now cleanup-period) + (remove-expired-cache-entries (cache-entries cache) + #:now now + #:entry-expiration entry-expiration + #:delete-entry delete-entry) + (call-with-output-file expiry-file + (cute write (time-second now) <>)))) + +;;; cache.scm ends here diff --git a/guix/derivations.scm b/guix/derivations.scm index 0846d54fa5..9aaab05ecb 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -76,7 +76,6 @@ derivation-name derivation-output-names fixed-output-derivation? - fixed-output-path offloadable-derivation? substitutable-derivation? substitution-oracle @@ -566,12 +565,14 @@ that form." (write-list env-vars write-env-var port) (display ")" port)))) -(define derivation->string +(define derivation->bytevector (mlambda (drv) - "Return the external representation of DRV as a string." + "Return the external representation of DRV as a UTF-8-encoded string." (with-fluids ((%default-port-encoding "UTF-8")) - (call-with-output-string - (cut write-derivation drv <>))))) + (call-with-values open-bytevector-output-port + (lambda (port get-bytevector) + (write-derivation drv port) + (get-bytevector)))))) (define* (derivation->output-path drv #:optional (output "out")) "Return the store path of its output OUTPUT. Raise a @@ -612,20 +613,6 @@ list of name/path pairs of its outputs." ;;; Derivation primitive. ;;; -(define (compressed-hash bv size) ; `compressHash' - "Given the hash stored in BV, return a compressed version thereof that fits -in SIZE bytes." - (define new (make-bytevector size 0)) - (define old-size (bytevector-length bv)) - (let loop ((i 0)) - (if (= i old-size) - new - (let* ((j (modulo i size)) - (o (bytevector-u8-ref new j))) - (bytevector-u8-set! new j - (logxor o (bytevector-u8-ref bv i))) - (loop (+ 1 i)))))) - (define derivation-path->base16-hash (mlambda (file) "Return a string containing the base16 representation of the hash of the @@ -670,45 +657,7 @@ derivation at FILE." ;; XXX: At this point this remains faster than `port-sha256', because ;; the SHA256 port's `write' method gets called for every single ;; character. - (sha256 - (string->utf8 (derivation->string drv)))))))) - -(define (store-path type hash name) ; makeStorePath - "Return the store path for NAME/HASH/TYPE." - (let* ((s (string-append type ":sha256:" - (bytevector->base16-string hash) ":" - (%store-prefix) ":" name)) - (h (sha256 (string->utf8 s))) - (c (compressed-hash h 20))) - (string-append (%store-prefix) "/" - (bytevector->nix-base32-string c) "-" - name))) - -(define (output-path output hash name) ; makeOutputPath - "Return an output path for OUTPUT (the name of the output as a string) of -the derivation called NAME with hash HASH." - (store-path (string-append "output:" output) hash - (if (string=? output "out") - name - (string-append name "-" output)))) - -(define* (fixed-output-path name hash - #:key - (output "out") - (hash-algo 'sha256) - (recursive? #t)) - "Return an output path for the fixed output OUTPUT defined by HASH of type -HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for -'add-to-store'." - (if (and recursive? (eq? hash-algo 'sha256)) - (store-path "source" hash name) - (let ((tag (string-append "fixed:" output ":" - (if recursive? "r:" "") - (symbol->string hash-algo) ":" - (bytevector->base16-string hash) ":"))) - (store-path (string-append "output:" output) - (sha256 (string->utf8 tag)) - name)))) + (sha256 (derivation->bytevector drv))))))) (define* (derivation store name builder args #:key @@ -872,8 +821,8 @@ output should not be used." system builder args env-vars #f)) (drv (add-output-paths drv-masked))) - (let* ((file (add-text-to-store store (string-append name ".drv") - (derivation->string drv) + (let* ((file (add-data-to-store store (string-append name ".drv") + (derivation->bytevector drv) (map derivation-input-path inputs))) (drv* (set-field drv (derivation-file-name) file))) (hash-set! %derivation-cache file drv*) @@ -1245,15 +1194,15 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." (with-fluids ((%default-port-encoding "UTF-8")) (call-with-output-string - (lambda (port) - (write prologue port) - (write - `(exit - ,(match exp - ((_ ...) - (remove module-form? exp)) - (_ `(,exp)))) - port)))) + (lambda (port) + (write prologue port) + (write + `(exit + ,(match exp + ((_ ...) + (remove module-form? exp)) + (_ `(,exp)))) + port)))) ;; The references don't really matter ;; since the builder is always used in diff --git a/guix/discovery.scm b/guix/discovery.scm new file mode 100644 index 0000000000..319ba7c872 --- /dev/null +++ b/guix/discovery.scm @@ -0,0 +1,131 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix discovery) + #:use-module (guix ui) + #:use-module (guix combinators) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (ice-9 ftw) + #:export (scheme-modules + fold-modules + all-modules + fold-module-public-variables)) + +;;; Commentary: +;;; +;;; This module provides tools to discover Guile modules and the variables +;;; they export. +;;; +;;; Code: + +(define* (scheme-files directory) + "Return the list of Scheme files found under DIRECTORY, recursively. The +returned list is sorted in alphabetical order." + + ;; Sort entries so that 'fold-packages' works in a deterministic fashion + ;; regardless of details of the underlying file system. + (sort (file-system-fold (const #t) ;enter? + (lambda (path stat result) ;leaf + (if (string-suffix? ".scm" path) + (cons path result) + result)) + (lambda (path stat result) ;down + result) + (lambda (path stat result) ;up + result) + (const #f) ;skip + (lambda (path stat errno result) + (unless (= ENOENT errno) + (warning (G_ "cannot access `~a': ~a~%") + path (strerror errno))) + result) + '() + directory + stat) + string<?)) + +(define file-name->module-name + (let ((not-slash (char-set-complement (char-set #\/)))) + (lambda (file) + "Return the module name (a list of symbols) corresponding to FILE." + (map string->symbol + (string-tokenize (string-drop-right file 4) not-slash))))) + +(define* (scheme-modules directory #:optional sub-directory) + "Return the list of Scheme modules available under DIRECTORY. +Optionally, narrow the search to SUB-DIRECTORY." + (define prefix-len + (string-length directory)) + + (filter-map (lambda (file) + (let* ((file (substring file prefix-len)) + (module (file-name->module-name file))) + (catch #t + (lambda () + (resolve-interface module)) + (lambda args + ;; Report the error, but keep going. + (warn-about-load-error module args) + #f)))) + (scheme-files (if sub-directory + (string-append directory "/" sub-directory) + directory)))) + +(define (fold-modules proc init path) + "Fold over all the Scheme modules present in PATH, a list of directories. +Call (PROC MODULE RESULT) for each module that is found." + (fold (lambda (spec result) + (match spec + ((? string? directory) + (fold proc result (scheme-modules directory))) + ((directory . sub-directory) + (fold proc result + (scheme-modules directory sub-directory))))) + '() + path)) + +(define (all-modules path) + "Return the list of package modules found in PATH, a list of directories to +search. Entries in PATH can be directory names (strings) or (DIRECTORY +. SUB-DIRECTORY) pairs, in which case modules are searched for beneath +SUB-DIRECTORY." + (fold-modules cons '() path)) + +(define (fold-module-public-variables proc init modules) + "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES, +using INIT as the initial value of RESULT. It is guaranteed to never traverse +the same object twice." + (identity ; discard second return value + (fold2 (lambda (module result seen) + (fold2 (lambda (var result seen) + (if (not (vhash-assq var seen)) + (values (proc var result) + (vhash-consq var #t seen)) + (values result seen))) + result + seen + (module-map (lambda (sym var) + (false-if-exception (variable-ref var))) + module))) + init + vlist-null + modules))) + +;;; discovery.scm ends here diff --git a/guix/download.scm b/guix/download.scm index 3f9263d757..bed1f502cf 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -66,7 +66,7 @@ "ftp://gcc.gnu.org/pub/gcc/" ,@(map (cut string-append <> "/gcc") gnu-mirrors)) (gnupg - "ftp://gd.tuwien.ac.at/privacy/gnupg/" + "http://gd.tuwien.ac.at/privacy/gnupg/" "ftp://mirrors.dotsrc.org/gcrypt/" "ftp://mirror.cict.fr/gnupg/" "http://artfiles.org/gnupg.org" @@ -124,6 +124,11 @@ "http://tenet.dl.sourceforge.net/project/" "http://vorboss.dl.sourceforge.net/project/" "http://netassist.dl.sourceforge.net/project/") + (netfilter.org ; https://www.netfilter.org/mirrors.html + "http://ftp.netfilter.org/pub/" + "ftp://ftp.es.netfilter.org/mirrors/netfilter/" + "ftp://ftp.hu.netfilter.org/" + "ftp://www.lt.netfilter.org/pub/") (kernel.org "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/" "http://linux-kernel.uio.no/pub/" @@ -208,7 +213,6 @@ ;; mirrors keeping old versions at the top level "ftp://sunsite.icm.edu.pl/packages/ImageMagick/" ;; mirrors moving old versions to "legacy" - "http://mirrors-au.go-parts.com/mirrors/ImageMagick/" "ftp://mirror.aarnet.edu.au/pub/imagemagick/" "http://mirror.checkdomain.de/imagemagick/" "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/" @@ -217,9 +221,7 @@ "http://ftp.surfnet.nl/pub/ImageMagick/" "http://mirror.searchdaimon.com/ImageMagick" "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/" - "http://mirrors-ru.go-parts.com/mirrors/ImageMagick/" "http://mirror.is.co.za/pub/imagemagick/" - "http://mirrors-uk.go-parts.com/mirrors/ImageMagick/" "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/" "ftp://ftp.fifi.org/pub/ImageMagick/" "http://www.imagemagick.org/download/" diff --git a/guix/gexp.scm b/guix/gexp.scm index 1b8e43e994..d9c4cb461e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -26,6 +26,8 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (gexp gexp? @@ -84,7 +86,13 @@ gexp-compiler? lower-object - lower-inputs)) + lower-inputs + + &gexp-error + gexp-error? + &gexp-input-error + gexp-input-error? + gexp-error-invalid-input)) ;;; Commentary: ;;; @@ -140,6 +148,14 @@ (lower gexp-compiler-lower) (expand gexp-compiler-expand)) ;#f | DRV -> sexp +(define-condition-type &gexp-error &error + gexp-error?) + +(define-condition-type &gexp-input-error &gexp-error + gexp-input-error? + (input gexp-error-invalid-input)) + + (define %gexp-compilers ;; 'eq?' mapping of record type descriptor to <gexp-compiler>. (make-hash-table 20)) @@ -177,8 +193,11 @@ procedure to expand it; otherwise return #f." corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. OBJ must be an object that has an associated gexp compiler, such as a <package>." - (let ((lower (lookup-compiler obj))) - (lower obj system target))) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + (lower obj system target)))) (define-syntax define-gexp-compiler (syntax-rules (=> compiler expander) @@ -440,21 +459,24 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! <gexp-output> write-gexp-output) (define (gexp-modules gexp) - "Return the list of Guile module names GEXP relies on." - (delete-duplicates - (append (gexp-self-modules gexp) - (append-map (match-lambda - (($ <gexp-input> (? gexp? exp)) - (gexp-modules exp)) - (($ <gexp-input> (lst ...)) - (append-map (lambda (item) - (if (gexp? item) - (gexp-modules item) - '())) - lst)) - (_ - '())) - (gexp-references gexp))))) + "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is +false, meaning that GEXP is a plain Scheme object, return the empty list." + (if (gexp? gexp) + (delete-duplicates + (append (gexp-self-modules gexp) + (append-map (match-lambda + (($ <gexp-input> (? gexp? exp)) + (gexp-modules exp)) + (($ <gexp-input> (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp)))) + '())) ;plain Scheme data type (define* (lower-inputs inputs #:key system target) diff --git a/guix/git-download.scm b/guix/git-download.scm index 5d86ab2b62..9f6d20ee38 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -145,6 +145,10 @@ absolute file name and STAT is the result of 'lstat'." (reverse lines)) (line (loop (cons line lines)))))) + (inodes (map (lambda (file) + (let ((stat (lstat file))) + (cons (stat:dev stat) (stat:ino stat)))) + files)) (status (close-pipe pipe))) (and (zero? status) (lambda (file stat) @@ -155,8 +159,10 @@ absolute file name and STAT is the result of 'lstat'." (any (lambda (f) (parent-directory? f file)) files)) ((or 'regular 'symlink) - (any (lambda (f) (string-suffix? f file)) - files)) + ;; Comparing file names is always tricky business so we rely on + ;; inode numbers instead + (member (cons (stat:dev stat) (stat:ino stat)) + inodes)) (_ #f)))))) diff --git a/guix/gnupg.scm b/guix/gnupg.scm index ef8f9000dc..ac0ed5ab2d 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -166,7 +166,7 @@ and 'interactive' (default)." (define (receive?) (let ((answer - (begin (format #t (_ "~a~a~%") + (begin (format #t (G_ "~a~a~%") "Would you like to download this key " "and add it to your keyring?") (read-line)))) diff --git a/guix/graph.scm b/guix/graph.scm index 7af2cd3b80..d7fd5f3e4b 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -229,6 +229,35 @@ nodeArray.push(nodes[\"~a\"]);~%" emit-d3js-prologue emit-d3js-epilogue emit-d3js-node emit-d3js-edge)) + + +;;; +;;; Cypher export. +;;; + +(define (emit-cypher-prologue name port) + (format port "")) + +(define (emit-cypher-epilogue port) + (format port "")) + +(define (emit-cypher-node id label port) + (format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%" + id label )) + +(define (emit-cypher-edge id1 id2 port) + (format port "MERGE (a:Package { id: ~s });~%" id1) + (format port "MERGE (b:Package { id: ~s });~%" id2) + (format port "MATCH (a:Package { id: ~s }), (b:Package { id: ~s }) CREATE UNIQUE (a)-[:NEEDS]->(b);~%" + id1 id2)) + +(define %cypher-backend + (graph-backend "cypher" + "Generate Cypher queries." + emit-cypher-prologue emit-cypher-epilogue + emit-cypher-node emit-cypher-edge)) + + ;;; ;;; Shared. @@ -236,7 +265,8 @@ nodeArray.push(nodes[\"~a\"]);~%" (define %graph-backends (list %graphviz-backend - %d3js-backend)) + %d3js-backend + %cypher-backend)) (define* (export-graph sinks port #:key diff --git a/guix/http-client.scm b/guix/http-client.scm index 6874c51db6..3c5441c38c 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -262,7 +262,7 @@ Raise an '&http-get-error' condition if downloading fails." 302) ; found (redirection) (let ((uri (resolve-uri-reference (response-location resp) uri))) (close-port port) - (format #t (_ "following redirection to `~a'...~%") + (format #t (G_ "following redirection to `~a'...~%") (uri->string uri)) (loop uri))) (else @@ -274,7 +274,7 @@ Raise an '&http-get-error' condition if downloading fails." (message (format #f - (_ "~a: HTTP download failed: ~a (~s)") + (G_ "~a: HTTP download failed: ~a (~s)") (uri->string uri) code (response-reason-phrase resp)))))))))))) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index b19d56ddcf..32c5c310e1 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -288,7 +288,7 @@ META." ;; Warn about inputs that are part of perl's core (unless (null? core-inputs) (for-each (lambda (module) - (warning (_ "input '~a' of ~a is in Perl core~%") + (warning (G_ "input '~a' of ~a is in Perl core~%") module (package-name package))) core-inputs))) (let ((version (cpan-version meta)) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index a5f91fe8d2..8d963a7475 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,7 +45,12 @@ bioconductor->guix-package recursive-import %cran-updater - %bioconductor-updater)) + %bioconductor-updater + + cran-package? + bioconductor-package? + bioconductor-data-package? + bioconductor-experiment-package?)) ;;; Commentary: ;;; @@ -122,19 +128,21 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "http://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.4. Bioconductor packages should be +;; The latest Bioconductor release is 3.5. Bioconductor packages should be ;; updated together. -(define %bioconductor-svn-url - (string-append "https://readonly:readonly@" - "hedgehog.fhcrc.org/bioconductor/branches/RELEASE_3_4/" - "madman/Rpacks/")) - +(define (bioconductor-mirror-url name) + (string-append "https://raw.githubusercontent.com/Bioconductor-mirror/" + name "/release-3.5")) -(define (fetch-description base-url name) +(define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package -NAME, or #f in case of failure. NAME is case-sensitive." +NAME in the given REPOSITORY, or #f in case of failure. NAME is +case-sensitive." ;; This API always returns the latest release of the module. - (let ((url (string-append base-url name "/DESCRIPTION"))) + (let ((url (string-append (case repository + ((cran) (string-append %cran-url name)) + ((bioconductor) (bioconductor-mirror-url name))) + "/DESCRIPTION"))) (guard (c ((http-get-error? c) (format (current-error-port) "error: failed to retrieve package information \ @@ -199,17 +207,16 @@ empty list when the FIELD cannot be found." (check "*.f95") (check "*.f"))) -(define (needs-zlib? tarball) - "Return #T if any of the Makevars files in the src directory of the TARBALL -contain a zlib linker flag." +(define (tarball-files-match-pattern? tarball regexp . file-patterns) + "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL +match the given REGEXP." (call-with-temporary-directory (lambda (dir) - (let ((pattern (make-regexp "-lz"))) + (let ((pattern (make-regexp regexp))) (parameterize ((current-error-port (%make-void-port "rw+"))) - (system* "tar" - "xf" tarball "-C" dir - "--wildcards" - "*/src/Makevars*" "*/src/configure*" "*/configure*")) + (apply system* "tar" + "xf" tarball "-C" dir + `("--wildcards" ,@file-patterns))) (any (lambda (file) (call-with-input-file file (lambda (port) @@ -218,10 +225,23 @@ contain a zlib linker flag." (cond ((eof-object? line) #f) ((regexp-exec pattern line) #t) - (else (loop))))))) - #t) + (else (loop)))))))) (find-files dir)))))) +(define (needs-zlib? tarball) + "Return #T if any of the Makevars files in the src directory of the TARBALL +contain a zlib linker flag." + (tarball-files-match-pattern? + tarball "-lz" + "*/src/Makevars*" "*/src/configure*" "*/configure*")) + +(define (needs-pkg-config? tarball) + "Return #T if any of the Makevars files in the src directory of the TARBALL +reference the pkg-config tool." + (tarball-files-match-pattern? + tarball "pkg-config" + "*/src/Makevars*" "*/src/configure*" "*/configure*")) + (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." @@ -271,11 +291,12 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (build-system r-build-system) ,@(maybe-inputs sysdepends) ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs) - ,@(if (needs-fortran? tarball) - `((native-inputs (,'quasiquote - ,(list "gfortran" - (list 'unquote 'gfortran))))) - '()) + ,@(maybe-inputs + `(,@(if (needs-fortran? tarball) + '("gfortran") '()) + ,@(if (needs-pkg-config? tarball) + '("pkg-config") '())) + 'native-inputs) (home-page ,(if (string-null? home-page) (string-append base-url name) home-page)) @@ -290,11 +311,8 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (lambda* (package-name #:optional (repo 'cran)) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (let* ((url (case repo - ((cran) %cran-url) - ((bioconductor) %bioconductor-svn-url))) - (module-meta (fetch-description url package-name))) - (and=> module-meta (cut description->package repo <>)))))) + (and=> (fetch-description repo package-name) + (cut description->package repo <>))))) (define* (recursive-import package-name #:optional (repo 'cran)) "Generate a stream of package expressions for PACKAGE-NAME and all its @@ -374,7 +392,7 @@ dependencies." (start (string-rindex url #\/))) ;; The URL ends on ;; (string-append "/" name "_" version ".tar.gz") - (substring url (+ start 1) end))) + (and start end (substring url (+ start 1) end)))) (_ #f))) (_ #f))))) @@ -385,7 +403,7 @@ dependencies." (package->upstream-name package)) (define meta - (fetch-description %cran-url upstream-name)) + (fetch-description 'cran upstream-name)) (and meta (let ((version (assoc-ref meta "Version"))) @@ -402,7 +420,7 @@ dependencies." (package->upstream-name package)) (define meta - (fetch-description %bioconductor-svn-url upstream-name)) + (fetch-description 'bioconductor upstream-name)) (and meta (let ((version (assoc-ref meta "Version"))) @@ -415,6 +433,9 @@ dependencies." (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." (and (string-prefix? "r-" (package-name package)) + ;; Check if the upstream name can be extracted from package uri. + (package->upstream-name package) + ;; Check if package uri(s) are prefixed by "mirror://cran". (match (and=> (package-source package) origin-uri) ((? string? uri) (string-prefix? "mirror://cran" uri)) @@ -424,13 +445,48 @@ dependencies." (define (bioconductor-package? package) "Return true if PACKAGE is an R package from Bioconductor." - (and (string-prefix? "r-" (package-name package)) - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (string-prefix? "http://bioconductor.org" uri)) - ((? list? uris) - (any (cut string-prefix? "http://bioconductor.org" <>) uris)) - (_ #f)))) + (let ((predicate (lambda (uri) + (and (string-prefix? "http://bioconductor.org" uri) + ;; Data packages are neither listed in SVN nor on + ;; the Github mirror, so we have to exclude them + ;; from the set of bioconductor packages that can be + ;; updated automatically. + (not (string-contains uri "/data/annotation/")) + ;; Experiment packages are in a separate repository. + (not (string-contains uri "/data/experiment/")))))) + (and (string-prefix? "r-" (package-name package)) + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (predicate uri)) + ((? list? uris) + (any predicate uris)) + (_ #f))))) + +(define (bioconductor-data-package? package) + "Return true if PACKAGE is an R data package from Bioconductor." + (let ((predicate (lambda (uri) + (and (string-prefix? "http://bioconductor.org" uri) + (string-contains uri "/data/annotation/"))))) + (and (string-prefix? "r-" (package-name package)) + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (predicate uri)) + ((? list? uris) + (any predicate uris)) + (_ #f))))) + +(define (bioconductor-experiment-package? package) + "Return true if PACKAGE is an R experiment package from Bioconductor." + (let ((predicate (lambda (uri) + (and (string-prefix? "http://bioconductor.org" uri) + (string-contains uri "/data/experiment/"))))) + (and (string-prefix? "r-" (package-name package)) + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (predicate uri)) + ((? list? uris) + (any predicate uris)) + (_ #f))))) (define %cran-updater (upstream-updater diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index b1003304d0..858eea88e2 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -82,7 +82,7 @@ NAMES (strings)." ;; Use a relatively small TTL for the archive itself. (parameterize ((%http-cache-ttl (* 6 3600))) (call-with-downloaded-file url read)) - (leave (_ "~A: currently not supported~%") repo)))) + (leave (G_ "~A: currently not supported~%") repo)))) (define* (call-with-downloaded-file url proc #:optional (error-thunk #f)) "Fetch URL, store the content in a temporary file and call PROC with that @@ -94,7 +94,7 @@ return its value or leave if it's false." (lambda (key . args) (if error-thunk (error-thunk) - (leave (_ "~A: download failed~%") url))))) + (leave (G_ "~A: download failed~%") url))))) (define (is-elpa-package? name elpa-pkg-spec) "Return true if the string NAME corresponds to the name of the package diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 1e433e3fb3..9c72e73314 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -132,7 +133,7 @@ extracted in the current directory, and will be deleted." (string-drop-right basename 8)) (else (begin - (warning (_ "Unsupported archive format: \ + (warning (G_ "Unsupported archive format: \ cannot determine package dependencies")) #f))))) @@ -215,7 +216,7 @@ cannot determine package dependencies")) (delete-file req-file) (rmdir dirname))) (begin - (warning (_ "'tar xf' failed with exit code ~a\n") + (warning (G_ "'tar xf' failed with exit code ~a\n") exit-code) '()))) '()))) @@ -279,7 +280,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (and package (guard (c ((missing-source-error? c) (let ((package (missing-source-error-package c))) - (leave (_ "no source release for pypi package ~a ~a~%") + (leave (G_ "no source release for pypi package ~a ~a~%") (assoc-ref* package "info" "name") (assoc-ref* package "info" "version"))))) (let ((name (assoc-ref* package "info" "name")) @@ -322,15 +323,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." - (guard (c ((missing-source-error? c) #f)) - (let* ((pypi-name (guix-package->pypi-name package)) - (metadata (pypi-fetch pypi-name)) - (version (assoc-ref* metadata "info" "version")) - (url (assoc-ref (latest-source-release metadata) "url"))) - (upstream-source - (package (package-name package)) - (version version) - (urls (list url)))))) + (let* ((pypi-name (guix-package->pypi-name package)) + (pypi-package (pypi-fetch pypi-name))) + (and pypi-package + (guard (c ((missing-source-error? c) #f)) + (let* ((metadata pypi-package) + (version (assoc-ref* metadata "info" "version")) + (url (assoc-ref (latest-source-release metadata) "url"))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url)))))))) (define %pypi-updater (upstream-updater diff --git a/guix/licenses.scm b/guix/licenses.scm index 7b2ac2d311..8396b1a3c6 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -9,6 +9,8 @@ ;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de> ;;; Copyright © 2016 Rene Saavedra <rennes@openmailbox.org> ;;; Copyright © 2016, 2017 ng0 <ng0@libertad.pw> +;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2017 Petter <petter@mykolab.ch> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,10 +39,11 @@ cc0 cc-by2.0 cc-by3.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0 cddl1.0 - cecill-c + cecill cecill-b cecill-c artistic2.0 clarified-artistic copyleft-next cpl1.0 + edl1.0 epl1.0 expat freetype @@ -61,6 +64,7 @@ ncsa nmap openldap2.8 openssl + perl-license psfl public-domain qpl repoze @@ -75,7 +79,8 @@ zpl2.1 zlib fsf-free - wtfpl2)) + wtfpl2 + fsdg-compatible)) (define-record-type <license> (license name uri comment) @@ -191,7 +196,17 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CDDLv1.0" "https://www.gnu.org/licenses/license-list#CDDL")) -(define cecill-c +(define cecill ;copyleft + (license "CeCILL" + "http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.html" + "https://www.gnu.org/licenses/license-list.html#CeCILL")) + +(define cecill-b ;non-copyleft + (license "CeCILL-B" + "http://www.cecill.info/licences/Licence_CeCILL-B_V1-en.html" + "https://www.gnu.org/licenses/license-list.html#CeCILL")) + +(define cecill-c ;weak copyleft (license "CeCILL-C" "http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html" "https://www.gnu.org/licenses/license-list.html#CeCILL")) @@ -217,6 +232,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CPLv1.0" "https://www.gnu.org/licenses/license-list#CommonPublicLicense10")) +(define edl1.0 + (license "EDL 1.0" + "http://directory.fsf.org/wiki/License:EDLv1.0" + "https://eclipse.org/org/documents/edl-v10.php")) + (define epl1.0 (license "EPL 1.0" "http://directory.fsf.org/wiki/License:EPLv1.0" @@ -395,6 +415,12 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/license-list#newOpenLDAP")) ;; lists OpenLDAPv2.7, which is virtually identical +(define perl-license + ;; The license of Perl, GPLv1+ or Artistic (we ignore the latter here). + ;; We define this alias to avoid circular dependencies introduced by the use + ;; of the '(package-license perl)' idiom. + gpl1+) + (define psfl (license "Python Software Foundation License" "http://docs.python.org/license.html" @@ -488,4 +514,13 @@ of licenses, approved as free by the FSF. More details can be found at URI." uri comment)) +(define* (fsdg-compatible uri #:optional (comment "")) + "Return a license that does not fit any of the ones above or a collection +of licenses, not necessarily free, but in accordance with FSDG as Non-functional +Data. More details can be found at URI. See also +https://www.gnu.org/distros/free-system-distribution-guidelines.en.html#non-functional-data." + (license "FSDG-compatible" + uri + comment)) + ;;; licenses.scm ends here diff --git a/guix/modules.scm b/guix/modules.scm index 8c63f21a97..24b5903579 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -95,11 +95,16 @@ depends on." (('gnu _ ...) #t) (_ #f))) +(define %source-less-modules + ;; These are modules that have no corresponding source files or a source + ;; file different from what you'd expect. + '((system syntax) ;2.0, defined in boot-9 + (ice-9 ports internal) ;2.2, defined in (ice-9 ports) + (system syntax internal))) ;2.2, defined in boot-9 + (define* (source-module-dependencies module #:optional (load-path %load-path)) "Return the modules used by MODULE by looking at its source code." - ;; The (system syntax) module is a special-case because it has no - ;; corresponding source file (as of Guile 2.0.) - (if (equal? module '(system syntax)) + (if (member module %source-less-modules) '() (module-file-dependencies (search-path load-path diff --git a/guix/monads.scm b/guix/monads.scm index 0b0ad239de..6ae616aca9 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +29,8 @@ monad-bind monad-return + template-directory + ;; Syntax. >>= return @@ -92,6 +94,9 @@ ;; The record type, for use at run time. (make-monad b r)) + ;; Instantiate all the templates, specialized for this monad. + (template-directory instantiations name) + (define-syntax name ;; An "inlined record", for use at expansion time. The goal is ;; to allow 'bind' and 'return' to be resolved at expansion @@ -103,6 +108,172 @@ ((_ %return) #'r) (_ #'rtd)))))))))) +;; Expansion- and run-time state of the template directory. This needs to be +;; available at run time (and not just at expansion time) so we can +;; instantiate templates defined in other modules, or use instances defined +;; elsewhere. +(eval-when (load expand eval) + ;; Mapping of syntax objects denoting the template to a pair containing (1) + ;; the syntax object of the parameter over which it is templated, and (2) + ;; the syntax of its body. + (define-once %templates (make-hash-table)) + + (define (register-template! name param body) + (hash-set! %templates name (cons param body))) + + ;; List of template instances, where each entry is a triplet containing the + ;; syntax of the name, the actual parameter for which the template is + ;; specialized, and the syntax object referring to this specialization (the + ;; procedure's identifier.) + (define-once %template-instances '()) + + (define (register-template-instance! name actual instance) + (set! %template-instances + (cons (list name actual instance) %template-instances)))) + +(define-syntax template-directory + (lambda (s) + "This is a \"stateful macro\" to register and lookup templates and +template instances." + (define location + (syntax-source s)) + + (define current-info-port + ;; Port for debugging info. + (const (%make-void-port "w"))) + + (define location-string + (format #f "~a:~a:~a" + (assq-ref location 'filename) + (and=> (assq-ref location 'line) 1+) + (assq-ref location 'column))) + + (define (matching-instance? name actual) + (match-lambda + ((name* instance-param proc) + (and (free-identifier=? name name*) + (or (equal? actual instance-param) + (and (identifier? actual) + (identifier? instance-param) + (free-identifier=? instance-param + actual))) + proc)))) + + (define (instance-identifier name actual) + (define stem + (string-append + " " + (symbol->string (syntax->datum name)) + (if (identifier? actual) + (string-append " " (symbol->string (syntax->datum actual))) + "") + " instance")) + (datum->syntax actual (string->symbol stem))) + + (define (instance-definition name template actual) + (match template + ((formal . body) + (let ((instance (instance-identifier name actual))) + (format (current-info-port) + "~a: info: specializing '~a' for '~a' as '~a'~%" + location-string + (syntax->datum name) (syntax->datum actual) + (syntax->datum instance)) + + (register-template-instance! name actual instance) + + #`(begin + (define #,instance + (let-syntax ((#,formal (identifier-syntax #,actual))) + #,body)) + + ;; Generate code to register the thing at run time. + (register-template-instance! #'#,name #'#,actual + #'#,instance)))))) + + (syntax-case s (register! lookup exists? instantiations) + ((_ register! name param body) + ;; Register NAME as a template on PARAM with the given BODY. + (begin + (register-template! #'name #'param #'body) + + ;; Generate code to register the template at run time. XXX: Because + ;; of this, BODY must not contain ellipses. + #'(register-template! #'name #'param #'body))) + ((_ lookup name actual) + ;; Search for an instance of template NAME for this ACTUAL parameter. + ;; On success, expand to the identifier of the instance; otherwise + ;; expand to #f. + (any (matching-instance? #'name #'actual) %template-instances)) + ((_ exists? name actual) + ;; Likewise, but return a Boolean. + (let ((result (->bool + (any (matching-instance? #'name #'actual) + %template-instances)))) + (unless result + (format (current-warning-port) + "~a: warning: no specialization of template '~a' for '~a'~%" + location-string + (syntax->datum #'name) (syntax->datum #'actual))) + result)) + ((_ instantiations actual) + ;; Expand to the definitions of all the existing templates + ;; specialized for ACTUAL. + #`(begin + #,@(hash-map->list (cut instance-definition <> <> #'actual) + %templates)))))) + +(define-syntax define-template + (lambda (s) + "Define a template, which is a procedure that can be specialized over its +first argument. In our case, the first argument is typically the identifier +of a monad. + +Defining templates for procedures like 'mapm' allows us to make have a +specialized version of those procedures for each monad that we define, such +that calls to: + + (mapm %state-monad proc lst) + +automatically expand to: + + (#{ mapm %state-monad instance}# proc lst) + +Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and +thus it contains inline calls to %state-bind and %state-return. This avoids +repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the +monad, and allows 'bind' and 'return' to be inlined, which in turn allows for +more optimizations." + (syntax-case s () + ((_ (name arg0 args ...) body ...) + (with-syntax ((generic-name (datum->syntax + #'name + (symbol-append '#{ %}# + (syntax->datum #'name) + '-generic))) + (original-name #'name)) + #`(begin + (template-directory register! name arg0 + (lambda (args ...) + body ...)) + (define (generic-name arg0 args ...) + ;; The generic instance of NAME, for when no specialization was + ;; found. + body ...) + + (define-syntax name + (lambda (s) + (syntax-case s () + ((_ arg0* args ...) + ;; Expand to either the specialized instance or the + ;; generic instance of template ORIGINAL-NAME. + #'(if (template-directory exists? original-name arg0*) + ((template-directory lookup original-name arg0*) + args ...) + (generic-name arg0* args ...))) + (_ + #'generic-name)))))))))) + (define-syntax-parameter >>= ;; The name 'bind' is already taken, so we choose this (obscure) symbol. (lambda (s) @@ -185,8 +356,9 @@ form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as (define-syntax mbegin (syntax-rules (%current-monad) - "Bind the given monadic expressions in sequence, returning the result of -the last one." + "Bind MEXP and the following monadic expressions in sequence, returning +the result of the last expression. Every expression in the sequence must be a +monadic expression." ((_ %current-monad mexp) mexp) ((_ %current-monad mexp rest ...) @@ -204,23 +376,27 @@ the last one." (define-syntax mwhen (syntax-rules () - "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'. When -CONDITION is false, return *unspecified* in the current monad." - ((_ condition exp0 exp* ...) + "When CONDITION is true, evaluate the sequence of monadic expressions +MEXP0..MEXP* as in an 'mbegin'. When CONDITION is false, return *unspecified* +in the current monad. Every expression in the sequence must be a monadic +expression." + ((_ condition mexp0 mexp* ...) (if condition (mbegin %current-monad - exp0 exp* ...) + mexp0 mexp* ...) (return *unspecified*))))) (define-syntax munless (syntax-rules () - "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'. When -CONDITION is true, return *unspecified* in the current monad." - ((_ condition exp0 exp* ...) + "When CONDITION is false, evaluate the sequence of monadic expressions +MEXP0..MEXP* as in an 'mbegin'. When CONDITION is true, return *unspecified* +in the current monad. Every expression in the sequence must be a monadic +expression." + ((_ condition mexp0 mexp* ...) (if condition (return *unspecified*) (mbegin %current-monad - exp0 exp* ...))))) + mexp0 mexp* ...))))) (define-syntax define-lift (syntax-rules () @@ -260,7 +436,7 @@ MONAD---i.e., return a monadic function in MONAD." (with-monad monad (return (apply proc args))))) -(define (foldm monad mproc init lst) +(define-template (foldm monad mproc init lst) "Fold MPROC over LST and return a monadic value seeded by INIT. (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) @@ -272,33 +448,33 @@ MONAD---i.e., return a monadic function in MONAD." (match lst (() (return result)) - ((head tail ...) + ((head . tail) (>>= (mproc head result) (lambda (result) (loop tail result)))))))) -(define (mapm monad mproc lst) +(define-template (mapm monad mproc lst) "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) - (>>= (mproc item) - (lambda (item) - (return (cons item result))))) - '() - lst))) - (return (reverse result)))) - -(define-syntax-rule (sequence monad lst) + ;; XXX: We don't use 'foldm' because template specialization wouldn't work + ;; in this context. + (with-monad monad + (let mapm ((lst lst) + (result '())) + (match lst + (() + (return (reverse result))) + ((head . tail) + (>>= (mproc head) + (lambda (head) + (mapm tail (cons head result))))))))) + +(define-template (sequence monad lst) "Turn the list of monadic values LST into a monadic list of values, by evaluating each item of LST in sequence." - ;; XXX: Making it a macro is a bit brutal as it leads to a lot of code - ;; duplication. However, it allows >>= and return to be open-coded, which - ;; avoids struct-ref's to MONAD and a few closure allocations when using - ;; %STATE-MONAD. (with-monad monad (let seq ((lstx lst) (result '())) @@ -310,7 +486,7 @@ evaluating each item of LST in sequence." (lambda (item) (seq tail (cons item result))))))))) -(define (anym monad mproc lst) +(define-template (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: @@ -322,7 +498,7 @@ value for which MPROC returns a true monadic value or #f. For example: (match lst (() (return #f)) - ((head tail ...) + ((head . tail) (>>= (mproc head) (lambda (result) (if result diff --git a/guix/nar.scm b/guix/nar.scm index 739d3d3a57..9b4c608238 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -208,7 +208,7 @@ s-expression")) (hash (get-hash)) (has-sig? (= 1 (read-int port)))) (format log-port - (_ "importing file or directory '~a'...~%") + (G_ "importing file or directory '~a'...~%") file) ;; The signature may contain characters that are meant to be @@ -219,7 +219,7 @@ s-expression")) (begin (assert-valid-signature sig hash file) (format log-port - (_ "found valid signature for '~a'~%") + (G_ "found valid signature for '~a'~%") file) (finalize-store-file temp file #:references refs diff --git a/guix/packages.scm b/guix/packages.scm index 29351ace1d..97580352e2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> +;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,6 @@ #:use-module (guix memoization) #:use-module (guix build-system) #:use-module (guix search-paths) - #:use-module (guix gexp) #:use-module (guix sets) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -99,12 +99,14 @@ package-transitive-propagated-inputs package-transitive-native-search-paths package-transitive-supported-systems + package-mapping package-input-rewriting package-source-derivation package-derivation package-cross-derivation package-output package-grafts + package/inherit transitive-input-references @@ -223,7 +225,7 @@ name of its URI." (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. - '("x86_64-linux" "i686-linux" "armhf-linux" "mips64el-linux")) + '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux")) (define %hurd-systems ;; The GNU/Hurd systems for which support is being developed. @@ -234,7 +236,7 @@ name of its URI." ;; ;; XXX: MIPS is temporarily unavailable on Hydra: ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>. - (delete "mips64el-linux" %supported-systems)) + (fold delete %supported-systems '("aarch64-linux" "mips64el-linux"))) ;; A package. @@ -747,36 +749,63 @@ dependencies are known to build on SYSTEM." "Return the \"target inputs\" of BAG, recursively." (transitive-inputs (bag-target-inputs bag))) -(define* (package-input-rewriting replacements - #:optional (rewrite-name identity)) - "Return a procedure that, when passed a package, replaces its direct and -indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. -REPLACEMENTS is a list of package pairs; the first element of each pair is the -package to replace, and the second one is the replacement. - -Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a -package and returns its new name after rewrite." +(define* (package-mapping proc #:optional (cut? (const #f))) + "Return a procedure that, given a package, applies PROC to all the packages +depended on and returns the resulting package. The procedure stops recursion +when CUT? returns true for a given package." (define (rewrite input) (match input ((label (? package? package) outputs ...) - (match (assq-ref replacements package) - (#f (cons* label (replace package) outputs)) - (new (cons* label new outputs)))) + (let ((proc (if (cut? package) proc replace))) + (cons* label (proc package) outputs))) (_ input))) (define replace (mlambdaq (p) - ;; Return a variant of P with its inputs rewritten. - (package - (inherit p) - (name (rewrite-name (package-name p))) - (inputs (map rewrite (package-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p)))))) + ;; Return a variant of P with PROC applied to P and its explicit + ;; dependencies, recursively. Memoize the transformations. Failing to + ;; do that, we would build a huge object graph with lots of duplicates, + ;; which in turns prevents us from benefiting from memoization in + ;; 'package-derivation'. + (let ((p (proc p))) + (package + (inherit p) + (location (package-location p)) + (inputs (map rewrite (package-inputs p))) + (native-inputs (map rewrite (package-native-inputs p))) + (propagated-inputs (map rewrite (package-propagated-inputs p))))))) replace) +(define* (package-input-rewriting replacements + #:optional (rewrite-name identity)) + "Return a procedure that, when passed a package, replaces its direct and +indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. +REPLACEMENTS is a list of package pairs; the first element of each pair is the +package to replace, and the second one is the replacement. + +Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a +package and returns its new name after rewrite." + (define (rewrite p) + (match (assq-ref replacements p) + (#f (package + (inherit p) + (name (rewrite-name (package-name p))))) + (new new))) + + (package-mapping rewrite (cut assq <> replacements))) + +(define-syntax-rule (package/inherit p overrides ...) + "Like (package (inherit P) OVERRIDES ...), except that the same +transformation is done to the package replacement, if any. P must be a bare +identifier, and will be bound to either P or its replacement when evaluating +OVERRIDES." + (let loop ((p p)) + (package (inherit p) + overrides ... + (replacement (and=> (package-replacement p) loop))))) + ;;; ;;; Package derivations. @@ -851,7 +880,16 @@ information in exceptions." ;; source. (list name (intern file))) (((? string? name) (? struct? source)) - (list name (package-source-derivation store source system))) + ;; 'package-source-derivation' calls 'lower-object', which can throw + ;; '&gexp-input-error'. However '&gexp-input-error' lacks source + ;; location info, so we catch and rethrow here (XXX: not optimal + ;; performance-wise). + (guard (c ((gexp-input-error? c) + (raise (condition + (&package-input-error + (package package) + (input (gexp-error-invalid-input c))))))) + (list name (package-source-derivation store source system)))) (x (raise (condition (&package-input-error (package package) diff --git a/guix/profiles.scm b/guix/profiles.scm index 795c9447fe..6733f105e3 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> +;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -946,10 +947,96 @@ files for the fonts of the @var{manifest} entries." #:local-build? #t #:substitutable? #f)) +(define (manual-database manifest) + "Return a derivation that builds the manual page database (\"mandb\") for +the entries in MANIFEST." + (define man-db ;lazy reference + (module-ref (resolve-interface '(gnu packages man)) 'man-db)) + + (define build + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-26)) + + (define entries + (filter-map (lambda (directory) + (let ((man (string-append directory "/share/man"))) + (and (directory-exists? man) + man))) + '#$(manifest-inputs manifest))) + + (define manpages-collection-dir + (string-append (getenv "PWD") "/manpages-collection")) + + (define man-directory + (string-append #$output "/share/man")) + + (define (get-manpage-tail-path manpage-path) + (let ((index (string-contains manpage-path "/share/man/"))) + (unless index + (error "Manual path doesn't contain \"/share/man/\":" + manpage-path)) + (string-drop manpage-path (+ index (string-length "/share/man/"))))) + + (define (populate-manpages-collection-dir entries) + (let ((manpages (append-map (cut find-files <> #:stat stat) entries))) + (for-each (lambda (manpage) + (let* ((dest-file (string-append + manpages-collection-dir "/" + (get-manpage-tail-path manpage)))) + (mkdir-p (dirname dest-file)) + (catch 'system-error + (lambda () + (symlink manpage dest-file)) + (lambda args + ;; Different packages may contain the same + ;; manpage. Simply ignore the symlink error. + #t)))) + manpages))) + + (mkdir-p manpages-collection-dir) + (populate-manpages-collection-dir entries) + + ;; Create a mandb config file which contains a custom made + ;; manpath. The associated catpath is the location where the database + ;; gets generated. + (copy-file #+(file-append man-db "/etc/man_db.conf") + "man_db.conf") + (substitute* "man_db.conf" + (("MANDB_MAP /usr/man /var/cache/man/fsstnd") + (string-append "MANDB_MAP " manpages-collection-dir " " + man-directory))) + + (mkdir-p man-directory) + (setenv "MANPATH" (string-join entries ":")) + + (format #t "Creating manual page database for ~a packages... " + (length entries)) + (force-output) + (let* ((start-time (current-time)) + (exit-status (system* #+(file-append man-db "/bin/mandb") + "--quiet" "--create" + "-C" "man_db.conf")) + (duration (time-difference (current-time) start-time))) + (format #t "done in ~,3f s~%" + (+ (time-second duration) + (* (time-nanosecond duration) (expt 10 -9)))) + (force-output) + (zero? exit-status)))) + + (gexp->derivation "manual-database" build + #:modules '((guix build utils) + (srfi srfi-19) + (srfi srfi-26)) + #:local-build? #t)) + (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 + manual-database fonts-dir-file ghc-package-cache-file ca-certificate-bundle diff --git a/guix/records.scm b/guix/records.scm index f3f3aafb04..7de5fccef6 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -134,10 +134,9 @@ fields, and DELAYED is the list of identifiers of delayed fields." ((_ (field value) (... ...)) (let ((fields (map syntax->datum #'(field (... ...))))) (define (field-value f) - (or (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - #'((field value) (... ...))) - car) + (or (find (lambda (x) + (eq? f (syntax->datum x))) + #'(field (... ...))) (wrap-field-value f (field-default-value f)))) (let ((fields (append fields (map car default-values)))) diff --git a/guix/scripts.scm b/guix/scripts.scm index bbee50bc3d..9ff7f25548 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; @@ -27,13 +27,16 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (args-fold* parse-command-line maybe-build build-package - build-package-source)) + build-package-source + %distro-age-warning + warn-about-old-distro)) ;;; Commentary: ;;; @@ -50,7 +53,7 @@ reporting." operand-proc seeds)) (lambda (key proc msg args . rest) ;; XXX: MSG is not i18n'd. - (leave (_ "invalid argument: ~a~%") + (leave (G_ "invalid argument: ~a~%") (apply format #f msg args))))) (define (environment-build-options) @@ -76,7 +79,7 @@ parameter of 'args-fold'." ;; Actual parsing takes place here. (apply args-fold* args options (lambda (opt name arg . rest) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) argument-handler seeds)) @@ -136,4 +139,47 @@ Show what and how will/would be built." #:dry-run? dry-run?) (return (show-derivation-outputs derivation)))))) +(define %distro-age-warning + ;; The age (in seconds) above which we warn that the distro is too old. + (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING") + string->duration) + (#f (* 7 24 3600)) + (age (time-second age))))) + +(define* (warn-about-old-distro #:optional (old (%distro-age-warning)) + #:key (suggested-command + "guix package -u")) + "Emit a warning if Guix is older than OLD seconds." + (let-syntax ((false-if-not-found + (syntax-rules () + ((_ exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args)))))))) + (define (seconds->days seconds) + (round (/ seconds (* 3600 24)))) + + (define age + (match (false-if-not-found + (lstat (string-append (config-directory #:ensure? #f) + "/latest"))) + (#f #f) + (stat (- (time-second (current-time time-utc)) + (stat:mtime stat))))) + + (when (and age (>= age old)) + (warning (N_ "Your Guix installation is ~a day old.\n" + "Your Guix installation is ~a days old.\n" + (seconds->days age)) + (seconds->days age))) + (when (or (not age) (>= age old)) + (warning (G_ "Consider running 'guix pull' followed by +'~a' to get up-to-date packages and security updates.\n") + suggested-command) + (newline (guix-warning-port))))) + ;;; scripts.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 8137455a9d..5ea19784dc 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -58,41 +58,41 @@ (verbosity . 0))) (define (show-help) - (display (_ "Usage: guix archive [OPTION]... PACKAGE... + (display (G_ "Usage: guix archive [OPTION]... PACKAGE... Export/import one or more packages from/to the store.\n")) - (display (_ " + (display (G_ " --export export the specified files/packages to stdout")) - (display (_ " + (display (G_ " -r, --recursive combined with '--export', include dependencies")) - (display (_ " + (display (G_ " --import import from the archive passed on stdin")) - (display (_ " + (display (G_ " --missing print the files from stdin that are missing")) - (display (_ " + (display (G_ " -x, --extract=DIR extract the archive on stdin to DIR")) (newline) - (display (_ " + (display (G_ " --generate-key[=PARAMETERS] generate a key pair with the given parameters")) - (display (_ " + (display (G_ " --authorize authorize imports signed by the public key on stdin")) (newline) - (display (_ " + (display (G_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) - (display (_ " + (display (G_ " -S, --source build the packages' source derivations")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) (newline) (show-build-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -140,7 +140,7 @@ Export/import one or more packages from/to the store.\n")) (or arg %key-generation-parameters)))) (alist-cons 'generate-key params result))) (lambda (key proc err) - (leave (_ "invalid key generation parameters: ~a: ~a~%") + (leave (G_ "invalid key generation parameters: ~a: ~a~%") (error-source err) (error-string err)))))) (option '("authorize") #f #f @@ -179,7 +179,7 @@ derivation of a package." (let ((source (package-source p))) (if source (package-source-derivation store source) - (leave (_ "package `~a' has no source~%") + (leave (G_ "package `~a' has no source~%") (package-name p)))) (package-derivation store p system))) ((? procedure? proc) @@ -248,25 +248,25 @@ resulting archive to the standard output port." (build-derivations store drv)) (export-paths store files (current-output-port) #:recursive? (assoc-ref opts 'export-recursive?)) - (leave (_ "unable to export the given packages~%"))))) + (leave (G_ "unable to export the given packages~%"))))) (define (generate-key-pair parameters) "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the right place." (when (or (file-exists? %public-key-file) (file-exists? %private-key-file)) - (leave (_ "key pair exists under '~a'; remove it first~%") + (leave (G_ "key pair exists under '~a'; remove it first~%") (dirname %public-key-file))) (format (current-error-port) - (_ "Please wait while gathering entropy to generate the key pair; + (G_ "Please wait while gathering entropy to generate the key pair; this may take time...~%")) (let* ((pair (catch 'gcry-error (lambda () (generate-key parameters)) (lambda (key proc err) - (leave (_ "key generation failed: ~a: ~a~%") + (leave (G_ "key generation failed: ~a: ~a~%") (error-source err) (error-string err))))) (public (find-sexp-token pair 'public-key)) @@ -293,13 +293,13 @@ the input port." (lambda () (string->canonical-sexp (read-string (current-input-port)))) (lambda (key proc err) - (leave (_ "failed to read public key: ~a: ~a~%") + (leave (G_ "failed to read public key: ~a: ~a~%") (error-source err) (error-string err))))) (let ((key (read-key)) (acl (current-acl))) (unless (eq? 'public-key (canonical-sexp-nth-data key 0)) - (leave (_ "s-expression does not denote a public key~%"))) + (leave (G_ "s-expression does not denote a public key~%"))) ;; Add KEY to the ACL and write that. (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) @@ -345,5 +345,5 @@ the input port." (restore-file (current-input-port) target))) (else (leave - (_ "either '--export' or '--import' \ + (G_ "either '--export' or '--import' \ must be specified~%")))))))))))) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index d9a312f1da..8b19dc871b 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -56,7 +56,7 @@ both the hash and the actual signature." ".pub") read-canonical-sexp) (leave - (_ "cannot find public key for secret key '~a'~%") + (G_ "cannot find public key for secret key '~a'~%") key-file))) (data (read-hash-data port (key-type public-key))) (signature (signature-sexp data secret-key public-key))) @@ -76,11 +76,11 @@ to stdout upon success." (let ((hash (hash-data->bytevector data))) (display (bytevector->base16-string hash)) #t) ; success - (leave (_ "error: invalid signature: ~a~%") + (leave (G_ "error: invalid signature: ~a~%") (canonical-sexp->string signature))) - (leave (_ "error: unauthorized public key: ~a~%") + (leave (G_ "error: unauthorized public key: ~a~%") (canonical-sexp->string subject))) - (leave (_ "error: corrupt signature data: ~a~%") + (leave (G_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) @@ -118,12 +118,12 @@ to stdout upon success." (("rsautl" "-verify" "-inkey" _ "-pubin") (validate-signature (current-input-port))) (("--help") - (display (_ "Usage: guix authenticate OPTION... + (display (G_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to be used internally by 'guix-daemon'.\n"))) (("--version") (show-version-and-exit "guix authenticate")) (else - (leave (_ "wrong arguments")))))) + (leave (G_ "wrong arguments")))))) ;;; authenticate.scm ends here diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 68402fda18..558e8e7719 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -51,7 +51,9 @@ options->transformation show-transformation-options-help - guix-build)) + guix-build + register-root + register-root*)) (define %default-log-urls ;; Default base URLs for build logs. @@ -119,9 +121,12 @@ found. Return #f if no build log was found." 0 paths)))) (lambda args - (leave (_ "failed to create GC root `~a': ~a~%") + (leave (G_ "failed to create GC root `~a': ~a~%") root (strerror (system-error-errno args))))))) +(define register-root* + (store-lift register-root)) + (define (package-with-source store p uri) "Return a package based on P but with its source taken from URI. Extract the new package's version number from URI." @@ -198,7 +203,7 @@ could not be found." (proc (specification->package old) (specification->package new))) (x - (leave (_ "invalid replacement specification: ~s~%") spec)))) + (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) (define (transform-package-inputs replacement-specs) @@ -255,13 +260,13 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (parser 'with-graft))))) (define (show-transformation-options-help) - (display (_ " + (display (G_ " --with-source=SOURCE use SOURCE when building the corresponding package")) - (display (_ " + (display (G_ " --with-input=PACKAGE=REPLACEMENT replace dependency PACKAGE by REPLACEMENT")) - (display (_ " + (display (G_ " --with-graft=PACKAGE=REPLACEMENT graft REPLACEMENT on packages that refer to PACKAGE"))) @@ -286,7 +291,7 @@ derivation, etc.), applies the transformations specified by OPTS." (((name . transform) obj) (let ((new (transform store obj))) (when (eq? new obj) - (warning (_ "transformation '~a' had no effect on ~a~%") + (warning (G_ "transformation '~a' had no effect on ~a~%") name (if (package? obj) (package-full-name obj) @@ -304,37 +309,37 @@ derivation, etc.), applies the transformations specified by OPTS." "Display on the current output port help about the standard command-line options handled by 'set-build-options-from-command-line', and listed in '%standard-build-options'." - (display (_ " + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) - (display (_ " + (display (G_ " -K, --keep-failed keep build tree of failed builds")) - (display (_ " + (display (G_ " -k, --keep-going keep going when some of the derivations fail")) - (display (_ " + (display (G_ " -n, --dry-run do not build the derivations")) - (display (_ " + (display (G_ " --fallback fall back to building when the substituter fails")) - (display (_ " + (display (G_ " --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " + (display (G_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) - (display (_ " + (display (G_ " --no-grafts do not graft packages")) - (display (_ " + (display (G_ " --no-build-hook do not attempt to offload builds via the build hook")) - (display (_ " + (display (G_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) - (display (_ " + (display (G_ " --timeout=SECONDS mark the build as failed after SECONDS of activity")) - (display (_ " + (display (G_ " --verbosity=LEVEL use the given verbosity LEVEL")) - (display (_ " + (display (G_ " --rounds=N build N times in a row to detect non-determinism")) - (display (_ " + (display (G_ " -c, --cores=N allow the use of up to N CPU cores for the build")) - (display (_ " + (display (G_ " -M, --max-jobs=N allow at most N build jobs"))) (define (set-build-options-from-command-line store opts) @@ -440,14 +445,14 @@ options handled by 'set-build-options-from-command-line', and listed in (let ((c (false-if-exception (string->number arg)))) (if c (apply values (alist-cons 'cores c result) rest) - (leave (_ "not a number: '~a' option argument: ~a~%") + (leave (G_ "not a number: '~a' option argument: ~a~%") name arg))))) (option '(#\M "max-jobs") #t #f (lambda (opt name arg result . rest) (let ((c (false-if-exception (string->number arg)))) (if c (apply values (alist-cons 'max-jobs c result) rest) - (leave (_ "not a number: '~a' option argument: ~a~%") + (leave (G_ "not a number: '~a' option argument: ~a~%") name arg))))))) @@ -466,43 +471,43 @@ options handled by 'set-build-options-from-command-line', and listed in (verbosity . 0))) (define (show-help) - (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... + (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) - (display (_ " + (display (G_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) - (display (_ " + (display (G_ " -f, --file=FILE build the package or derivation that the code within FILE evaluates to")) - (display (_ " + (display (G_ " -S, --source build the packages' source derivations")) - (display (_ " + (display (G_ " --sources[=TYPE] build source derivations; TYPE may optionally be one of \"package\", \"all\" (default), or \"transitive\"")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " + (display (G_ " -d, --derivations return the derivation paths of the given packages")) - (display (_ " + (display (G_ " --check rebuild items to check for non-determinism issues")) - (display (_ " + (display (G_ " --repair repair the specified items")) - (display (_ " + (display (G_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) - (display (_ " + (display (G_ " -q, --quiet do not show the build log")) - (display (_ " + (display (G_ " --log-file return the log file names for the given derivations")) (newline) (show-build-options-help) (newline) (show-transformation-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -529,7 +534,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ("transitive" (alist-cons 'source package-transitive-sources result)) (else - (leave (_ "invalid argument: '~a' option argument: ~a, ~ + (leave (G_ "invalid argument: '~a' option argument: ~a, ~ must be one of 'package', 'all', or 'transitive'~%") name arg))))) (option '("check") #f #f @@ -582,7 +587,7 @@ must be one of 'package', 'all', or 'transitive'~%") build---packages, gexps, derivations, and so on." (define (validate-type x) (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) - (leave (_ "~s: not something we can build~%") x))) + (leave (G_ "~s: not something we can build~%") x))) (define (ensure-list x) (let ((lst (match x @@ -636,7 +641,7 @@ build." (match (package-source p) (#f (format (current-error-port) - (_ "~a: warning: \ + (G_ "~a: warning: \ package '~a' has no source~%") (location->string (package-location p)) (package-name p)) @@ -670,7 +675,7 @@ needed." (log-url store file #:base-urls urls)))) (if log (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") file)))) + (leave (G_ "no build log for '~a'~%") file)))) ;;; diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 815bb789c3..681394f9cf 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -188,10 +188,10 @@ object. When VERBOSE?, display matches in addition to mismatches and inconclusive reports." (define (report-hashes item local narinfos) (if local - (report (_ " local hash: ~a~%") (hash->string local)) - (report (_ " no local build for '~a'~%") item)) + (report (G_ " local hash: ~a~%") (hash->string local)) + (report (G_ " no local build for '~a'~%") item)) (for-each (lambda (narinfo) - (report (_ " ~50a: ~a~%") + (report (G_ " ~50a: ~a~%") (uri->string (narinfo-uri narinfo)) (hash->string (narinfo-hash->sha256 (narinfo-hash narinfo))))) @@ -199,15 +199,15 @@ inconclusive reports." (match comparison-report (($ <comparison-report> item 'mismatch local (narinfos ...)) - (report (_ "~a contents differ:~%") item) + (report (G_ "~a contents differ:~%") item) (report-hashes item local narinfos)) (($ <comparison-report> item 'inconclusive #f narinfos) - (warning (_ "could not challenge '~a': no local build~%") item)) + (warning (G_ "could not challenge '~a': no local build~%") item)) (($ <comparison-report> item 'inconclusive locals ()) - (warning (_ "could not challenge '~a': no substitutes~%") item)) + (warning (G_ "could not challenge '~a': no substitutes~%") item)) (($ <comparison-report> item 'match local (narinfos ...)) (when verbose? - (report (_ "~a contents match:~%") item) + (report (G_ "~a contents match:~%") item) (report-hashes item local narinfos))))) @@ -216,17 +216,17 @@ inconclusive reports." ;;; (define (show-help) - (display (_ "Usage: guix challenge [PACKAGE...] + (display (G_ "Usage: guix challenge [PACKAGE...] Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) - (display (_ " + (display (G_ " --substitute-urls=URLS compare build results with those at URLS")) - (display (_ " + (display (G_ " -v, --verbose show details about successful comparisons")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm index cd9f345b68..10aed2be75 100644 --- a/guix/scripts/container.scm +++ b/guix/scripts/container.scm @@ -22,17 +22,17 @@ #:export (guix-container)) (define (show-help) - (display (_ "Usage: guix container ACTION ARGS... + (display (G_ "Usage: guix container ACTION ARGS... Build and manipulate Linux containers.\n")) (newline) - (display (_ "The valid values for ACTION are:\n")) + (display (G_ "The valid values for ACTION are:\n")) (newline) - (display (_ "\ + (display (G_ "\ exec execute a command inside of an existing container\n")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -50,7 +50,7 @@ Build and manipulate Linux containers.\n")) (match args (() (format (current-error-port) - (_ "guix container: missing action~%"))) + (G_ "guix container: missing action~%"))) ((or ("-h") ("--help")) (show-help) (exit 0)) @@ -60,4 +60,4 @@ Build and manipulate Linux containers.\n")) (if (member action %actions) (apply (resolve-action action) args) (format (current-error-port) - (_ "guix container: invalid action~%"))))))) + (G_ "guix container: invalid action~%"))))))) diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index d6d267daff..d598f5cac4 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -37,12 +37,12 @@ (show-version-and-exit "guix container exec"))))) (define (show-help) - (display (_ "Usage: guix container exec PID COMMAND [ARGS...] + (display (G_ "Usage: guix container exec PID COMMAND [ARGS...] Execute COMMMAND within the container process PID.\n")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -66,7 +66,7 @@ and the other containing arguments for the command to be executed." (define (guix-container-exec . args) (define (handle-argument arg result) (if (assoc-ref result 'pid) - (leave (_ "~a: extraneous argument~%") arg) + (leave (G_ "~a: extraneous argument~%") arg) (alist-cons 'pid (string->number* arg) result))) (with-error-handling @@ -84,13 +84,13 @@ and the other containing arguments for the command to be executed." '("TERM")))) (unless pid - (leave (_ "no pid specified~%"))) + (leave (G_ "no pid specified~%"))) (when (null? command) - (leave (_ "no command specified~%"))) + (leave (G_ "no command specified~%"))) (unless (file-exists? (string-append "/proc/" (number->string pid))) - (leave (_ "no such process ~d~%") pid)) + (leave (G_ "no such process ~d~%") pid)) (let ((result (container-excursion pid (lambda () @@ -102,4 +102,4 @@ and the other containing arguments for the command to be executed." environment) (apply execlp program program program-args))))))) (unless (zero? result) - (leave (_ "exec failed with status ~d~%") result))))))) + (leave (G_ "exec failed with status ~d~%") result))))))) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 624ef73e96..45f7cbbad5 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,9 +25,6 @@ #:use-module (guix derivations) #:use-module (guix scripts build) #:use-module ((guix scripts archive) #:select (options->derivations+files)) - #:use-module (ssh session) - #:use-module (ssh auth) - #:use-module (ssh key) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) @@ -40,42 +37,6 @@ ;;; Exchanging store items over SSH. ;;; -(define %compression - "zlib@openssh.com,zlib") - -(define* (open-ssh-session host #:key user port) - "Open an SSH session for HOST and return it. When USER and PORT are #f, use -default values or whatever '~/.ssh/config' specifies; otherwise use them. -Throw an error on failure." - (let ((session (make-session #:user user - #:host host - #:port port - #:timeout 10 ;seconds - ;; #:log-verbosity 'protocol - - ;; We need lightweight compression when - ;; exchanging full archives. - #:compression %compression - #:compression-level 3))) - - ;; Honor ~/.ssh/config. - (session-parse-config! session) - - (match (connect! session) - ('ok - ;; Use public key authentication, via the SSH agent if it's available. - (match (userauth-public-key/auto! session) - ('success - session) - (x - (disconnect! session) - (leave (_ "SSH authentication failed for '~a': ~a~%") - host (get-error session))))) - (x - ;; Connection failed or timeout expired. - (leave (_ "SSH connection to '~a' failed: ~a~%") - host (get-error session)))))) - (define (ssh-spec->user+host+port spec) "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return three values: the user name (or #f), the host name, and the TCP port @@ -95,9 +56,9 @@ number (or #f) corresponding to SPEC." ((? integer? port) (values user host port)) (x - (leave (_ "~a: invalid TCP port number~%") port)))) + (leave (G_ "~a: invalid TCP port number~%") port)))) (x - (leave (_ "~a: invalid SSH specification~%") spec)))) + (leave (G_ "~a: invalid SSH specification~%") spec)))) (define (send-to-remote-host target opts) "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; @@ -148,18 +109,18 @@ package names, build the underlying packages before sending them." ;;; (define (show-help) - (display (_ "Usage: guix copy [OPTION]... ITEMS... + (display (G_ "Usage: guix copy [OPTION]... ITEMS... Copy ITEMS to or from the specified host over SSH.\n")) - (display (_ " + (display (G_ " --to=HOST send ITEMS to HOST")) - (display (_ " + (display (G_ " --from=HOST receive ITEMS from HOST")) (newline) (show-build-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -204,4 +165,4 @@ Copy ITEMS to or from the specified host over SSH.\n")) (target (assoc-ref opts 'destination))) (cond (target (send-to-remote-host target opts)) (source (retrieve-from-remote-host source opts)) - (else (leave (_ "use '--to' or '--from'~%"))))))) + (else (leave (G_ "use '--to' or '--from'~%"))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1ddfd648cd..bb3dc76741 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -64,23 +64,23 @@ (download-proc . ,download-to-store*))) (define (show-help) - (display (_ "Usage: guix download [OPTION] URL + (display (G_ "Usage: guix download [OPTION] URL Download the file at URL to the store or to the given file, and print its file name and the hash of its contents. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) - (format #t (_ " + (format #t (G_ " -f, --format=FMT write the hash in the given format")) - (format #t (_ " + (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) - (format #f (_ " + (format #f (G_ " -o, --output=FILE download to FILE")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -98,7 +98,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (leave (_ "unsupported hash format: ~a~%") arg)))) + (leave (G_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc (alist-delete 'format result)))) @@ -130,10 +130,10 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (when (assq 'argument result) - (leave (_ "~A: extraneous argument~%") arg)) + (leave (G_ "~A: extraneous argument~%") arg)) (alist-cons 'argument arg result)) %default-options)) @@ -141,9 +141,9 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (with-error-handling (let* ((opts (parse-options)) (arg (or (assq-ref opts 'argument) - (leave (_ "no download URI was specified~%")))) + (leave (G_ "no download URI was specified~%")))) (uri (or (string->uri arg) - (leave (_ "~a: failed to parse URI~%") + (leave (G_ "~a: failed to parse URI~%") arg))) (fetch (assq-ref opts 'download-proc)) (path (parameterize ((current-terminal-columns @@ -153,7 +153,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (assq-ref opts 'verify-certificate?)))) (hash (call-with-input-file (or path - (leave (_ "~a: download failed~%") + (leave (G_ "~a: download failed~%") arg)) port-sha256)) (fmt (assq-ref opts 'format))) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 555796a69c..8b2b61d76a 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -38,12 +38,12 @@ (show-version-and-exit "guix edit"))))) (define (show-help) - (display (_ "Usage: guix edit PACKAGE... + (display (G_ "Usage: guix edit PACKAGE... Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -59,7 +59,7 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (let ((absolute-file-name (search-path path file))) (unless absolute-file-name ;; Shouldn't happen unless somebody fiddled with the 'location' field. - (leave (_ "file '~a' not found in search path ~s~%") + (leave (G_ "file '~a' not found in search path ~s~%") file path)) absolute-file-name)) @@ -78,7 +78,7 @@ line." ;; Return the list of package names. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) cons '())) @@ -87,7 +87,7 @@ line." (packages (map specification->package specs))) (for-each (lambda (package) (unless (package-location package) - (leave (_ "source location of package '~a' is unknown~%") + (leave (G_ "source location of package '~a' is unknown~%") (package-full-name package)))) packages) @@ -100,5 +100,5 @@ line." (exit (system (string-join (cons (%editor) file-names)))))) (lambda args (let ((errno (system-error-errno args))) - (leave (_ "failed to launch '~a': ~a~%") + (leave (G_ "failed to launch '~a': ~a~%") (%editor) (strerror errno)))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 44f490043c..af69e2b730 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -72,14 +72,16 @@ as 'HOME' and 'USER' are left untouched." (define (create-environment profile paths pure?) "Set the environment variables specified by PATHS for PROFILE. When PURE? is #t, unset the variables in the current environment. Otherwise, augment -existing enviroment variables with additional search paths." +existing environment variables with additional search paths." (when pure? (purify-environment)) (for-each (match-lambda ((($ <search-path-specification> variable _ separator) . value) (let ((current (getenv variable))) (setenv variable (if (and current (not pure?)) - (string-append value separator current) + (if separator + (string-append value separator current) + value) value))))) (evaluate-profile-search-paths profile paths)) @@ -130,45 +132,45 @@ and an output string." (package->bag package))))) (define (show-help) - (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] + (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] Build an environment that includes the dependencies of PACKAGE and execute COMMAND or an interactive shell in that environment.\n")) - (display (_ " + (display (G_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) - (display (_ " + (display (G_ " -l, --load=FILE create environment for the package that the code within FILE evaluates to")) - (display (_ " + (display (G_ " --ad-hoc include all specified packages in the environment instead of only their inputs")) - (display (_ " + (display (G_ " --pure unset existing environment variables")) - (display (_ " + (display (G_ " --search-paths display needed environment variable definitions")) - (display (_ " + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) - (display (_ " + (display (G_ " -C, --container run command within an isolated container")) - (display (_ " + (display (G_ " -N, --network allow containers to access the network")) - (display (_ " + (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) - (display (_ " + (display (G_ " --expose=SPEC for containers, expose read-only host file system according to SPEC")) - (display (_ " + (display (G_ " --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -499,16 +501,16 @@ Otherwise, return the derivation for the Bash package." "Check if containers can be created and exit with an informative error message if any test fails." (unless (user-namespace-supported?) - (report-error (_ "cannot create container: user namespaces unavailable\n")) - (leave (_ "is your kernel version < 3.10?\n"))) + (report-error (G_ "cannot create container: user namespaces unavailable\n")) + (leave (G_ "is your kernel version < 3.10?\n"))) (unless (unprivileged-user-namespace-supported?) - (report-error (_ "cannot create container: unprivileged user cannot create user namespaces\n")) - (leave (_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) + (report-error (G_ "cannot create container: unprivileged user cannot create user namespaces\n")) + (leave (G_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) (unless (setgroups-supported?) - (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) - (leave (_ "is your kernel version < 3.19?\n")))) + (report-error (G_ "cannot create container: /proc/self/setgroups does not exist\n")) + (leave (G_ "is your kernel version < 3.19?\n")))) (define (register-gc-root target root) "Make ROOT an indirect root to TARGET. This is procedure is idempotent." diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index bdfee4308c..221467a108 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -39,41 +39,41 @@ `((action . collect-garbage))) (define (show-help) - (display (_ "Usage: guix gc [OPTION]... PATHS... + (display (G_ "Usage: guix gc [OPTION]... PATHS... Invoke the garbage collector.\n")) - (display (_ " + (display (G_ " -C, --collect-garbage[=MIN] collect at least MIN bytes of garbage")) - (display (_ " + (display (G_ " -F, --free-space=FREE attempt to reach FREE available space in the store")) - (display (_ " + (display (G_ " -d, --delete attempt to delete PATHS")) - (display (_ " + (display (G_ " --optimize optimize the store by deduplicating identical files")) - (display (_ " + (display (G_ " --list-dead list dead paths")) - (display (_ " + (display (G_ " --list-live list live paths")) (newline) - (display (_ " + (display (G_ " --references list the references of PATHS")) - (display (_ " + (display (G_ " -R, --requisites list the requisites of PATHS")) - (display (_ " + (display (G_ " --referrers list the referrers of PATHS")) (newline) - (display (_ " + (display (G_ " --verify[=OPTS] verify the integrity of the store; OPTS is a comma-separated combination of 'repair' and 'contents'")) - (display (_ " + (display (G_ " --list-failures list cached build failures")) - (display (_ " + (display (G_ " --clear-failures remove PATHS from the set of cached failures")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -97,7 +97,7 @@ Invoke the garbage collector.\n")) (let ((amount (size->number arg))) (if arg (alist-cons 'min-freed amount result) - (leave (_ "invalid amount of storage: ~a~%") + (leave (G_ "invalid amount of storage: ~a~%") arg)))) (#f result))))) (option '(#\F "free-space") #t #f @@ -161,7 +161,7 @@ Invoke the garbage collector.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -188,10 +188,10 @@ Invoke the garbage collector.\n")) (free (* (file-system-block-size fs) (file-system-blocks-available fs)))) (if (> free space) - (info (_ "already ~h bytes available on ~a, nothing to do~%") + (info (G_ "already ~h bytes available on ~a, nothing to do~%") free (%store-prefix)) (let ((to-free (- space free))) - (info (_ "freeing ~h bytes~%") to-free) + (info (G_ "freeing ~h bytes~%") to-free) (collect-garbage store to-free))))) (with-error-handling @@ -203,7 +203,7 @@ Invoke the garbage collector.\n")) opts))) (define (assert-no-extra-arguments) (unless (null? paths) - (leave (_ "extraneous arguments: ~{~a ~}~%") paths))) + (leave (G_ "extraneous arguments: ~{~a ~}~%") paths))) (define (list-relatives relatives) (for-each (compose (lambda (path) @@ -223,10 +223,10 @@ Invoke the garbage collector.\n")) (ensure-free-space store free-space)) (min-freed (let-values (((paths freed) (collect-garbage store min-freed))) - (info (_ "freed ~h bytes~%") freed))) + (info (G_ "freed ~h bytes~%") freed))) (else (let-values (((paths freed) (collect-garbage store))) - (info (_ "freed ~h bytes~%") freed)))))) + (info (G_ "freed ~h bytes~%") freed)))))) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 9804d41929..0af1fa3ad3 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -81,7 +81,7 @@ name." (raise (condition (&message - (message (format #f (_ "~a: invalid argument (package name expected)") + (message (format #f (G_ "~a: invalid argument (package name expected)") x)))))))) (define nodes-from-package @@ -305,7 +305,7 @@ substitutes." ((info) (values (substitutable-references info) store)) (() - (leave (_ "references for '~a' are not known~%") + (leave (G_ "references for '~a' are not known~%") item))))) (values (references store item) store)))) @@ -355,18 +355,18 @@ substitutes." (or (find (lambda (type) (string=? (node-type-name type) name)) %node-types) - (leave (_ "~a: unknown node type~%") name))) + (leave (G_ "~a: unknown node type~%") name))) (define (lookup-backend name) "Return the graph backend called NAME. Raise an error if it is not found." (or (find (lambda (backend) (string=? (graph-backend-name backend) name)) %graph-backends) - (leave (_ "~a: unknown backend~%") name))) + (leave (G_ "~a: unknown backend~%") name))) (define (list-node-types) "Print the available node types along with their synopsis." - (display (_ "The available node types are:\n")) + (display (G_ "The available node types are:\n")) (newline) (for-each (lambda (type) (format #t " - ~a: ~a~%" @@ -376,7 +376,7 @@ substitutes." (define (list-backends) "Print the available backends along with their synopsis." - (display (_ "The available backend types are:\n")) + (display (G_ "The available backend types are:\n")) (newline) (for-each (lambda (backend) (format #t " - ~a: ~a~%" @@ -420,22 +420,22 @@ substitutes." (define (show-help) ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be ;; translated. - (display (_ "Usage: guix graph PACKAGE... + (display (G_ "Usage: guix graph PACKAGE... Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) - (display (_ " + (display (G_ " -b, --backend=TYPE produce a graph with the given backend TYPE")) - (display (_ " + (display (G_ " --list-backends list the available graph backends")) - (display (_ " + (display (G_ " -t, --type=TYPE represent nodes of the given TYPE")) - (display (_ " + (display (G_ " --list-types list the available graph types")) - (display (_ " + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -453,7 +453,7 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (with-error-handling (let* ((opts (args-fold* args %options (lambda (opt name arg . rest) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index a048b53461..1fa6bb8d1f 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -44,21 +44,21 @@ `((format . ,bytevector->nix-base32-string))) (define (show-help) - (display (_ "Usage: guix hash [OPTION] FILE + (display (G_ "Usage: guix hash [OPTION] FILE Return the cryptographic hash of FILE. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) - (format #t (_ " + (format #t (G_ " -x, --exclude-vcs exclude version control directories")) - (format #t (_ " + (format #t (G_ " -f, --format=FMT write the hash in the given format")) - (format #t (_ " + (format #t (G_ " -r, --recursive compute the hash on FILE recursively")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -79,7 +79,7 @@ and 'hexadecimal' can be used as well).\n")) ((or "base16" "hex" "hexadecimal") bytevector->base16-string) (x - (leave (_ "unsupported hash format: ~a~%") + (leave (G_ "unsupported hash format: ~a~%") arg)))) (alist-cons 'format fmt-proc @@ -106,7 +106,7 @@ and 'hexadecimal' can be used as well).\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "unrecognized option: ~a~%") + (leave (G_ "unrecognized option: ~a~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) @@ -152,7 +152,7 @@ and 'hexadecimal' can be used as well).\n")) (lambda () (format #t "~a~%" (fmt (file-hash file)))) (lambda args - (leave (_ "~a~%") + (leave (G_ "~a~%") (strerror (system-error-errno args)))))) (x - (leave (_ "wrong number of arguments~%")))))) + (leave (G_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 8c2f705738..203cda8049 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -83,15 +83,15 @@ rather than \\n." (module-ref module proc))) (define (show-help) - (display (_ "Usage: guix import IMPORTER ARGS ... + (display (G_ "Usage: guix import IMPORTER ARGS ... Run IMPORTER with ARGS.\n")) (newline) - (display (_ "IMPORTER must be one of the importers listed below:\n")) + (display (G_ "IMPORTER must be one of the importers listed below:\n")) (newline) (format #t "~{ ~a~%~}" importers) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -100,7 +100,7 @@ Run IMPORTER with ARGS.\n")) (match args (() (format (current-error-port) - (_ "guix import: missing importer name~%"))) + (G_ "guix import: missing importer name~%"))) ((or ("-h") ("--help")) (show-help) (exit 0)) @@ -120,5 +120,5 @@ Run IMPORTER with ARGS.\n")) (newline)) expressions)) (x - (leave (_ "'~a' import failed~%") importer)))) - (leave (_ "~a: invalid importer~%") importer))))) + (leave (G_ "'~a' import failed~%") importer)))) + (leave (G_ "~a: invalid importer~%") importer))))) diff --git a/guix/scripts/import/cpan.scm b/guix/scripts/import/cpan.scm index 3d470f684d..77ffe1f38e 100644 --- a/guix/scripts/import/cpan.scm +++ b/guix/scripts/import/cpan.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import cpan PACKAGE-NAME + (display (G_ "Usage: guix import cpan PACKAGE-NAME Import and convert the CPAN package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -83,10 +83,10 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (cpan->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index c9a9eab762..d65c644c05 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -40,13 +40,13 @@ '()) (define (show-help) - (display (_ "Usage: guix import cran PACKAGE-NAME + (display (G_ "Usage: guix import cran PACKAGE-NAME Import and convert the CRAN package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -a, --archive=ARCHIVE specify the archive repository")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -79,7 +79,7 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -105,10 +105,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) (unless sexp - (leave (_ "failed to download description for package '~a'~%") + (leave (G_ "failed to download description for package '~a'~%") package-name)) sexp))) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 4337a0b623..cab9a4397b 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -40,11 +40,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import crate PACKAGE-NAME + (display (G_ "Usage: guix import crate PACKAGE-NAME Import and convert the crate.io package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -70,7 +70,7 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -85,10 +85,10 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (crate->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index b22a7c4c23..34eb16485e 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -38,13 +38,13 @@ '((repo . gnu))) (define (show-help) - (display (_ "Usage: guix import elpa PACKAGE-NAME + (display (G_ "Usage: guix import elpa PACKAGE-NAME Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) - (display (_ " + (display (G_ " -a, --archive=ARCHIVE specify the archive repository")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -74,7 +74,7 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -89,11 +89,11 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) ((package-name) (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) (unless sexp - (leave (_ "failed to download package '~a'~%") package-name)) + (leave (G_ "failed to download package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) ;;; elpa.scm ends here diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index a5dd2a7822..349a0a072a 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import gem PACKAGE-NAME + (display (G_ "Usage: guix import gem PACKAGE-NAME Import and convert the RubyGems package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -83,10 +83,10 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (gem->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/gnu.scm b/guix/scripts/import/gnu.scm index 66861f5837..ae98370037 100644 --- a/guix/scripts/import/gnu.scm +++ b/guix/scripts/import/gnu.scm @@ -37,18 +37,18 @@ '((key-download . interactive))) (define (show-help) - (display (_ "Usage: guix import gnu [OPTION...] PACKAGE + (display (G_ "Usage: guix import gnu [OPTION...] PACKAGE Return a package declaration template for PACKAGE, a GNU package.\n")) ;; '--key-download' taken from (guix scripts refresh). - (display (_ " + (display (G_ " --key-download=POLICY handle missing OpenPGP keys according to POLICY: 'always', 'never', and 'interactive', which is also used when 'key-download' is not specified")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -69,7 +69,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) (alist-cons 'key-download (string->symbol arg) result)) (x - (leave (_ "unsupported policy: ~a~%") + (leave (G_ "unsupported policy: ~a~%") arg))))) %standard-import-options)) @@ -83,7 +83,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -100,6 +100,6 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) (gnu->guix-package name #:key-download (assoc-ref opts 'key-download)))) (x - (leave (_ "wrong number of arguments~%")))))) + (leave (G_ "wrong number of arguments~%")))))) ;;; gnu.scm ends here diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index f2c20026b6..969f637846 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -44,23 +44,23 @@ (cabal-environment . ,`(("impl" . ,ghc-default-version))))) (define (show-help) - (display (_ "Usage: guix import hackage PACKAGE-NAME + (display (G_ "Usage: guix import hackage PACKAGE-NAME Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME includes a suffix constituted by a at-sign followed by a numerical version (as used with Guix packages), then a definition for the specified version of the package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available version.\n")) - (display (_ " + (display (G_ " -e ALIST, --cabal-environment=ALIST specify environment for Cabal evaluation")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -s, --stdin read from standard input")) - (display (_ " + (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -101,7 +101,7 @@ version.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -130,18 +130,18 @@ version.\n")) (() (run-importer "stdin" opts (lambda () - (leave (_ "failed to import cabal file \ + (leave (G_ "failed to import cabal file \ from standard input~%"))))) ((many ...) - (leave (_ "too many arguments~%")))) + (leave (G_ "too many arguments~%")))) (match args ((package-name) (run-importer package-name opts (lambda () - (leave (_ "failed to download cabal file \ + (leave (G_ "failed to download cabal file \ for package '~a'~%") package-name)))) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%"))))))) + (leave (G_ "too many arguments~%"))))))) diff --git a/guix/scripts/import/nix.scm b/guix/scripts/import/nix.scm index 05e6e4b85d..45ca7e3fcf 100644 --- a/guix/scripts/import/nix.scm +++ b/guix/scripts/import/nix.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import nix NIXPKGS ATTRIBUTE + (display (G_ "Usage: guix import nix NIXPKGS ATTRIBUTE Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -87,4 +87,4 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (location-file loc) (location-line loc)) expr)) (x - (leave (_ "wrong number of arguments~%")))))) + (leave (G_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 7166b014eb..59a925a3ca 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -38,11 +38,11 @@ '()) (define (show-help) - (display (_ "Usage: guix import pypi PACKAGE-NAME + (display (G_ "Usage: guix import pypi PACKAGE-NAME Import and convert the PyPI package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -68,7 +68,7 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -83,10 +83,10 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) ((package-name) (let ((sexp (pypi->guix-package package-name))) (unless sexp - (leave (_ "failed to download meta-data for package '~a'~%") + (leave (G_ "failed to download meta-data for package '~a'~%") package-name)) sexp)) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm index f91b496d24..e6676e93e8 100644 --- a/guix/scripts/import/stackage.scm +++ b/guix/scripts/import/stackage.scm @@ -40,16 +40,16 @@ (include-test-dependencies? . #t))) (define (show-help) - (display (_ "Usage: guix import stackage PACKAGE-NAME + (display (G_ "Usage: guix import stackage PACKAGE-NAME Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) - (display (_ " + (display (G_ " -r VERSION, --lts-version=VERSION specify the LTS version to use")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -85,7 +85,7 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -105,12 +105,12 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (assoc-ref opts 'include-test-dependencies?) #:lts-version (assoc-ref opts 'lts-version)))) (unless sexp - (leave (_ "failed to download cabal file for package '~a'~%") + (leave (G_ "failed to download cabal file for package '~a'~%") package-name)) sexp))) (() - (leave (_ "too few arguments~%"))) + (leave (G_ "too few arguments~%"))) ((many ...) - (leave (_ "too many arguments~%")))))) + (leave (G_ "too many arguments~%")))))) ;;; stackage.scm ends here diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 811f167067..04ab852999 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -132,11 +132,11 @@ monad." (define (list-checkers-and-exit) ;; Print information about all available checkers and exit. - (format #t (_ "Available checkers:~%")) + (format #t (G_ "Available checkers:~%")) (for-each (lambda (checker) (format #t "- ~a: ~a~%" (lint-checker-name checker) - (_ (lint-checker-description checker)))) + (G_ (lint-checker-description checker)))) %checkers) (exit 0)) @@ -156,7 +156,7 @@ monad." (define (check-not-empty description) (when (string-null? description) (emit-warning package - (_ "description should not be empty") + (G_ "description should not be empty") 'description))) (define (check-texinfo-markup description) @@ -166,7 +166,7 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f." (lambda () (texi->plain-text description)) (lambda (keys . args) (emit-warning package - (_ "Texinfo markup in description is invalid") + (G_ "Texinfo markup in description is invalid") 'description) #f))) @@ -176,7 +176,7 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html." (match (string-index description (char-set #\™ #\®)) ((and (? number?) index) (emit-warning package - (format #f (_ "description should not contain ~ + (format #f (G_ "description should not contain ~ trademark sign '~a' at ~d") (string-ref description index) index) 'description)) @@ -189,14 +189,14 @@ trademark sign '~a' at ~d") ;; TRANSLATORS: '@code' is Texinfo markup and must be kept ;; as is. - (_ "use @code or similar ornament instead of quotes") + (G_ "use @code or similar ornament instead of quotes") 'description))) (define (check-proper-start description) (unless (or (properly-starts-sentence? description) (string-prefix-ci? (package-name package) description)) (emit-warning package - (_ "description should start with an upper-case letter or digit") + (G_ "description should start with an upper-case letter or digit") 'description))) (define (check-end-of-sentence-space description) @@ -212,7 +212,7 @@ trademark sign '~a' at ~d") r (cons (match:start m) r))))))) (unless (null? infractions) (emit-warning package - (format #f (_ "sentences in description should be followed ~ + (format #f (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") (length infractions) infractions) @@ -230,35 +230,33 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (and=> (check-texinfo-markup description) check-proper-start)) (emit-warning package - (format #f (_ "invalid description: ~s") description) + (format #f (G_ "invalid description: ~s") description) 'description)))) -(define (warn-if-package-has-input linted inputs-to-check input-names message) - ;; Emit a warning MESSAGE if some of the inputs named in INPUT-NAMES are - ;; contained in INPUTS-TO-CHECK, which are assumed to be inputs of package - ;; LINTED. +(define (package-input-intersection inputs-to-check input-names) + "Return the intersection between INPUTS-TO-CHECK, the list of input tuples +of a package, and INPUT-NAMES, a list of package specifications such as +\"glib:bin\"." (match inputs-to-check (((labels packages . outputs) ...) - (for-each (lambda (package output) - (when (package? package) - (let ((input (string-append - (package-name package) - (if (> (length output) 0) - (string-append ":" (car output)) - "")))) - (when (member input input-names) - (emit-warning linted - (format #f (_ message) input) - 'inputs-to-check))))) - packages outputs)))) + (filter-map (lambda (package output) + (and (package? package) + (let ((input (string-append + (package-name package) + (if (> (length output) 0) + (string-append ":" (car output)) + "")))) + (and (member input input-names) + input)))) + packages outputs)))) (define (check-inputs-should-be-native package) ;; Emit a warning if some inputs of PACKAGE are likely to belong to its ;; native inputs. - (let ((message "'~a' should probably be a native input") - (inputs (package-inputs package)) + (let ((inputs (package-inputs package)) (input-names - '("pkg-config" + '("pkg-config" + "cmake" "extra-cmake-modules" "glib:bin" "intltool" @@ -274,24 +272,29 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") "python-pytest-cov" "python2-pytest-cov" "python-setuptools-scm" "python2-setuptools-scm" "python-sphinx" "python2-sphinx"))) - (warn-if-package-has-input package inputs input-names message))) + (for-each (lambda (input) + (emit-warning + package + (format #f (G_ "'~a' should probably be a native input") + input) + 'inputs-to-check)) + (package-input-intersection inputs input-names)))) (define (check-inputs-should-not-be-an-input-at-all package) ;; Emit a warning if some inputs of PACKAGE are likely to should not be ;; an input at all. - (let ((message "'~a' should probably not be an input at all") - (inputs (package-inputs package)) - (input-names - '("python-setuptools" - "python2-setuptools" - "python-pip" - "python2-pip"))) - (warn-if-package-has-input package (package-inputs package) - input-names message) - (warn-if-package-has-input package (package-native-inputs package) - input-names message) - (warn-if-package-has-input package (package-propagated-inputs package) - input-names message))) + (let ((input-names '("python-setuptools" + "python2-setuptools" + "python-pip" + "python2-pip"))) + (for-each (lambda (input) + (emit-warning + package + (format #f + (G_ "'~a' should probably not be an input at all") + input))) + (package-input-intersection (package-direct-inputs package) + input-names)))) (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a @@ -305,7 +308,7 @@ line." (define (check-not-empty synopsis) (when (string-null? synopsis) (emit-warning package - (_ "synopsis should not be empty") + (G_ "synopsis should not be empty") 'synopsis))) (define (check-final-period synopsis) @@ -313,7 +316,7 @@ line." (when (and (string-suffix? "." synopsis) (not (string-suffix? "etc." synopsis))) (emit-warning package - (_ "no period allowed at the end of the synopsis") + (G_ "no period allowed at the end of the synopsis") 'synopsis))) (define check-start-article @@ -325,27 +328,27 @@ line." (when (or (string-prefix-ci? "A " synopsis) (string-prefix-ci? "An " synopsis)) (emit-warning package - (_ "no article allowed at the beginning of \ + (G_ "no article allowed at the beginning of \ the synopsis") 'synopsis))))) (define (check-synopsis-length synopsis) (when (>= (string-length synopsis) 80) (emit-warning package - (_ "synopsis should be less than 80 characters long") + (G_ "synopsis should be less than 80 characters long") 'synopsis))) (define (check-proper-start synopsis) (unless (properly-starts-sentence? synopsis) (emit-warning package - (_ "synopsis should start with an upper-case letter or digit") + (G_ "synopsis should start with an upper-case letter or digit") 'synopsis))) (define (check-start-with-package-name synopsis) (when (and (regexp-exec (package-name-regexp package) synopsis) (not (starts-with-abbreviation? synopsis))) (emit-warning package - (_ "synopsis should not start with the package name") + (G_ "synopsis should not start with the package name") 'synopsis))) (define (check-texinfo-markup synopsis) @@ -355,7 +358,7 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." (lambda () (texi->plain-text synopsis)) (lambda (keys . args) (emit-warning package - (_ "Texinfo markup in synopsis is invalid") + (G_ "Texinfo markup in synopsis is invalid") 'synopsis) #f))) @@ -374,7 +377,7 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." (proc synopsis)) checks)) (invalid - (emit-warning package (format #f (_ "invalid synopsis: ~s") invalid) + (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid) 'synopsis)))) (define* (probe-uri uri #:key timeout) @@ -474,7 +477,7 @@ warning for PACKAGE mentionning the FIELD." (begin (emit-warning package (format #f - (_ "URI ~a returned \ + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") (uri->string uri) length)) @@ -483,7 +486,7 @@ suspiciously small file (~a bytes)") (begin (emit-warning package (format #f - (_ "URI ~a not reachable: ~a (~s)") + (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) (response-code argument) (response-reason-phrase argument)) @@ -495,14 +498,14 @@ suspiciously small file (~a bytes)") (('error port command code message) (emit-warning package (format #f - (_ "URI ~a not reachable: ~a (~s)") + (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) code (string-trim-both message))) #f))) ((getaddrinfo-error) (emit-warning package (format #f - (_ "URI ~a domain not found: ~a") + (G_ "URI ~a domain not found: ~a") (uri->string uri) (gai-strerror (car argument))) field) @@ -510,7 +513,7 @@ suspiciously small file (~a bytes)") ((system-error) (emit-warning package (format #f - (_ "URI ~a unreachable: ~a") + (G_ "URI ~a unreachable: ~a") (uri->string uri) (strerror (system-error-errno @@ -519,7 +522,7 @@ suspiciously small file (~a bytes)") #f) ((tls-certificate-error) (emit-warning package - (format #f (_ "TLS certificate error: ~a") + (format #f (G_ "TLS certificate error: ~a") (tls-certificate-error-string argument)))) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. @@ -540,10 +543,10 @@ suspiciously small file (~a bytes)") (unless (or (string-contains (package-name package) "bootstrap") (string=? (package-name package) "ld-wrapper")) (emit-warning package - (_ "invalid value for home page") + (G_ "invalid value for home page") 'home-page))) (else - (emit-warning package (format #f (_ "invalid home page URL: ~s") + (emit-warning package (format #f (G_ "invalid home page URL: ~s") (package-home-page package)) 'home-page))))) @@ -563,7 +566,7 @@ patch could not be found." '())) (emit-warning package - (_ "file names of patches should start with the package name") + (G_ "file names of patches should start with the package name") 'patch-file-names)))) (define (escape-quotes str) @@ -601,7 +604,7 @@ descriptions maintained upstream." (or (not (string? downstream)) (not (string=? upstream downstream)))) (format (guix-warning-port) - (_ "~a: ~a: proposed synopsis: ~s~%") + (G_ "~a: ~a: proposed synopsis: ~s~%") (location->string loc) (package-full-name package) upstream))) @@ -614,7 +617,7 @@ descriptions maintained upstream." (not (string=? (fill-paragraph upstream 100) (fill-paragraph downstream 100))))) (format (guix-warning-port) - (_ "~a: ~a: proposed description:~% \"~a\"~%") + (G_ "~a: ~a: proposed description:~% \"~a\"~%") (location->string loc) (package-full-name package) (fill-paragraph (escape-quotes upstream) 77 7))))))) @@ -656,7 +659,7 @@ descriptions maintained upstream." ;; where *all* the URIs are unreachable. (unless success? (emit-warning package - (_ "all the source URIs are unreachable:") + (G_ "all the source URIs are unreachable:") 'source) (for-each (lambda (warning) (display warning (guix-warning-port))) @@ -665,21 +668,20 @@ descriptions maintained upstream." (define (check-source-file-name package) "Emit a warning if PACKAGE's origin has no meaningful file name." (define (origin-file-name-valid? origin) - ;; Return #t if the source file name contains only a version or is #f; + ;; Return #f if the source file name contains only a version or is #f; ;; indicates that the origin needs a 'file-name' field. (let ((file-name (origin-actual-file-name origin)) (version (package-version package))) (and file-name - (not (or (string-prefix? version file-name) - ;; Common in many projects is for the filename to start - ;; with a "v" followed by the version, - ;; e.g. "v3.2.0.tar.gz". - (string-prefix? (string-append "v" version) file-name)))))) + ;; Common in many projects is for the filename to start + ;; with a "v" followed by the version, + ;; e.g. "v3.2.0.tar.gz". + (not (string-match (string-append "^v?" version) file-name))))) (let ((origin (package-source package))) (unless (or (not origin) (origin-file-name-valid? origin)) (emit-warning package - (_ "the source file name should contain the package name") + (G_ "the source file name should contain the package name") 'source)))) (define (check-mirror-url package) @@ -695,7 +697,7 @@ descriptions maintained upstream." (loop rest)) (prefix (emit-warning package - (format #f (_ "URL should be \ + (format #f (G_ "URL should be \ 'mirror://~a/~a'") mirror-id (string-drop uri (string-length prefix))) @@ -713,11 +715,11 @@ descriptions maintained upstream." (lambda () (guard (c ((nix-protocol-error? c) (emit-warning package - (format #f (_ "failed to create derivation: ~a") + (format #f (G_ "failed to create derivation: ~a") (nix-protocol-error-message c)))) ((message-condition? c) (emit-warning package - (format #f (_ "failed to create derivation: ~a") + (format #f (G_ "failed to create derivation: ~a") (condition-message c))))) (with-store store ;; Disable grafts since it can entail rebuilds. @@ -731,7 +733,7 @@ descriptions maintained upstream." (package-derivation store replacement #:graft? #f)))))) (lambda args (emit-warning package - (format #f (_ "failed to create derivation: ~s~%") + (format #f (G_ "failed to create derivation: ~s~%") args))))) (define (check-license package) @@ -741,7 +743,7 @@ descriptions maintained upstream." ((? license?) ...)) #t) (x - (emit-warning package (_ "invalid license field") + (emit-warning package (G_ "invalid license field") 'license)))) (define (patch-file-name patch) @@ -758,26 +760,26 @@ be determined." or HTTP errors. This allows network-less operation and makes problems with the NIST server non-fatal.." (guard (c ((http-get-error? c) - (warning (_ "failed to retrieve CVE vulnerabilities \ + (warning (G_ "failed to retrieve CVE vulnerabilities \ from ~s: ~a (~s)~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) - (warning (_ "assuming no CVE vulnerabilities~%")) + (warning (G_ "assuming no CVE vulnerabilities~%")) '())) (catch #t (lambda () (current-vulnerabilities)) (match-lambda* (('getaddrinfo-error errcode) - (warning (_ "failed to lookup NIST host: ~a~%") + (warning (G_ "failed to lookup NIST host: ~a~%") (gai-strerror errcode)) - (warning (_ "assuming no CVE vulnerabilities~%")) + (warning (G_ "assuming no CVE vulnerabilities~%")) '()) (('tls-certificate-error args ...) - (warning (_ "TLS certificate error: ~a") + (warning (G_ "TLS certificate error: ~a") (tls-certificate-error-string args)) - (warning (_ "assuming no CVE vulnerabilities~%")) + (warning (G_ "assuming no CVE vulnerabilities~%")) '()) (args (apply throw args)))))) @@ -815,7 +817,7 @@ from ~s: ~a (~s)~%") vulnerabilities))) (unless (null? unpatched) (emit-warning package - (format #f (_ "probably vulnerable to ~a") + (format #f (G_ "probably vulnerable to ~a") (string-join (map vulnerability-id unpatched) ", "))))))))) @@ -830,7 +832,7 @@ from ~s: ~a (~s)~%") (#f #t) (index (emit-warning package - (format #f (_ "tabulation on line ~a, column ~a") + (format #f (G_ "tabulation on line ~a, column ~a") line-number index))))) (define (report-trailing-white-space package line line-number) @@ -839,7 +841,7 @@ from ~s: ~a (~s)~%") (string=? line (string #\page))) (emit-warning package (format #f - (_ "trailing white space on line ~a") + (G_ "trailing white space on line ~a") line-number)))) (define (report-long-line package line line-number) @@ -849,7 +851,7 @@ from ~s: ~a (~s)~%") ;; much noise. (when (> (string-length line) 90) (emit-warning package - (format #f (_ "line ~a is way too long (~a characters)") + (format #f (G_ "line ~a is way too long (~a characters)") line-number (string-length line))))) (define %hanging-paren-rx @@ -860,7 +862,7 @@ from ~s: ~a (~s)~%") (when (regexp-exec %hanging-paren-rx line) (emit-warning package (format #f - (_ "line ~a: parentheses feel lonely, \ + (G_ "line ~a: parentheses feel lonely, \ move to the previous or next line") line-number)))) @@ -999,17 +1001,17 @@ or a list thereof") '()) (define (show-help) - (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... + (display (G_ "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")) - (display (_ " + (display (G_ " -c, --checkers=CHECKER1,CHECKER2... only run the specified checkers")) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -l, --list-checkers display the list of available lint checkers")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -1027,7 +1029,7 @@ run the checkers on all packages.\n")) (unless (memq c (map lint-checker-name %checkers)) - (leave (_ "~a: invalid checker~%") c))) + (leave (G_ "~a: invalid checker~%") c))) names) (alist-cons 'checkers (filter (lambda (checker) @@ -1056,7 +1058,7 @@ run the checkers on all packages.\n")) ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 6a4ae28689..74c0c5484c 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -130,14 +130,14 @@ determined." ;; Silently ignore missing file since this is a common case. (if (= ENOENT err) '() - (leave (_ "failed to open machine file '~a': ~a~%") + (leave (G_ "failed to open machine file '~a': ~a~%") file (strerror err))))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (leave (_ "~a: ~a~%") + (leave (G_ "~a: ~a~%") (location->string loc) message))) (x - (leave (_ "failed to load machine file '~a': ~s~%") + (leave (G_ "failed to load machine file '~a': ~s~%") file args)))))) (define (host-key->type+key host-key) @@ -148,7 +148,7 @@ its key type as a symbol, and the actual base64-encoded string." (string->symbol (string-drop type 4)))) (match (string-tokenize host-key) - ((type key _) + ((type key x) (values (type->symbol type) key)) ((type key) (values (type->symbol type) key)))) @@ -161,7 +161,7 @@ can interpret meaningfully." (private-key-from-file file)) (lambda (key proc str . rest) (raise (condition - (&message (message (format #f (_ "failed to load SSH \ + (&message (message (format #f (G_ "failed to load SSH \ private key from '~a': ~a") file str)))))))) @@ -204,7 +204,7 @@ private key from '~a': ~a") (string=? (public-key->string server) key)) ;; Key mismatch: something's wrong. XXX: It could be that the server ;; provided its Ed25519 key when we where expecting its RSA key. - (leave (_ "server at '~a' returned host key '~a' of type '~a' \ + (leave (G_ "server at '~a' returned host key '~a' of type '~a' \ instead of '~a' of type '~a'~%") (build-machine-name machine) (public-key->string server) (get-key-type server) @@ -213,13 +213,13 @@ instead of '~a' of type '~a'~%") (let ((auth (userauth-public-key! session private))) (unless (eq? 'success auth) (disconnect! session) - (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (leave (G_ "SSH public key authentication failed for '~a': ~a~%") (build-machine-name machine) (get-error session)))) session) (x ;; Connection failed or timeout expired. - (leave (_ "failed to connect to '~a': ~a~%") + (leave (G_ "failed to connect to '~a': ~a~%") (build-machine-name machine) (get-error session)))))) @@ -346,7 +346,7 @@ MACHINE." (guard (c ((nix-protocol-error? c) (format (current-error-port) - (_ "derivation '~a' offloaded to '~a' failed: ~a~%") + (G_ "derivation '~a' offloaded to '~a' failed: ~a~%") (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) @@ -403,7 +403,7 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded (match (string-tokenize line) - ((one five fifteen . _) + ((one five fifteen . x) (let* ((raw (string->number five)) (jobs (build-machine-parallel-builds machine)) (normalized (/ raw jobs))) @@ -411,9 +411,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (normalized: ~s)~%" (build-machine-name machine) raw normalized) normalized)) - (_ + (x +inf.0))))) ;something's fishy about MACHINE, so avoid it - (_ + (x +inf.0))) ;failed to connect to MACHINE, so avoid it (define (machine-lock-file machine hint) @@ -503,7 +503,7 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (() ;; We'll never be able to match REQS. (display "# decline\n")) - ((_ ...) + ((x ...) (let ((machine (choose-build-machine candidates))) (if machine (begin @@ -530,11 +530,11 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." "Bail out if NODE is not running Guile." (match (node-guile-version node) (#f - (leave (_ "Guile could not be started on '~a'~%") + (leave (G_ "Guile could not be started on '~a'~%") name)) ((? string? version) ;; Note: The version string already contains the word "Guile". - (info (_ "'~a' is running ~a~%") + (info (G_ "'~a' is running ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) @@ -546,10 +546,10 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (add-text-to-store store "test" "Hello, build machine!")))) ((? string? str) - (info (_ "Guix is usable on '~a' (test returned ~s)~%") + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") name str)) (x - (leave (_ "failed to use Guix module on '~a' (test returned ~s)~%") + (leave (G_ "failed to use Guix module on '~a' (test returned ~s)~%") name x)))) (define %random-state @@ -570,9 +570,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (send-files local (list item) remote)) (if (valid-path? remote item) - (info (_ "'~a' successfully imported '~a'~%") + (info (G_ "'~a' successfully imported '~a'~%") name item) - (leave (_ "'~a' was not properly imported on '~a'~%") + (leave (G_ "'~a' was not properly imported on '~a'~%") item name)))))) (define (assert-node-can-export node name daemon-socket) @@ -583,9 +583,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (with-store store (if (and (retrieve-files store (list item) remote) (valid-path? store item)) - (info (_ "successfully imported '~a' from '~a'~%") + (info (G_ "successfully imported '~a' from '~a'~%") item name) - (leave (_ "failed to import '~a' from '~a'~%") + (leave (G_ "failed to import '~a' from '~a'~%") item name))))) (define (check-machine-availability machine-file pred) @@ -600,7 +600,7 @@ machine." (let ((machines (filter pred (delete-duplicates (build-machines machine-file) build-machine=?)))) - (info (_ "testing ~a build machines defined in '~a'...~%") + (info (G_ "testing ~a build machines defined in '~a'...~%") (length machines) machine-file) (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) @@ -633,8 +633,8 @@ machine." ;; We rely on protocol-level compression from libssh to optimize large data ;; transfers. Warn if it's missing. (unless (zlib-support?) - (warning (_ "Guile-SSH lacks zlib support")) - (warning (_ "data transfers will *not* be compressed!"))) + (warning (G_ "Guile-SSH lacks zlib support")) + (warning (G_ "data transfers will *not* be compressed!"))) (match args ((system max-silent-time print-build-trace? build-timeout) @@ -659,7 +659,7 @@ machine." #:max-silent-time max-silent-time #:build-timeout build-timeout)))) (else - (leave (_ "invalid request line: ~s~%") line))) + (leave (G_ "invalid request line: ~s~%") line))) (loop (read-line))))))) (("test" rest ...) (with-error-handling @@ -671,20 +671,20 @@ machine." build-machine-name))) ((file) (values file (const #t))) (() (values %machine-file (const #t))) - (_ (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (check-machine-availability (or file %machine-file) pred)))) (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE + (format #t (G_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") %machine-file) - (display (_ " + (display (G_ " This tool is meant to be used internally by 'guix-daemon'.\n")) (show-bug-report-information)) (x - (leave (_ "invalid arguments: ~{~s ~}~%") x)))) + (leave (G_ "invalid arguments: ~{~s ~}~%") x)))) ;;; Local Variables: ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 9e91bc22ac..1273c09f54 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -35,7 +35,7 @@ #:autoload (gnu packages base) (tar) #:autoload (gnu packages package-management) (guix) #:autoload (gnu packages gnupg) (libgcrypt) - #:autoload (gnu packages guile) (guile-json) + #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-37) @@ -71,7 +71,7 @@ found." (($ <compressor> name*) (string=? name* name))) %compressors) - (leave (_ "~a: compressor not found~%") name))) + (leave (G_ "~a: compressor not found~%") name))) (define* (self-contained-tarball name profile #:key target @@ -217,6 +217,13 @@ the image." (define %libgcrypt #+(file-append libgcrypt "/lib/libgcrypt")))))) + (define json + ;; Pick the guile-json package that corresponds to the Guile used to build + ;; derivations. + (if (string-prefix? "2.0" (package-version (default-guile))) + guile2.0-json + guile-json)) + (define build (with-imported-modules `(,@(source-module-closure '((guix docker)) #:select? not-config?) @@ -224,7 +231,7 @@ the image." #~(begin ;; Guile-JSON is required by (guix docker). (add-to-load-path - (string-append #$guile-json "/share/guile/site/" + (string-append #+json "/share/guile/site/" (effective-version))) (use-modules (guix docker) (srfi srfi-19)) @@ -280,6 +287,9 @@ the image." (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -304,7 +314,7 @@ the image." `((,source -> ,target) ,@symlinks) (alist-delete 'symlinks result eq?)))) (x - (leave (_ "~a: invalid symlink specification~%") + (leave (G_ "~a: invalid symlink specification~%") arg))))) (option '("localstatedir") #f #f (lambda (opt name arg result) @@ -314,28 +324,30 @@ the image." %standard-build-options))) (define (show-help) - (display (_ "Usage: guix pack [OPTION]... PACKAGE... + (display (G_ "Usage: guix pack [OPTION]... PACKAGE... Create a bundle of PACKAGE.\n")) (show-build-options-help) (newline) (show-transformation-options-help) (newline) - (display (_ " + (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) - (display (_ " + (display (G_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " + (display (G_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) - (display (_ " + (display (G_ " -S, --symlink=SPEC create symlinks to the profile according to SPEC")) - (display (_ " + (display (G_ " --localstatedir include /var/guix in the resulting pack")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -349,20 +361,22 @@ Create a bundle of PACKAGE.\n")) (define opts (parse-command-line args %options (list %default-options))) + (define maybe-package-argument + ;; Given an option pair, return a package, a package/output tuple, or #f. + (match-lambda + (('argument . spec) + (call-with-values + (lambda () + (specification->package+output spec)) + list)) + (('expression . exp) + (read/eval-package-expression exp)) + (x #f))) + (with-error-handling (parameterize ((%graft? (assoc-ref opts 'graft?))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (specs (filter-map (match-lambda - (('argument . name) - name) - (x #f)) - opts)) - (packages (map (lambda (spec) - (call-with-values - (lambda () - (specification->package+output spec)) - list)) - specs)) + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (packages (filter-map maybe-package-argument opts)) (pack-format (assoc-ref opts 'format)) (name (string-append (symbol->string pack-format) "-pack")) @@ -372,7 +386,7 @@ Create a bundle of PACKAGE.\n")) (build-image (match (assq-ref %formats pack-format) ((? procedure? proc) proc) (#f - (leave (_ "~a: unknown pack format") + (leave (G_ "~a: unknown pack format") format)))) (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6be9d00aec..f050fad976 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -104,7 +104,7 @@ indirectly, or PROFILE." (define (rtfm) (format (current-error-port) - (_ "Try \"info '(guix) Invoking guix package'\" for \ + (G_ "Try \"info '(guix) Invoking guix package'\" for \ more information.~%")) (exit 1)) @@ -126,21 +126,21 @@ more information.~%")) ;; parent directory is root-owned and we're running ;; unprivileged. (format (current-error-port) - (_ "error: while creating directory `~a': ~a~%") + (G_ "error: while creating directory `~a': ~a~%") %profile-directory (strerror (system-error-errno args))) (format (current-error-port) - (_ "Please create the `~a' directory, with you as the owner.~%") + (G_ "Please create the `~a' directory, with you as the owner.~%") %profile-directory) (rtfm)))) ;; Bail out if it's not owned by the user. (unless (or (not s) (= (stat:uid s) (getuid))) (format (current-error-port) - (_ "error: directory `~a' is not owned by you~%") + (G_ "error: directory `~a' is not owned by you~%") %profile-directory) (format (current-error-port) - (_ "Please change the owner of `~a' to user ~s.~%") + (G_ "Please change the owner of `~a' to user ~s.~%") %profile-directory (or (getenv "USER") (getenv "LOGNAME") (getuid))) @@ -175,17 +175,17 @@ denote ranges as interpreted by 'matching-generations'." => (lambda (numbers) (when (memv current numbers) - (warning (_ "not removing generation ~a, which is current~%") + (warning (G_ "not removing generation ~a, which is current~%") current)) ;; Make sure we don't inadvertently remove the current ;; generation. (let ((numbers (delv current numbers))) (when (null-list? numbers) - (leave (_ "no matching generation~%"))) + (leave (G_ "no matching generation~%"))) (delete-generations store profile numbers)))) (else - (leave (_ "invalid syntax: ~a~%") pattern))))) + (leave (G_ "invalid syntax: ~a~%") pattern))))) (define* (build-and-use-profile store profile manifest #:key @@ -211,7 +211,7 @@ specified in MANIFEST, a manifest object." (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) + (format (current-error-port) (G_ "nothing to be done~%"))) (else (let* ((number (generation-number profile)) @@ -269,7 +269,7 @@ synopsis or description matches all of REGEXPS." "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a <manifest-entry>." (define (supersede old new) - (info (_ "package '~a' has been superseded by '~a'~%") + (info (G_ "package '~a' has been superseded by '~a'~%") (manifest-entry-name old) (package-name new)) (manifest-transaction-install-entry (package->manifest-entry new (manifest-entry-output old)) @@ -341,7 +341,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (settings (search-path-environment-variables entries profiles #:kind kind))) (unless (null? settings) - (format #t (_ "The following environment variable definitions may be needed:~%")) + (format #t (G_ "The following environment variable definitions may be needed:~%")) (format #t "~{ ~a~%~}" settings)))) @@ -357,68 +357,68 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (substitutes? . #t))) (define (show-help) - (display (_ "Usage: guix package [OPTION]... + (display (G_ "Usage: guix package [OPTION]... Install, remove, or upgrade packages in a single transaction.\n")) - (display (_ " + (display (G_ " -i, --install PACKAGE ... install PACKAGEs")) - (display (_ " + (display (G_ " -e, --install-from-expression=EXP install the package EXP evaluates to")) - (display (_ " + (display (G_ " -f, --install-from-file=FILE install the package that the code within FILE evaluates to")) - (display (_ " + (display (G_ " -r, --remove PACKAGE ... remove PACKAGEs")) - (display (_ " + (display (G_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) - (display (_ " + (display (G_ " -m, --manifest=FILE create a new profile generation with the manifest from FILE")) - (display (_ " + (display (G_ " --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) - (display (_ " + (display (G_ " --roll-back roll back to the previous generation")) - (display (_ " + (display (G_ " --search-paths[=KIND] display needed environment variable definitions")) - (display (_ " + (display (G_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) - (display (_ " + (display (G_ " -d, --delete-generations[=PATTERN] delete generations matching PATTERN")) - (display (_ " + (display (G_ " -S, --switch-generation=PATTERN switch to a generation matching PATTERN")) - (display (_ " + (display (G_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (newline) - (display (_ " + (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) - (display (_ " + (display (G_ " --verbose produce verbose output")) (newline) - (display (_ " + (display (G_ " -s, --search=REGEXP search in synopsis and description using REGEXP")) - (display (_ " + (display (G_ " -I, --list-installed[=REGEXP] list installed packages matching REGEXP")) - (display (_ " + (display (G_ " -A, --list-available[=REGEXP] list available packages matching REGEXP")) - (display (_ " + (display (G_ " --show=PACKAGE show details about PACKAGE")) (newline) (show-build-options-help) (newline) (show-transformation-options-help) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -504,7 +504,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) (#f 'exact) (x - (leave (_ "~a: unsupported \ + (leave (G_ "~a: unsupported \ kind of search path~%") x))))) (values (cons `(query search-paths ,kind) @@ -681,24 +681,26 @@ processed, #f otherwise." (unless (null-list? (cdr numbers)) (display-profile-content-diff profile (car numbers) (cadr numbers)) (diff-profiles profile (cdr numbers)))) - (cond ((not (file-exists? profile)) ; XXX: race condition - (raise (condition (&profile-not-found-error - (profile profile))))) - ((string-null? pattern) - (list-generation display-profile-content - (car (profile-generations profile))) - (diff-profiles profile (profile-generations profile))) - ((matching-generations pattern profile) - => - (lambda (numbers) - (if (null-list? numbers) - (exit 1) - (leave-on-EPIPE - (list-generation display-profile-content (car numbers)) - (diff-profiles profile numbers))))) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) + + (leave-on-EPIPE + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (list-generation display-profile-content + (car (profile-generations profile))) + (diff-profiles profile (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (begin + (list-generation display-profile-content (car numbers)) + (diff-profiles profile numbers))))) + (else + (leave (G_ "invalid syntax: ~a~%") + pattern)))) #t) (('list-installed regexp) @@ -788,7 +790,7 @@ processed, #f otherwise." (let ((number (relative-generation-spec->number profile spec))) (if number (switch-to-generation* profile number) - (leave (_ "cannot switch to generation '~a'~%") spec))))) + (leave (G_ "cannot switch to generation '~a'~%") spec))))) (define* (delete-generations-action store profile pattern opts #:key dry-run?) @@ -804,9 +806,9 @@ processed, #f otherwise." (bootstrap? (assoc-ref opts 'bootstrap?)) (substitutes? (assoc-ref opts 'substitutes?))) (if dry-run? - (format #t (_ "would install new manifest from '~a' with ~d entries~%") + (format #t (G_ "would install new manifest from '~a' with ~d entries~%") file (length (manifest-entries manifest))) - (format #t (_ "installing new manifest from '~a' with ~d entries~%") + (format #t (G_ "installing new manifest from '~a' with ~d entries~%") file (length (manifest-entries manifest)))) (build-and-use-profile store profile manifest #:bootstrap? bootstrap? @@ -859,6 +861,8 @@ processed, #f otherwise." (manifest-transaction-install step2))))) (new (manifest-perform-transaction manifest step3))) + (warn-about-old-distro) + (unless (manifest-transaction-null? step3) (show-manifest-transaction store manifest step3 #:dry-run? dry-run?) @@ -877,7 +881,7 @@ processed, #f otherwise." ;; Process non-option argument ARG by calling back ARG-HANDLER. (if arg-handler (arg-handler arg result) - (leave (_ "~A: extraneous argument~%") arg))) + (leave (G_ "~A: extraneous argument~%") arg))) (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 59ade0a8c1..aee506af46 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -54,7 +54,7 @@ actual output is different from that when we're doing a 'bmCheck' or (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors")) (unless url - (leave (_ "~a: missing URL~%") (derivation-file-name drv))) + (leave (G_ "~a: missing URL~%") (derivation-file-name drv))) (let* ((output (or output output*)) (url (call-with-input-string url read)) @@ -62,7 +62,7 @@ actual output is different from that when we're doing a 'bmCheck' or (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) (unless (and algo hash) - (leave (_ "~a is not a fixed-output derivation~%") + (leave (G_ "~a is not a fixed-output derivation~%") (derivation-file-name drv))) ;; We're invoked by the daemon, which gives us write access to OUTPUT. @@ -86,7 +86,7 @@ actual output is different from that when we're doing a 'bmCheck' or (define (assert-low-privileges) (when (zero? (getuid)) - (leave (_ "refusing to run with elevated privileges (UID ~a)~%") + (leave (G_ "refusing to run with elevated privileges (UID ~a)~%") (getuid)))) (define (guix-perform-download . args) @@ -115,7 +115,7 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See (show-version-and-exit)) (x (leave - (_ "fixed-output derivation and output file name expected~%")))))) + (G_ "fixed-output derivation and output file name expected~%")))))) ;; Local Variables: ;; eval: (put 'derivation-let 'scheme-indent-function 2) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index d8ac72f4ef..db7f6a957e 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -38,6 +39,7 @@ #:use-module (web response) #:use-module (web server) #:use-module (web uri) + #:autoload (sxml simple) (sxml->xml) #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix config) @@ -45,44 +47,52 @@ #:use-module (guix hash) #:use-module (guix pki) #:use-module (guix pk-crypto) + #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix zlib) + #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module ((guix utils) #:select (compressed-file?)) - #:use-module ((guix build utils) #:select (dump-port)) + #:use-module ((guix utils) + #:select (with-atomic-file-output compressed-file?)) + #:use-module ((guix build utils) + #:select (dump-port mkdir-p find-files)) #:export (%public-key %private-key guix-publish)) (define (show-help) - (format #t (_ "Usage: guix publish [OPTION]... + (format #t (G_ "Usage: guix publish [OPTION]... Publish ~a over HTTP.\n") %store-directory) - (display (_ " + (display (G_ " -p, --port=PORT listen on PORT")) - (display (_ " + (display (G_ " --listen=HOST listen on the network interface for HOST")) - (display (_ " + (display (G_ " -u, --user=USER change privileges to USER as soon as possible")) - (display (_ " + (display (G_ " -C, --compression[=LEVEL] compress archives at LEVEL")) - (display (_ " + (display (G_ " + -c, --cache=DIRECTORY cache published items to DIRECTORY")) + (display (G_ " + --workers=N use N workers to bake items")) + (display (G_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) - (display (_ " + (display (G_ " --nar-path=PATH use PATH as the prefix for nar URLs")) - (display (_ " + (display (G_ " --public-key=FILE use FILE as the public key for signatures")) - (display (_ " + (display (G_ " --private-key=FILE use FILE as the private key for signatures")) - (display (_ " + (display (G_ " -r, --repl[=PORT] spawn REPL server on PORT")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -93,7 +103,7 @@ Publish ~a over HTTP.\n") %store-directory) (lambda () (getaddrinfo host)) (lambda (key error) - (leave (_ "lookup of host '~a' failed: ~a~%") + (leave (G_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) ;; Nar compression parameters. @@ -110,6 +120,13 @@ Publish ~a over HTTP.\n") %store-directory) ;; Since we compress on the fly, default to fast compression. (compression 'gzip 3)) +(define (actual-compression item requested) + "Return the actual compression used for ITEM, which may be %NO-COMPRESSION +if ITEM is already compressed." + (if (compressed-file? item) + %no-compression + requested)) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -131,7 +148,7 @@ Publish ~a over HTTP.\n") %store-directory) (alist-cons 'address (addrinfo:addr info) result)) (() - (leave (_ "lookup of host '~a' returned nothing") + (leave (G_ "lookup of host '~a' returned nothing") name))))) (option '(#\C "compression") #f #t (lambda (opt name arg result) @@ -144,14 +161,21 @@ Publish ~a over HTTP.\n") %store-directory) (compression 'gzip level) result) (begin - (warning (_ "zlib support is missing; \ + (warning (G_ "zlib support is missing; \ compression disabled~%")) result)))))) + (option '(#\c "cache") #t #f + (lambda (opt name arg result) + (alist-cons 'cache arg result))) + (option '("workers") #t #f + (lambda (opt name arg result) + (alist-cons 'workers (string->number* arg) + result))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) (unless duration - (leave (_ "~a: invalid duration~%") arg)) + (leave (G_ "~a: invalid duration~%") arg)) (alist-cons 'narinfo-ttl (time-second duration) result)))) (option '("nar-path") #t #f @@ -183,6 +207,9 @@ compression disabled~%")) %default-gzip-compression %no-compression)) + ;; Default number of workers when caching is enabled. + (workers . ,(current-processor-count)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -213,14 +240,14 @@ compression disabled~%")) (define* (narinfo-string store store-path key #:key (compression %no-compression) - (nar-path "nar")) + (nar-path "nar") file-size) "Generate a narinfo key/value string for STORE-PATH; an exception is raised if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The -narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs." +narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs. +Optionally, FILE-SIZE can specify the size in bytes of the compressed NAR; it +informs the client of how much needs to be downloaded." (let* ((path-info (query-path-info store store-path)) - (compression (if (compressed-file? store-path) - %no-compression - compression)) + (compression (actual-compression store-path compression)) (url (encode-and-join-uri-path `(,@(split-and-decode-uri-path nar-path) ,@(match compression @@ -232,6 +259,8 @@ narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs." (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) + (file-size (or file-size + (and (eq? compression %no-compression) size))) (references (string-join (map basename (path-info-references path-info)) " ")) @@ -243,10 +272,13 @@ URL: ~a Compression: ~a NarHash: sha256:~a NarSize: ~d -References: ~a~%" +References: ~a~%~a" store-path url (compression-type compression) - hash size references)) + hash size references + (if file-size + (format #f "FileSize: ~a~%" file-size) + ""))) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -268,10 +300,15 @@ References: ~a~%" (canonical-sexp->string (signed-string info))))) (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) -(define (not-found request) +(define* (not-found request + #:key (phrase "Resource not found") + ttl) "Render 404 response for REQUEST." - (values (build-response #:code 404) - (string-append "Resource not found: " + (values (build-response #:code 404 + #:headers (if ttl + `((cache-control (max-age . ,ttl))) + '())) + (string-append phrase ": " (uri-path (request-uri request))))) (define (render-nix-cache-info) @@ -303,6 +340,151 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." #:compression compression) <>))))) +(define* (nar-cache-file directory item + #:key (compression %no-compression)) + (string-append directory "/" + (symbol->string (compression-type compression)) + "/" (basename item) ".nar")) + +(define* (narinfo-cache-file directory item + #:key (compression %no-compression)) + (string-append directory "/" + (symbol->string (compression-type compression)) + "/" (basename item) + ".narinfo")) + +(define run-single-baker + (let ((baking (make-weak-value-hash-table)) + (mutex (make-mutex))) + (lambda (item thunk) + "Run THUNK, which is supposed to bake ITEM, but make sure only one +thread is baking ITEM at a given time." + (define selected? + (with-mutex mutex + (and (not (hash-ref baking item)) + (begin + (hash-set! baking item (current-thread)) + #t)))) + + (when selected? + (dynamic-wind + (const #t) + thunk + (lambda () + (with-mutex mutex + (hash-remove! baking item)))))))) + +(define-syntax-rule (single-baker item exp ...) + "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM +at a time." + (run-single-baker item (lambda () exp ...))) + + +(define (narinfo-files cache) + "Return the list of .narinfo files under CACHE." + (if (file-is-directory? cache) + (find-files cache + (lambda (file stat) + (string-suffix? ".narinfo" file))) + '())) + +(define* (render-narinfo/cached store request hash + #:key ttl (compression %no-compression) + (nar-path "nar") + cache pool) + "Respond to the narinfo request for REQUEST. If the narinfo is available in +CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo +requested using POOL." + (define (delete-entry narinfo) + ;; Delete NARINFO and the corresponding nar from CACHE. + (let ((nar (string-append (string-drop-right narinfo + (string-length ".narinfo")) + ".nar"))) + (delete-file* narinfo) + (delete-file* nar))) + + (let* ((item (hash-part->path store hash)) + (compression (actual-compression item compression)) + (cached (and (not (string-null? item)) + (narinfo-cache-file cache item + #:compression compression)))) + (cond ((string-null? item) + (not-found request)) + ((file-exists? cached) + ;; Narinfo is in cache, send it. + (values `((content-type . (application/x-nix-narinfo)) + ,@(if ttl + `((cache-control (max-age . ,ttl))) + '())) + (lambda (port) + (display (call-with-input-file cached + read-string) + port)))) + ((valid-path? store item) + ;; Nothing in cache: bake the narinfo and nar in the background and + ;; return 404. + (eventually pool + (single-baker item + ;; (format #t "baking ~s~%" item) + (bake-narinfo+nar cache item + #:ttl ttl + #:compression compression + #:nar-path nar-path)) + + (when ttl + (single-baker 'cache-cleanup + (maybe-remove-expired-cache-entries cache + narinfo-files + #:entry-expiration + (file-expiration-time ttl) + #:delete-entry delete-entry + #:cleanup-period ttl)))) + (not-found request + #:phrase "We're baking it" + #:ttl 300)) ;should be available within 5m + (else + (not-found request))))) + +(define* (bake-narinfo+nar cache item + #:key ttl (compression %no-compression) + (nar-path "/nar")) + "Write the narinfo and nar for ITEM to CACHE." + (let* ((compression (actual-compression item compression)) + (nar (nar-cache-file cache item + #:compression compression)) + (narinfo (narinfo-cache-file cache item + #:compression compression))) + + (mkdir-p (dirname nar)) + (match (compression-type compression) + ('gzip + ;; Note: the file port gets closed along with the gzip port. + (call-with-gzip-output-port (open-output-file (string-append nar ".tmp")) + (lambda (port) + (write-file item port)) + #:level (compression-level compression) + #:buffer-size (* 128 1024)) + (rename-file (string-append nar ".tmp") nar)) + ('none + ;; When compression is disabled, we retrieve files directly from the + ;; store; no need to cache them. + #t)) + + (mkdir-p (dirname narinfo)) + (with-atomic-file-output narinfo + (lambda (port) + ;; Open a new connection to the store. We cannot reuse the main + ;; thread's connection to the store since we would end up sending + ;; stuff concurrently on the same channel. + (with-store store + (display (narinfo-string store item + (%private-key) + #:nar-path nar-path + #:compression compression + #:file-size (and=> (stat nar #f) + stat:size)) + port)))))) + ;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. @@ -334,6 +516,21 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." store-path) (not-found request)))) +(define* (render-nar/cached store cache request store-item + #:key (compression %no-compression)) + "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE, +return it; otherwise, return 404." + (let ((cached (nar-cache-file cache store-item + #:compression compression))) + (if (file-exists? cached) + (values `((content-type . (application/octet-stream + (charset . "ISO-8859-1")))) + ;; XXX: We're not returning the actual contents, deferring + ;; instead to 'http-write'. This is a hack to work around + ;; <http://bugs.gnu.org/21093>. + cached) + (not-found request)))) + (define (render-content-addressed-file store request name algo hash) "Return the content of the result of the fixed-output derivation NAME that @@ -353,6 +550,22 @@ has the given HASH of type ALGO." (not-found request))) (not-found request))) +(define (render-home-page request) + "Render the home page." + (values `((content-type . (text/html (charset . "UTF-8")))) + (call-with-output-string + (lambda (port) + (sxml->xml '(html + (head (title "GNU Guix Substitute Server")) + (body + (h1 "GNU Guix Substitute Server") + (p "Hi, " + (a (@ (href + "https://gnu.org/s/guix/manual/html_node/Invoking-guix-publish.html")) + (tt "guix publish")) + " speaking. Welcome!"))) + port))))) + (define extract-narinfo-hash (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$"))) (lambda (str) @@ -464,7 +677,9 @@ blocking." size) client)) (output (response-port response))) - (dump-port input output) + (if (file-port? output) + (sendfile output input size) + (dump-port input output)) (close-port output) (values))))) (lambda args @@ -488,6 +703,7 @@ blocking." (define* (make-request-handler store #:key + cache pool narinfo-ttl (nar-path "nar") (compression %no-compression)) @@ -504,14 +720,24 @@ blocking." ;; /nix-cache-info (("nix-cache-info") (render-nix-cache-info)) + ;; / + ((or () ("index.html")) + (render-home-page request)) ;; /<hash>.narinfo (((= extract-narinfo-hash (? string? hash))) ;; TODO: Register roots for HASH that will somehow remain for ;; NARINFO-TTL. - (render-narinfo store request hash - #:ttl narinfo-ttl - #:nar-path nar-path - #:compression compression)) + (if cache + (render-narinfo/cached store request hash + #:cache cache + #:pool pool + #:ttl narinfo-ttl + #:nar-path nar-path + #:compression compression) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:nar-path nar-path + #:compression compression))) ;; /nar/file/NAME/sha256/HASH (("file" name "sha256" hash) (guard (c ((invalid-base32-character? c) @@ -527,13 +753,16 @@ blocking." ;; /nar/gzip/<store-item> ((components ... "gzip" store-item) (if (and (nar-path? components) (zlib-available?)) - (render-nar store request store-item - #:compression - (match compression - (($ <compression> 'gzip) - compression) - (_ - %default-gzip-compression))) + (let ((compression (match compression + (($ <compression> 'gzip) + compression) + (_ + %default-gzip-compression)))) + (if cache + (render-nar/cached store cache request store-item + #:compression compression) + (render-nar store request store-item + #:compression compression))) (not-found request))) ;; /nar/<store-item> @@ -548,8 +777,11 @@ blocking." (define* (run-publish-server socket store #:key (compression %no-compression) - (nar-path "nar") narinfo-ttl) + (nar-path "nar") narinfo-ttl + cache pool) (run-server (make-request-handler store + #:cache cache + #:pool pool #:nar-path nar-path #:narinfo-ttl narinfo-ttl #:compression compression) @@ -572,7 +804,7 @@ blocking." (setgid (passwd:gid user)) (setuid (passwd:uid user)))) (lambda (key proc message args . rest) - (leave (_ "user '~a' not found: ~a~%") + (leave (G_ "user '~a' not found: ~a~%") user (apply format #f message args))))) @@ -584,9 +816,9 @@ blocking." (with-error-handling (let* ((opts (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) - (leave (_ "~A: extraneous argument~%") arg)) + (leave (G_ "~A: extraneous argument~%") arg)) %default-options)) (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) @@ -599,6 +831,8 @@ blocking." (socket (open-server-socket address)) (nar-path (assoc-ref opts 'nar-path)) (repl-port (assoc-ref opts 'repl)) + (cache (assoc-ref opts 'cache)) + (workers (assoc-ref opts 'workers)) ;; 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. @@ -611,12 +845,12 @@ blocking." (gather-user-privileges user)) (when (zero? (getuid)) - (warning (_ "server running as root; \ + (warning (G_ "server running as root; \ consider using the '--user' option!~%"))) (parameterize ((%public-key public-key) (%private-key private-key)) - (format #t (_ "publishing ~a on ~a, port ~d~%") + (format #t (G_ "publishing ~a on ~a, port ~d~%") %store-directory (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) (sockaddr:port address)) @@ -624,6 +858,12 @@ consider using the '--user' option!~%"))) (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store (run-publish-server socket store + #:cache cache + #:pool (and cache (make-pool workers)) #:nar-path nar-path #:compression compression #:narinfo-ttl ttl)))))) + +;;; Local Variables: +;;; eval: (put 'single-baker 'scheme-indent-function 1) +;;; End: diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 8e31ad620c..58b87d4df4 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -28,6 +28,7 @@ #:use-module (guix download) #:use-module (guix gexp) #:use-module (guix monads) + #:use-module (guix scripts build) #:use-module ((guix build utils) #:select (with-directory-excursion delete-file-recursively)) #:use-module ((guix build download) @@ -72,45 +73,56 @@ (define %default-options ;; Alist of default option values. - `((tarball-url . ,%snapshot-url))) + `((tarball-url . ,%snapshot-url) + (system . ,(%current-system)) + (substitutes? . #t) + (graft? . #t) + (max-silent-time . 3600) + (verbosity . 0))) (define (show-help) - (display (_ "Usage: guix pull [OPTION]... + (display (G_ "Usage: guix pull [OPTION]... Download and deploy the latest version of Guix.\n")) - (display (_ " + (display (G_ " --verbose produce verbose output")) - (display (_ " + (display (G_ " --url=URL download the Guix tarball from URL")) - (display (_ " + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) - (display (_ " + (show-build-options-help) + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) (define %options ;; Specifications of the command-line options. - (list (option '("verbose") #f #f - (lambda (opt name arg result) - (alist-cons 'verbose? #t result))) - (option '("url") #t #f - (lambda (opt name arg result) - (alist-cons 'tarball-url arg - (alist-delete 'tarball-url result)))) - (option '("bootstrap") #f #f - (lambda (opt name arg result) - (alist-cons 'bootstrap? #t result))) + (cons* (option '("verbose") #f #f + (lambda (opt name arg result) + (alist-cons 'verbose? #t result))) + (option '("url") #t #f + (lambda (opt name arg result) + (alist-cons 'tarball-url arg + (alist-delete 'tarball-url result)))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) - (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix pull"))))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix pull"))) + + %standard-build-options)) (define what-to-build (store-lift show-what-to-build)) @@ -153,7 +165,7 @@ store file name." (mbegin %store-monad (what-to-build (list tar gzip)) (built-derivations (list tar gzip)) - (format #t (_ "unpacking '~a'...~%") tarball) + (format #t (G_ "unpacking '~a'...~%") tarball) (let ((source (temporary-directory))) (with-directory-excursion source @@ -205,26 +217,18 @@ contained therein." (if (and (file-exists? latest) (string=? (readlink latest) source-dir)) (begin - (display (_ "Guix already up to date\n")) + (display (G_ "Guix already up to date\n")) (return #t)) (begin (switch-symlinks latest source-dir) (format #t - (_ "updated ~a successfully deployed under `~a'~%") + (G_ "updated ~a successfully deployed under `~a'~%") %guix-package-name latest) (return #t)))) - (leave (_ "failed to update Guix, check the build log~%"))))) + (leave (G_ "failed to update Guix, check the build log~%"))))) + (define (guix-pull . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: unexpected argument~%") arg)) - %default-options)) - (define (use-le-certs? url) (string-prefix? "https://git.savannah.gnu.org/" url)) @@ -232,28 +236,31 @@ contained therein." (download-to-store store url "guix-latest.tar.gz")) (with-error-handling - (let* ((opts (parse-options)) - (store (open-connection)) + (let* ((opts (parse-command-line args %options + (list %default-options))) (url (assoc-ref opts 'tarball-url))) - (let ((tarball - (if (use-le-certs? url) - (let* ((drv (package-derivation store le-certs)) - (certs (string-append (derivation->output-path drv) - "/etc/ssl/certs"))) - (build-derivations store (list drv)) - (parameterize ((%x509-certificate-directory certs)) - (fetch-tarball store url))) - (fetch-tarball store url)))) - (unless tarball - (leave (_ "failed to download up-to-date source, exiting\n"))) - (parameterize ((%guile-for-build - (package-derivation store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.0))))) - (run-with-store store - (build-and-install tarball (config-directory) - #:verbose? (assoc-ref opts 'verbose?)))))))) + (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful + (with-store store + (set-build-options-from-command-line store opts) + (let ((tarball + (if (use-le-certs? url) + (let* ((drv (package-derivation store le-certs)) + (certs (string-append (derivation->output-path drv) + "/etc/ssl/certs"))) + (build-derivations store (list drv)) + (parameterize ((%x509-certificate-directory certs)) + (fetch-tarball store url))) + (fetch-tarball store url)))) + (unless tarball + (leave (G_ "failed to download up-to-date source, exiting\n"))) + (parameterize ((%guile-for-build + (package-derivation store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.0))))) + (run-with-store store + (build-and-install tarball (config-directory) + #:verbose? (assoc-ref opts 'verbose?)))))))))) ;; Local Variables: ;; eval: (put 'with-PATH 'scheme-indent-function 1) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 4d3c695aaf..f85d6e5101 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -28,18 +28,10 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix discovery) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix monads) - #:use-module ((guix gnu-maintenance) - #:select (%gnu-updater - %gnome-updater - %kde-updater - %xorg-updater - %kernel.org-updater)) - #:use-module (guix import elpa) - #:use-module (guix import cran) - #:use-module (guix import hackage) #:use-module (guix gnupg) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) @@ -76,7 +68,7 @@ (alist-cons 'select (string->symbol arg) result)) (x - (leave (_ "~a: invalid selection; expected `core' or `non-core'~%") + (leave (G_ "~a: invalid selection; expected `core' or `non-core'~%") arg))))) (option '(#\t "type") #t #f (lambda (opt name arg result) @@ -107,7 +99,7 @@ (alist-cons 'key-download (string->symbol arg) result)) (x - (leave (_ "unsupported policy: ~a~%") + (leave (G_ "unsupported policy: ~a~%") arg))))) (option '(#\h "help") #f #f @@ -119,41 +111,41 @@ (show-version-and-exit "guix refresh"))))) (define (show-help) - (display (_ "Usage: guix refresh [OPTION]... [PACKAGE]... + (display (G_ "Usage: guix refresh [OPTION]... [PACKAGE]... Update package definitions to match the latest upstream version. When PACKAGE... is given, update only the specified packages. Otherwise update all the packages of the distribution, or the subset thereof specified with `--select'.\n")) - (display (_ " + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) - (display (_ " + (display (G_ " -u, --update update source files in place")) - (display (_ " + (display (G_ " -s, --select=SUBSET select all the packages in SUBSET, one of `core' or `non-core'")) - (display (_ " + (display (G_ " -t, --type=UPDATER,... restrict to updates from the specified updaters (e.g., 'gnu')")) - (display (_ " + (display (G_ " -L, --list-updaters list available updaters and exit")) - (display (_ " + (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) (newline) - (display (_ " + (display (G_ " --key-server=HOST use HOST as the OpenPGP key server")) - (display (_ " + (display (G_ " --gpg=COMMAND use COMMAND as the GnuPG 2.x command")) - (display (_ " + (display (G_ " --key-download=POLICY handle missing OpenPGP keys according to POLICY: 'always', 'never', and 'interactive', which is also used when 'key-download' is not specified")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -163,66 +155,32 @@ specified with `--select'.\n")) ;;; Updates. ;;; -(define-syntax maybe-updater - ;; Helper macro for 'list-updaters'. - (syntax-rules (=>) - ((_ ((module => updater) rest ...) result) - (maybe-updater (rest ...) - (let ((iface (false-if-exception - (resolve-interface 'module))) - (tail result)) - (if iface - (cons (module-ref iface 'updater) tail) - tail)))) - ((_ (updater rest ...) result) - (maybe-updater (rest ...) - (cons updater result))) - ((_ () result) - (reverse result)))) - -(define-syntax-rule (list-updaters updaters ...) - "Expand to '(list UPDATERS ...)' but only the subset of UPDATERS that are -either unconditional, or have their requirement met. - -A conditional updater has this form: - - ((SOME MODULE) => UPDATER) - -meaning that UPDATER is added to the list if and only if (SOME MODULE) could -be resolved at run time. - -This is a way to discard at macro expansion time updaters that depend on -unavailable optional dependencies such as Guile-JSON." - (maybe-updater (updaters ...) '())) +(define (importer-modules) + "Return the list of importer modules." + (cons (resolve-interface '(guix gnu-maintenance)) + (all-modules (map (lambda (entry) + `(,entry . "guix/import")) + %load-path)))) (define %updaters - ;; List of "updaters" used by default. They are consulted in this order. - (list-updaters %gnu-updater - %gnome-updater - %kde-updater - %xorg-updater - %kernel.org-updater - %elpa-updater - %cran-updater - %bioconductor-updater - ((guix import stackage) => %stackage-updater) - %hackage-updater - ((guix import cpan) => %cpan-updater) - ((guix import pypi) => %pypi-updater) - ((guix import gem) => %gem-updater) - ((guix import github) => %github-updater) - ((guix import crate) => %crate-updater))) + ;; The list of publically-known updaters. + (delay (fold-module-public-variables (lambda (obj result) + (if (upstream-updater? obj) + (cons obj result) + result)) + '() + (importer-modules)))) (define (lookup-updater-by-name name) "Return the updater called NAME." (or (find (lambda (updater) (eq? name (upstream-updater-name updater))) - %updaters) - (leave (_ "~a: no such updater~%") name))) + (force %updaters)) + (leave (G_ "~a: no such updater~%") name))) (define (list-updaters-and-exit) "Display available updaters and exit." - (format #t (_ "Available updaters:~%")) + (format #t (G_ "Available updaters:~%")) (newline) (let* ((packages (fold-packages cons '())) @@ -234,22 +192,22 @@ unavailable optional dependencies such as Guile-JSON." ;; TRANSLATORS: The parenthetical expression here is rendered ;; like "(42% coverage)" and denotes the fraction of packages ;; covered by the given updater. - (format #t (_ " - ~a: ~a (~2,1f% coverage)~%") + (format #t (G_ " - ~a: ~a (~2,1f% coverage)~%") (upstream-updater-name updater) - (_ (upstream-updater-description updater)) + (G_ (upstream-updater-description updater)) (* 100. (/ matches total))) (+ covered matches))) 0 - %updaters)) + (force %updaters))) (newline) - (format #t (_ "~2,1f% of the packages are covered by these updaters.~%") + (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%") (* 100. (/ covered total)))) (exit 0)) (define (warn-no-updater package) (format (current-error-port) - (_ "~a: warning: no updater for ~a~%") + (G_ "~a: warning: no updater for ~a~%") (location->string (package-location package)) (package-name package))) @@ -270,14 +228,14 @@ warn about packages that have no matching updater." (if (and=> tarball file-exists?) (begin (format (current-error-port) - (_ "~a: ~a: updating from version ~a to version ~a...~%") + (G_ "~a: ~a: updating from version ~a to version ~a...~%") (location->string loc) (package-name package) (package-version package) version) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) - (warning (_ "~a: version ~a could not be \ + (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") (package-name package) version)))) (when warn? @@ -293,7 +251,7 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (let ((loc (or (package-field-location package 'version) (package-location package)))) (format (current-error-port) - (_ "~a: ~a would be upgraded from ~a to ~a~%") + (G_ "~a: ~a would be upgraded from ~a to ~a~%") (location->string loc) (package-name package) (package-version package) (upstream-source-version source))))) @@ -315,6 +273,10 @@ WARN? is true and no updater exists for PACKAGE, print a warning." "List all the things that would need to be rebuilt if PACKAGES are changed." ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + (mlet %store-monad ((edges (node-back-edges %bag-node-type (all-packages)))) (let* ((dependents (node-transitive-edges packages edges)) @@ -327,12 +289,12 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (N_ "No dependents other than itself: ~{~a~}~%" "No dependents other than themselves: ~{~a~^ ~}~%" (length packages)) - (map package-full-name packages))) + (map full-name packages))) ((x) (format (current-output-port) - (_ "A single dependent package: ~a~%") - (package-full-name x))) + (G_ "A single dependent package: ~a~%") + (full-name x))) (lst (format (current-output-port) (N_ "Building the following package would ensure ~d \ @@ -341,7 +303,7 @@ dependent packages are rebuilt: ~*~{~a~^ ~}~%" dependent packages are rebuilt: ~{~a~^ ~}~%" (length covering)) (length covering) (length dependents) - (map package-full-name covering)))) + (map full-name covering)))) (return #t)))) @@ -354,7 +316,7 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" ;; Return the alist of option values. (args-fold* args %options (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) + (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) @@ -368,7 +330,7 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" opts) (() ;; Use the default updaters. - %updaters) + (force %updaters)) (lists (concatenate lists)))) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index ea259f3758..52f7cdd972 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,7 +74,7 @@ if ITEM is not in the store." ;; The nar size is an approximation, but a good one. (return (substitutable-nar-size info))) (() - (leave (_ "no available substitute information for '~a'~%") + (leave (G_ "no available substitute information for '~a'~%") item))))))) (define* (display-profile profile #:optional (port (current-output-port))) @@ -82,7 +82,7 @@ if ITEM is not in the store." (define MiB (expt 2 20)) (format port "~64a ~8a ~a\n" - (_ "store item") (_ "total") (_ "self")) + (G_ "store item") (G_ "total") (G_ "self")) (let ((whole (reduce + 0 (map profile-self-size profile)))) (for-each (match-lambda (($ <profile> name self total) @@ -91,9 +91,10 @@ if ITEM is not in the store." (* 100. (/ self whole 1.))))) (sort profile (match-lambda* - ((($ <profile> _ _ total1) ($ <profile> _ _ total2)) + ((($ <profile> name1 self1 total1) + ($ <profile> name2 self2 total2)) (> total1 total2))))) - (format port (_ "total: ~,1f MiB~%") (/ whole MiB 1.)))) + (format port (G_ "total: ~,1f MiB~%") (/ whole MiB 1.)))) (define display-profile* (lift display-profile %store-monad)) @@ -200,13 +201,14 @@ the name of a PNG file." 0 (sort profiles (match-lambda* - ((($ <profile> _ _ total1) ($ <profile> _ _ total2)) + ((($ <profile> name1 self1 total1) + ($ <profile> name2 self2 total2)) (> total1 total2)))))) ;; TRANSLATORS: This is the title of a graph, meaning that the graph ;; represents a profile of the store (the "store" being the place where ;; packages are stored.) - (make-page-map (_ "store profile") data + (make-page-map (G_ "store profile") data #:write-to-png file)) @@ -215,19 +217,19 @@ the name of a PNG file." ;;; (define (show-help) - (display (_ "Usage: guix size [OPTION]... PACKAGE + (display (G_ "Usage: guix size [OPTION]... PACKAGE Report the size of PACKAGE and its dependencies.\n")) - (display (_ " + (display (G_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) - (display (_ " + (display (G_ " -s, --system=SYSTEM consider packages for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " + (display (G_ " -m, --map-file=FILE write to FILE a graphical map of disk usage")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -276,7 +278,7 @@ Report the size of PACKAGE and its dependencies.\n")) (urls (assoc-ref opts 'substitute-urls))) (match files (() - (leave (_ "missing store item argument\n"))) + (leave (G_ "missing store item argument\n"))) ((files ..1) (leave-on-EPIPE ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d3bccf4ddb..73d4f6e2eb 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -28,6 +28,7 @@ #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix base64) + #:use-module (guix cache) #:use-module (guix pk-crypto) #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) @@ -110,7 +111,7 @@ (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") (cut string-ci=? <> "yes")) (begin - (warning (_ "authentication and authorization of substitutes \ + (warning (G_ "authentication and authorization of substitutes \ disabled!~%")) #t))) @@ -185,7 +186,7 @@ provide." (values port (stat:size (stat port))))) ((http https) (guard (c ((http-get-error? c) - (leave (_ "download from '~a' failed: ~a, ~s~%") + (leave (G_ "download from '~a' failed: ~a, ~s~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)))) @@ -198,9 +199,9 @@ provide." %fetch-timeout 0) (begin - (warning (_ "while fetching ~a: server is somewhat slow~%") + (warning (G_ "while fetching ~a: server is somewhat slow~%") (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%")) + (warning (G_ "try `--no-substitutes' if the problem persists~%")) ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, ;; and thus PORT had to be closed and re-opened. This is not the @@ -218,7 +219,7 @@ provide." (http-fetch uri #:text? #f #:port port #:verify-certificate? #f)))))) (else - (leave (_ "unsupported substitute URI scheme: ~a~%") + (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) (define-record-type <cache-info> @@ -253,12 +254,12 @@ failure, return #f and #f." #:verify-certificate? #f #:timeout %fetch-timeout))) (guard (c ((http-get-error? c) - (warning (_ "while fetching '~a': ~a (~s)~%") + (warning (G_ "while fetching '~a': ~a (~s)~%") (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) (close-connection port) - (warning (_ "ignoring substitute server at '~s'~%") url) + (warning (G_ "ignoring substitute server at '~s'~%") url) (values #f #f))) (values (read-cache-info (http-fetch uri #:verify-certificate? #f @@ -308,11 +309,11 @@ Otherwise return #f." ((version host-name sig) (let ((maybe-number (string->number version))) (cond ((not (number? maybe-number)) - (leave (_ "signature version must be a number: ~s~%") + (leave (G_ "signature version must be a number: ~s~%") version)) ;; Currently, there are no other versions. ((not (= 1 maybe-number)) - (leave (_ "unsupported signature version: ~a~%") + (leave (G_ "unsupported signature version: ~a~%") maybe-number)) (else (let ((signature (utf8->string (base64-decode sig)))) @@ -320,11 +321,11 @@ Otherwise return #f." (lambda () (string->canonical-sexp signature)) (lambda (key proc err) - (leave (_ "signature is not a valid \ + (leave (G_ "signature is not a valid \ s-expression: ~s~%") signature)))))))) (x - (leave (_ "invalid format of the signature field: ~a~%") x)))) + (leave (G_ "invalid format of the signature field: ~a~%") x)))) (define (narinfo-maker str cache-url) "Return a narinfo constructor for narinfos originating from CACHE-URL. STR @@ -359,13 +360,13 @@ NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." (signature-case (signature hash acl) (valid-signature #t) (invalid-signature - (leave (_ "invalid signature for '~a'~%") uri)) + (leave (G_ "invalid signature for '~a'~%") uri)) (hash-mismatch - (leave (_ "hash mismatch for '~a'~%") uri)) + (leave (G_ "hash mismatch for '~a'~%") uri)) (unauthorized-key - (leave (_ "'~a' is signed with an unauthorized key~%") uri)) + (leave (G_ "'~a' is signed with an unauthorized key~%") uri)) (corrupt-signature - (leave (_ "signature on '~a' is corrupt~%") uri))))) + (leave (G_ "signature on '~a' is corrupt~%") uri))))) (define* (read-narinfo port #:optional url #:key size) @@ -403,17 +404,17 @@ or is signed by an unauthorized key." (if (not hash) (if %allow-unauthenticated-substitutes? narinfo - (leave (_ "substitute at '~a' lacks a signature~%") + (leave (G_ "substitute at '~a' lacks a signature~%") (uri->string (narinfo-uri narinfo)))) (let ((signature (narinfo-signature narinfo))) (unless %allow-unauthenticated-substitutes? (assert-valid-signature narinfo signature hash acl) (when verbose? (format (current-error-port) - (_ "Found valid signature for ~a~%") + (G_ "Found valid signature for ~a~%") (narinfo-path narinfo)) (format (current-error-port) - (_ "From ~a~%") + (G_ "From ~a~%") (uri->string (narinfo-uri narinfo))))) narinfo)))) @@ -440,12 +441,6 @@ or is signed by an unauthorized key." the cache STR originates form." (call-with-input-string str (cut read-narinfo <> cache-uri))) -(define (obsolete? date now ttl) - "Return #t if DATE is obsolete compared to NOW + TTL seconds." - (time>? (subtract-duration now (make-time time-duration 0 ttl)) - (make-time time-monotonic 0 date))) - - (define (narinfo-cache-file cache-url path) "Return the name of the local file that contains an entry for PATH. The entry is stored in a sub-directory specific to CACHE-URL." @@ -453,7 +448,7 @@ entry is stored in a sub-directory specific to CACHE-URL." ;; "/gnu/store/foo". Gracefully handle that. (match (store-path-hash-part path) (#f - (leave (_ "'~a' does not name a store item~%") path)) + (leave (G_ "'~a' does not name a store item~%") path)) ((? string? hash-part) (string-append %narinfo-cache-directory "/" (bytevector->base32-string (sha256 (string->utf8 cache-url))) @@ -477,9 +472,9 @@ for PATH." (match (read p) (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('ttl _) ('value #f)) + ('date date) ('ttl ttl) ('value #f)) ;; A cached negative lookup. - (if (obsolete? date now %narinfo-negative-ttl) + (if (obsolete? date now ttl) (values #f #f) (values #t #f))) (('narinfo ('version 2) @@ -601,7 +596,7 @@ if file doesn't exist, and the narinfo otherwise." (display #\cr (current-error-port)) (force-output (current-error-port)) (format (current-error-port) - (_ "updating list of substitutes from '~a'... ~5,1f%") + (G_ "updating list of substitutes from '~a'... ~5,1f%") url (* 100. (/ done (length paths)))) (set! done (+ 1 done))))) @@ -656,7 +651,7 @@ if file doesn't exist, and the narinfo otherwise." paths))) (filter-map (cut narinfo-from-file <> url) files))) (else - (leave (_ "~s: unsupported server URI scheme~%") + (leave (G_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) (let-values (((cache-info port) @@ -666,7 +661,7 @@ if file doesn't exist, and the narinfo otherwise." (%store-prefix)) (do-fetch (string->uri url) port) ;reuse PORT (begin - (warning (_ "'~a' uses different store '~a'; ignoring it~%") + (warning (G_ "'~a' uses different store '~a'; ignoring it~%") url (cache-info-store-directory cache-info)) (close-connection port) #f))))) @@ -718,43 +713,28 @@ was found." ((answer) answer) (_ #f))) -(define (remove-expired-cached-narinfos directory) - "Remove expired narinfo entries from DIRECTORY. The sole purpose of this -function is to make sure `%narinfo-cache-directory' doesn't grow -indefinitely." - (define now - (current-time time-monotonic)) +(define (cached-narinfo-expiration-time file) + "Return the expiration time for FILE, which is a cached narinfo." + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (port) + (match (read port) + (('narinfo ('version 2) ('cache-uri uri) + ('date date) ('ttl ttl) ('value #f)) + (+ date ttl)) + (('narinfo ('version 2) ('cache-uri uri) + ('date date) ('ttl ttl) ('value value)) + (+ date ttl)) + (x + 0))))) + (lambda args + ;; FILE may have been deleted. + 0))) - (define (expired? file) - (catch 'system-error - (lambda () - (call-with-input-file file - (lambda (port) - (match (read port) - (('narinfo ('version 2) ('cache-uri _) - ('date date) ('ttl _) ('value #f)) - (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 2) ('cache-uri _) - ('date date) ('ttl ttl) ('value _)) - (obsolete? date now ttl)) - (_ #t))))) - (lambda args - ;; FILE may have been deleted. - #t))) - - (for-each (lambda (file) - (let ((file (string-append directory "/" file))) - (when (expired? file) - ;; Wrap in `false-if-exception' because FILE might have been - ;; deleted in the meantime (TOCTTOU). - (false-if-exception (delete-file file))))) - (scandir directory - (lambda (file) - (= (string-length file) 32))))) - -(define (narinfo-cache-directories) +(define (narinfo-cache-directories directory) "Return the list of narinfo cache directories (one per cache URL.)" - (map (cut string-append %narinfo-cache-directory "/" <>) + (map (cut string-append directory "/" <>) (scandir %narinfo-cache-directory (lambda (item) (and (not (member item '("." ".."))) @@ -762,25 +742,15 @@ indefinitely." (string-append %narinfo-cache-directory "/" item))))))) -(define (maybe-remove-expired-cached-narinfo) - "Remove expired narinfo entries from the cache if deemed necessary." - (define now - (current-time time-monotonic)) - - (define expiry-file - (string-append %narinfo-cache-directory "/last-expiry-cleanup")) - - (define last-expiry-date - (or (false-if-exception - (call-with-input-file expiry-file read)) - 0)) - - (when (obsolete? last-expiry-date now - %narinfo-expired-cache-entry-removal-delay) - (for-each remove-expired-cached-narinfos - (narinfo-cache-directories)) - (call-with-output-file expiry-file - (cute write (time-second now) <>)))) +(define* (cached-narinfo-files #:optional + (directory %narinfo-cache-directory)) + "Return the list of cached narinfo files under DIRECTORY." + (append-map (lambda (directory) + (map (cut string-append directory "/" <>) + (scandir directory + (lambda (file) + (= (string-length file) 32))))) + (narinfo-cache-directories directory))) (define (progress-report-port report-progress port) "Return a port that calls REPORT-PROGRESS every time something is read from @@ -811,12 +781,12 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (lambda () exp ...) (match-lambda* (('getaddrinfo-error error) - (leave (_ "host name lookup error: ~a~%") + (leave (G_ "host name lookup error: ~a~%") (gai-strerror error))) (('gnutls-error error proc . rest) (let ((error->string (module-ref (resolve-interface '(gnutls)) 'error->string))) - (leave (_ "TLS error in procedure '~a': ~a~%") + (leave (G_ "TLS error in procedure '~a': ~a~%") proc (error->string error)))) (args (apply throw args))))))) @@ -827,19 +797,19 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;;; (define (show-help) - (display (_ "Usage: guix substitute [OPTION]... + (display (G_ "Usage: guix substitute [OPTION]... Internal tool to substitute a pre-built binary to a local build.\n")) - (display (_ " + (display (G_ " --query report on the availability of substitutes for the store file names passed on the standard input")) - (display (_ " + (display (G_ " --substitute STORE-FILE DESTINATION download STORE-FILE and store it as a Nar in file DESTINATION")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -905,7 +875,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; TRANSLATORS: The second part of this message looks like ;; "(4.1MiB installed)"; it shows the size of the package once ;; installed. - (_ "Downloading ~a~:[~*~; (~a installed)~]...~%") + (G_ "Downloading ~a~:[~*~; (~a installed)~]...~%") (uri->string uri) ;; Use the Nar size as an estimate of the installed size. (narinfo-size narinfo) @@ -962,7 +932,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." (let ((acl (acl->public-keys (current-acl)))) (when (or (null? acl) (singleton? acl)) - (warning (_ "ACL for archive imports seems to be uninitialized, \ + (warning (G_ "ACL for archive imports seems to be uninitialized, \ substitutes may be unavailable\n"))))) (define (daemon-options) @@ -1010,10 +980,19 @@ default value." (and number (max 20 (- number 1)))))) 80)) +(define (validate-uri uri) + (unless (string->uri uri) + (leave (G_ "~a: invalid URI~%") uri))) + (define (guix-substitute . args) "Implement the build daemon's substituter protocol." (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cached-narinfo) + (maybe-remove-expired-cache-entries %narinfo-cache-directory + cached-narinfo-files + #:entry-expiration + cached-narinfo-expiration-time + #:cleanup-period + %narinfo-expired-cache-entry-removal-delay) (check-acl-initialized) ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly @@ -1026,6 +1005,9 @@ default value." (newline) (force-output (current-output-port)) + ;; Sanity-check %CACHE-URLS so we can provide a meaningful error message. + (for-each validate-uri %cache-urls) + ;; Attempt to install the client's locale, mostly so that messages are ;; suitably translated. (match (or (find-daemon-option "untrusted-locale") @@ -1058,7 +1040,7 @@ default value." (("--help") (show-help)) (opts - (leave (_ "~a: unrecognized options~%") opts)))))) + (leave (G_ "~a: unrecognized options~%") opts)))))) ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 144a7fd377..f71b1d71b8 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> -;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,10 +38,10 @@ #:use-module (guix build utils) #:use-module (gnu build install) #:use-module (gnu system) + #:use-module (gnu bootloader) #:use-module (gnu system file-systems) #:use-module (gnu system linux-container) #:use-module (gnu system vm) - #:use-module (gnu system grub) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services herd) @@ -77,6 +78,29 @@ ;;; Installation. ;;; +(define-syntax-rule (save-load-path-excursion body ...) + "Save the current values of '%load-path' and '%load-compiled-path', run +BODY..., and restore them." + (let ((path %load-path) + (cpath %load-compiled-path)) + (dynamic-wind + (const #t) + (lambda () + body ...) + (lambda () + (set! %load-path path) + (set! %load-compiled-path cpath))))) + +(define-syntax-rule (save-environment-excursion body ...) + "Save the current environment variables, run BODY..., and restore them." + (let ((env (environ))) + (dynamic-wind + (const #t) + (lambda () + body ...) + (lambda () + (environ env))))) + (define topologically-sorted* (store-lift topologically-sorted)) @@ -106,7 +130,7 @@ #:prefix target #:state-directory state #:references refs) - (leave (_ "failed to register '~a' under '~a'~%") + (leave (G_ "failed to register '~a' under '~a'~%") item target)) (return #t)))) @@ -123,41 +147,50 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) -(define (install-grub* grub.cfg device target) - "This is a variant of 'install-grub' with error handling, lifted in -%STORE-MONAD" - (let* ((gc-root (string-append target %gc-roots-directory - "/grub.cfg")) - (temp-gc-root (string-append gc-root ".new")) - (delete-file (lift1 delete-file %store-monad)) - (make-symlink (lift2 switch-symlinks %store-monad)) - (rename (lift2 rename-file %store-monad))) - (mbegin %store-monad - ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when - ;; 'install-grub' completes (being a bit paranoid.) - (make-symlink temp-gc-root grub.cfg) - - (munless (false-if-exception (install-grub grub.cfg device target)) +(define* (install-bootloader installer-drv + #:key + bootcfg bootcfg-file + device target) + "Call INSTALLER-DRV with error handling, in %STORE-MONAD." + (with-monad %store-monad + (let* ((gc-root (string-append target %gc-roots-directory + "/bootcfg")) + (temp-gc-root (string-append gc-root ".new")) + (install (and installer-drv + (derivation->output-path installer-drv))) + (bootcfg (derivation->output-path bootcfg))) + ;; Prepare the symlink to bootloader config file to make sure that it's + ;; a GC root when 'installer-drv' completes (being a bit paranoid.) + (switch-symlinks temp-gc-root bootcfg) + + (unless (false-if-exception + (begin + (install-boot-config bootcfg bootcfg-file target) + (when install + (save-load-path-excursion (primitive-load install))))) (delete-file temp-gc-root) - (leave (_ "failed to install GRUB on device '~a'~%") device)) + (leave (G_ "failed to install bootloader on device ~a '~a'~%") install device)) - ;; Register GRUB.CFG as a GC root so that its dependencies (background - ;; image, font, etc.) are not reclaimed. - (rename temp-gc-root gc-root)))) + ;; Register bootloader config file as a GC root so that its dependencies + ;; (background image, font, etc.) are not reclaimed. + (rename-file temp-gc-root gc-root) + (return #t)))) (define* (install os-drv target #:key (log-port (current-output-port)) - grub? grub.cfg device) - "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to + bootloader-installer install-bootloader? + bootcfg bootcfg-file + device) + "Copy the closure of BOOTCFG, 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." +When INSTALL-BOOTLOADER? is true, install bootloader on DEVICE, using BOOTCFG." (define (maybe-copy to-copy) (with-monad %store-monad (if (string=? target "/") (begin - (warning (_ "initializing the current root file system~%")) + (warning (G_ "initializing the current root file system~%")) (return #t)) (begin ;; Make sure the target store exists. @@ -171,7 +204,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>. (if (zero? (geteuid)) (chown target 0 0) - (warning (_ "not running as 'root', so \ + (warning (G_ "not running as 'root', so \ the ownership of '~a' may be incorrect!~%") target)) @@ -181,16 +214,21 @@ the ownership of '~a' may be incorrect!~%") (populate (lift2 populate-root-file-system %store-monad))) (mbegin %store-monad - ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's - ;; background image and so on. - (maybe-copy grub.cfg) + ;; Copy the closure of BOOTCFG, which includes OS-DIR, + ;; eventual background image and so on. + (maybe-copy + (derivation->output-path bootcfg)) ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) (populate os-dir target) - (mwhen grub? - (install-grub* grub.cfg device target))))) + (mwhen install-bootloader? + (install-bootloader bootloader-installer + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:device device + #:target target))))) ;;; @@ -201,29 +239,6 @@ the ownership of '~a' may be incorrect!~%") ;; The system profile. (string-append %state-directory "/profiles/system")) -(define-syntax-rule (save-environment-excursion body ...) - "Save the current environment variables, run BODY..., and restore them." - (let ((env (environ))) - (dynamic-wind - (const #t) - (lambda () - body ...) - (lambda () - (environ env))))) - -(define-syntax-rule (save-load-path-excursion body ...) - "Save the current values of '%load-path' and '%load-compiled-path', run -BODY..., and restore them." - (let ((path %load-path) - (cpath %load-compiled-path)) - (dynamic-wind - (const #t) - (lambda () - body ...) - (lambda () - (set! %load-path path) - (set! %load-compiled-path cpath))))) - (define-syntax-rule (with-shepherd-error-handling mbody ...) "Catch and report Shepherd errors that arise when binding MBODY, a monadic expression in %STORE-MONAD." @@ -235,21 +250,21 @@ expression in %STORE-MONAD." (values (run-with-store store (begin mbody ...)) store))) (lambda (key proc format-string format-args errno . rest) - (warning (_ "while talking to shepherd: ~a~%") + (warning (G_ "while talking to shepherd: ~a~%") (apply format #f format-string format-args)) (values #f store))))) (define (report-shepherd-error error) "Report ERROR, a '&shepherd-error' error condition object." (cond ((service-not-found-error? error) - (report-error (_ "service '~a' could not be found~%") + (report-error (G_ "service '~a' could not be found~%") (service-not-found-error-service error))) ((action-not-found-error? error) - (report-error (_ "service '~a' does not have an action '~a'~%") + (report-error (G_ "service '~a' does not have an action '~a'~%") (action-not-found-error-service error) (action-not-found-error-action error))) ((action-exception-error? error) - (report-error (_ "exception caught while executing '~a' \ + (report-error (G_ "exception caught while executing '~a' \ on service '~a':~%") (action-exception-error-action error) (action-exception-error-service error)) @@ -257,10 +272,10 @@ on service '~a':~%") (action-exception-error-key error) (action-exception-error-arguments error))) ((unknown-shepherd-error? error) - (report-error (_ "something went wrong: ~s~%") + (report-error (G_ "something went wrong: ~s~%") (unknown-shepherd-error-sexp error))) ((shepherd-error? error) - (report-error (_ "shepherd error~%"))) + (report-error (G_ "shepherd error~%"))) ((not error) ;not an error #t))) @@ -277,7 +292,7 @@ unload." to-unload)))) (#f (with-monad %store-monad - (warning (_ "failed to obtain list of shepherd services~%")) + (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) (define (upgrade-shepherd-services os) @@ -288,7 +303,7 @@ This is currently very conservative in that it does not stop or unload any running service. Unloading or stopping the wrong service ('udev', say) could bring the system down." (define new-services - (service-parameters + (service-value (fold-services (operating-system-services os) #:target-type shepherd-root-service-type))) @@ -297,7 +312,7 @@ bring the system down." (call-with-service-upgrade-info new-services (lambda (to-load to-unload) (for-each (lambda (unload) - (info (_ "unloading service '~a'...~%") unload) + (info (G_ "unloading service '~a'...~%") unload) (unload-service unload)) to-unload) @@ -305,7 +320,7 @@ bring the system down." (munless (null? to-load) (let ((to-load-names (map shepherd-service-canonical-name to-load)) (to-start (filter shepherd-service-auto-start? to-load))) - (info (_ "loading new services:~{ ~a~}...~%") to-load-names) + (info (G_ "loading new services:~{ ~a~}...~%") to-load-names) (mlet %store-monad ((files (mapm %store-monad shepherd-service-file to-load))) ;; Here we assume that FILES are exactly those that were computed @@ -329,7 +344,7 @@ it atomically, and then run OS's activation script." (switch-symlinks generation system) (switch-symlinks profile generation) - (format #t (_ "activating system...~%")) + (format #t (G_ "activating system...~%")) ;; The activation script may change $PATH, among others, so protect ;; against that. @@ -362,44 +377,26 @@ it atomically, and then run OS's activation script." (date->string (time-utc->date time) "~Y-~m-~d ~H:~M"))) -(define* (profile-grub-entries #:optional (profile %system-profile) +(define* (profile-boot-parameters #:optional (profile %system-profile) (numbers (generation-numbers profile))) - "Return a list of 'menu-entry' for the generations of PROFILE specified by + "Return a list of 'boot-parameters' for the generations of PROFILE specified by NUMBERS, which is a list of generation numbers." - (define (system->grub-entry system number time) + (define (system->boot-parameters system number time) (unless-file-not-found - (let* ((file (string-append system "/parameters")) - (params (call-with-input-file file - read-boot-parameters)) - (label (boot-parameters-label params)) - (root (boot-parameters-root-device params)) - (root-device (if (bytevector? root) - (uuid->string root) - root)) - (kernel (boot-parameters-kernel params)) - (kernel-arguments (boot-parameters-kernel-arguments params)) - (initrd (boot-parameters-initrd params))) - (menu-entry - (label (string-append label " (#" - (number->string number) ", " - (seconds->string time) ")")) - (device (boot-parameters-store-device params)) - (device-mount-point (boot-parameters-store-mount-point params)) - (linux kernel) - (linux-arguments - (cons* (string-append "--root=" root-device) - (string-append "--system=" system) - (string-append "--load=" system "/boot") - kernel-arguments)) - (initrd initrd))))) - + (let* ((params (read-boot-parameters-file system)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label (string-append label " (#" + (number->string number) ", " + (seconds->string time) ")")))))) (let* ((systems (map (cut generation-file-name profile <>) numbers)) (times (map (lambda (system) (unless-file-not-found (stat:mtime (lstat system)))) systems))) - (filter-map system->grub-entry systems numbers times))) + (filter-map system->boot-parameters systems numbers times))) ;;; @@ -415,50 +412,58 @@ connection to the store." ;;; (define (switch-to-system-generation store spec) "Switch the system profile to the generation specified by SPEC, and -re-install grub with a grub configuration file that uses the specified system +re-install bootloader with a configuration file that uses the specified system generation as its default entry. STORE is an open connection to the store." (let ((number (relative-generation-spec->number %system-profile spec))) (if number (begin - (reinstall-grub store number) + (reinstall-bootloader store number) (switch-to-generation* %system-profile number)) - (leave (_ "cannot switch to system generation '~a'~%") spec)))) + (leave (G_ "cannot switch to system generation '~a'~%") spec)))) + +(define* (system-bootloader-name #:optional (system %system-profile)) + "Return the bootloader name stored in SYSTEM's \"parameters\" file." + (let ((params (unless-file-not-found + (read-boot-parameters-file system)))) + (boot-parameters-boot-name params))) -(define (reinstall-grub store number) - "Re-install grub for existing system profile generation NUMBER. STORE is an -open connection to the store." +(define (reinstall-bootloader store number) + "Re-install bootloader for existing system profile generation NUMBER. +STORE is an open connection to the store." (let* ((generation (generation-file-name %system-profile number)) - (file (string-append generation "/parameters")) (params (unless-file-not-found - (call-with-input-file file read-boot-parameters))) - (root-device (boot-parameters-root-device params)) - ;; We don't currently keep track of past menu entries' details. The - ;; default values will allow the system to boot, even if they differ - ;; from the actual past values for this generation's entry. - (grub-config (grub-configuration (device root-device))) + (read-boot-parameters-file generation))) + ;; Detect the bootloader used in %system-profile. + (bootloader (lookup-bootloader-by-name (system-bootloader-name))) + + ;; Use the detected bootloader with default configuration. + ;; It will be enough to allow the system to boot. + (bootloader-config (bootloader-configuration + (bootloader bootloader))) + ;; Make the specified system generation the default entry. - (entries (profile-grub-entries %system-profile (list number))) + (entries (profile-boot-parameters %system-profile (list number))) (old-generations (delv number (generation-numbers %system-profile))) - (old-entries (profile-grub-entries %system-profile old-generations)) - (grub.cfg (run-with-store store - (grub-configuration-file grub-config - entries - #:old-entries old-entries)))) - (show-what-to-build store (list grub.cfg)) - (build-derivations store (list grub.cfg)) - ;; This is basically the same as install-grub*, but for now we avoid - ;; re-installing the GRUB boot loader itself onto a device, mainly because - ;; we don't in general have access to the same version of the GRUB package - ;; which was used when installing this other system generation. - (let* ((grub.cfg-path (derivation->output-path grub.cfg)) - (gc-root (string-append %gc-roots-directory "/grub.cfg")) - (temp-gc-root (string-append gc-root ".new"))) - (switch-symlinks temp-gc-root grub.cfg-path) - (unless (false-if-exception (install-grub-config grub.cfg-path "/")) - (delete-file temp-gc-root) - (leave (_ "failed to re-install GRUB configuration file: '~a'~%") - grub.cfg-path)) - (rename-file temp-gc-root gc-root)))) + (old-entries (profile-boot-parameters + %system-profile old-generations))) + (run-with-store store + (mlet* %store-monad + ((bootcfg ((bootloader-configuration-file-generator bootloader) + bootloader-config entries + #:old-entries old-entries)) + (bootcfg-file -> (bootloader-configuration-file bootloader)) + (target -> "/") + (drvs -> (list bootcfg))) + (mbegin %store-monad + (show-what-to-build* drvs) + (built-derivations drvs) + ;; Only install bootloader configuration file. Thus, no installer + ;; nor device is provided here. + (install-bootloader #f + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:device #f + #:target target)))))) ;;; @@ -468,7 +473,7 @@ open connection to the store." (define (service-node-label service) "Return a label to represent SERVICE." (let ((type (service-kind service)) - (value (service-parameters service))) + (value (service-value service))) (string-append (symbol->string (service-type-name type)) (cond ((or (number? value) (symbol? value)) (string-append " " (object->string value))) @@ -514,21 +519,22 @@ list of services." "Display a summary of system generation NUMBER in a human-readable format." (unless (zero? number) (let* ((generation (generation-file-name profile number)) - (param-file (string-append generation "/parameters")) - (params (call-with-input-file param-file read-boot-parameters)) + (params (read-boot-parameters-file generation)) (label (boot-parameters-label params)) + (boot-name (boot-parameters-boot-name params)) (root (boot-parameters-root-device params)) (root-device (if (bytevector? root) (uuid->string root) root)) (kernel (boot-parameters-kernel params))) (display-generation profile number) - (format #t (_ " file name: ~a~%") generation) - (format #t (_ " canonical file name: ~a~%") (readlink* generation)) + (format #t (G_ " file name: ~a~%") generation) + (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) ;; TRANSLATORS: Please preserve the two-space indentation. - (format #t (_ " label: ~a~%") label) - (format #t (_ " root device: ~a~%") root-device) - (format #t (_ " kernel: ~a~%") kernel)))) + (format #t (G_ " label: ~a~%") label) + (format #t (G_ " bootloader: ~a~%") boot-name) + (format #t (G_ " root device: ~a~%") root-device) + (format #t (G_ " kernel: ~a~%") kernel)))) (define* (list-generations pattern #:optional (profile %system-profile)) "Display in a human-readable format all the system generations matching @@ -546,7 +552,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (leave-on-EPIPE (for-each display-system-generation numbers))))) (else - (leave (_ "invalid syntax: ~a~%") pattern)))) + (leave (G_ "invalid syntax: ~a~%") pattern)))) ;;; @@ -569,7 +575,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." #:disk-image-size (if full-boot? image-size - (* 30 (expt 2 20))) + (* 70 (expt 2 20))) #:mappings mappings)) ((disk-image) (system-disk-image os #:disk-image-size image-size)))) @@ -585,23 +591,39 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (string-append (config-directory) "/latest")) (unless (file-exists? latest) - (warning (_ "~a not found: 'guix pull' was never run~%") latest) - (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%")) - (warning (_ "Failing to do that may downgrade your system!~%")))) + (warning (G_ "~a not found: 'guix pull' was never run~%") latest) + (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) + (warning (G_ "Failing to do that may downgrade your system!~%")))) + +(define (bootloader-installer-derivation installer + bootloader device target) + "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE +and TARGET arguments." + (with-monad %store-monad + (gexp->file "bootloader-installer" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (#$installer #$bootloader #$device #$target)))))) (define* (perform-action action os - #:key grub? dry-run? derivations-only? + #:key install-bootloader? + dry-run? derivations-only? use-substitutes? device target image-size full-boot? - (mappings '())) - "Perform ACTION for OS. GRUB? specifies whether to install GRUB; DEVICE is -the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE -is the size of the image to be built, for the 'vm-image' and 'disk-image' -actions. FULL-BOOT? is used for the 'vm' action; it determines whether to -boot directly to the kernel or to the bootloader. + (mappings '()) + (gc-root #f)) + "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install +bootloader; DEVICE is the target devices for bootloader; TARGET is the target +root directory; IMAGE-SIZE is the size of the image to be built, for the +'vm-image' and 'disk-image' actions. FULL-BOOT? is used for the 'vm' action; +it determines whether to boot directly to the kernel or to the bootloader. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without -building anything." +building anything. + +When GC-ROOT is a path, also make that path an indirect root of the build +output when building a system derivation, such as a disk image." (define println (cut format #t "~a~%" <>)) @@ -613,22 +635,37 @@ building anything." #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) - (grub (package->derivation (grub-configuration-grub - (operating-system-bootloader os)))) - (grub.cfg (if (eq? 'container action) - (return #f) - (operating-system-grub.cfg os - (if (eq? 'init action) - '() - (profile-grub-entries))))) - - ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if - ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC - ;; root. See <http://bugs.gnu.org/21068>. + (bootloader -> (bootloader-configuration-bootloader + (operating-system-bootloader os))) + (bootloader-package + (let ((package (bootloader-package bootloader))) + (if package + (package->derivation package) + (return #f)))) + (bootcfg (if (eq? 'container action) + (return #f) + (operating-system-bootcfg + os + (if (eq? 'init action) + '() + (profile-boot-parameters))))) + (bootcfg-file -> (bootloader-configuration-file bootloader)) + (bootloader-installer + (let ((installer (bootloader-installer bootloader)) + (target (or target "/"))) + (bootloader-installer-derivation installer + bootloader-package + device target))) + + ;; For 'init' and 'reconfigure', always build BOOTCFG, even if + ;; --no-bootloader is passed, because we then use it as a GC root. + ;; See <http://bugs.gnu.org/21068>. (drvs -> (if (memq action '(init reconfigure)) - (if grub? - (list sys grub.cfg grub) - (list sys grub.cfg)) + (if (and install-bootloader? bootloader-package) + (list sys bootcfg + bootloader-package + bootloader-installer) + (list sys bootcfg)) (list sys))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) @@ -642,31 +679,34 @@ building anything." (for-each (compose println derivation->output-path) drvs) - ;; Make sure GRUB is accessible. - (when grub? - (let ((prefix (derivation->output-path grub))) - (setenv "PATH" - (string-append prefix "/bin:" prefix "/sbin:" - (getenv "PATH"))))) - (case action ((reconfigure) (mbegin %store-monad (switch-to-system os) - (mwhen grub? - (install-grub* (derivation->output-path grub.cfg) - device "/")))) + (mwhen install-bootloader? + (install-bootloader bootloader-installer + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:device device + #:target "/")))) ((init) (newline) - (format #t (_ "initializing operating system under '~a'...~%") + (format #t (G_ "initializing operating system under '~a'...~%") target) (install sys (canonicalize-path target) - #:grub? grub? - #:grub.cfg (derivation->output-path grub.cfg) + #:install-bootloader? install-bootloader? + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:bootloader-installer bootloader-installer #:device device)) (else - ;; All we had to do was to build SYS. - (return (derivation->output-path sys)))))))) + ;; All we had to do was to build SYS and maybe register an + ;; indirect GC root. + (let ((output (derivation->output-path sys))) + (mbegin %store-monad + (mwhen gc-root + (register-root* (list output) gc-root)) + (return output))))))))) (define (export-extension-graph os port) "Export the service extension graph of OS to PORT." @@ -683,7 +723,7 @@ building anything." (let* ((services (operating-system-services os)) (pid1 (fold-services services #:target-type shepherd-root-service-type)) - (shepherds (service-parameters pid1)) ;list of <shepherd-service> + (shepherds (service-value pid1)) ;list of <shepherd-service> (sinks (filter (lambda (service) (null? (shepherd-service-requirement service))) shepherds))) @@ -697,57 +737,61 @@ building anything." ;;; (define (show-help) - (display (_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] + (display (G_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] Build the operating system declared in FILE according to ACTION. Some ACTIONS support additional ARGS.\n")) (newline) - (display (_ "The valid values for ACTION are:\n")) + (display (G_ "The valid values for ACTION are:\n")) (newline) - (display (_ "\ + (display (G_ "\ reconfigure switch to a new operating system configuration\n")) - (display (_ "\ + (display (G_ "\ roll-back switch to the previous operating system configuration\n")) - (display (_ "\ + (display (G_ "\ switch-generation switch to an existing operating system configuration\n")) - (display (_ "\ + (display (G_ "\ list-generations list the system generations\n")) - (display (_ "\ + (display (G_ "\ build build the operating system without installing anything\n")) - (display (_ "\ + (display (G_ "\ container build a container that shares the host's store\n")) - (display (_ "\ + (display (G_ "\ vm build a virtual machine image that shares the host's store\n")) - (display (_ "\ + (display (G_ "\ vm-image build a freestanding virtual machine image\n")) - (display (_ "\ + (display (G_ "\ disk-image build a disk image, suitable for a USB stick\n")) - (display (_ "\ + (display (G_ "\ init initialize a root file system to run GNU\n")) - (display (_ "\ + (display (G_ "\ extension-graph emit the service extension graph in Dot format\n")) - (display (_ "\ + (display (G_ "\ shepherd-graph emit the graph of shepherd services in Dot format\n")) (show-build-options-help) - (display (_ " + (display (G_ " -d, --derivation return the derivation of the given system")) - (display (_ " + (display (G_ " --on-error=STRATEGY apply STRATEGY when an error occurs while reading FILE")) - (display (_ " + (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) - (display (_ " - --no-grub for 'init', do not install GRUB")) - (display (_ " + (display (G_ " + --no-bootloader for 'init', do not install a bootloader")) + (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) - (display (_ " + (display (G_ " + -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', + and 'build', make FILE a symlink to the result, and + register it as a garbage collector root")) + (display (G_ " --expose=SPEC for 'vm', expose host file system according to SPEC")) - (display (_ " + (display (G_ " --full-boot for 'vm', make a full boot sequence")) (newline) - (display (_ " + (display (G_ " -h, --help display this help and exit")) - (display (_ " + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -772,9 +816,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) result))) - (option '("no-grub") #f #f + (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) - (alist-cons 'install-grub? #f result))) + (alist-cons 'install-bootloader? #f result))) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) @@ -797,6 +841,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) %standard-build-options)) (define %default-options @@ -808,7 +855,7 @@ Some ACTIONS support additional ARGS.\n")) (max-silent-time . 3600) (verbosity . 0) (image-size . ,(* 900 (expt 2 20))) - (install-grub? . #t))) + (install-bootloader? . #t))) ;;; @@ -820,23 +867,23 @@ Some ACTIONS support additional ARGS.\n")) ACTION must be one of the sub-commands that takes an operating system declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." - (let* ((file (match args - (() #f) - ((x . _) x))) - (system (assoc-ref opts 'system)) - (os (if file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error)) - (leave (_ "no configuration file specified~%")))) - - (dry? (assoc-ref opts 'dry-run?)) - (grub? (assoc-ref opts 'install-grub?)) - (target (match args - ((first second) second) - (_ #f))) - (device (and grub? - (grub-configuration-device - (operating-system-bootloader os))))) + (let* ((file (match args + (() #f) + ((x . _) x))) + (system (assoc-ref opts 'system)) + (os (if file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error)) + (leave (G_ "no configuration file specified~%")))) + + (dry? (assoc-ref opts 'dry-run?)) + (bootloader? (assoc-ref opts 'install-bootloader?)) + (target (match args + ((first second) second) + (_ #f))) + (device (and bootloader? + (bootloader-configuration-device + (operating-system-bootloader os))))) (with-store store (set-build-options-from-command-line store opts) @@ -850,6 +897,10 @@ resulting from command-line parsing." ((shepherd-graph) (export-shepherd-graph os (current-output-port))) (else + (unless (memq action '(build init)) + (warn-about-old-distro #:suggested-command + "guix system reconfigure")) + (perform-action action os #:dry-run? dry? #:derivations-only? (assoc-ref opts @@ -862,8 +913,9 @@ resulting from command-line parsing." m) (_ #f)) opts) - #:grub? grub? - #:target target #:device device)))) + #:install-bootloader? bootloader? + #:target target #:device device + #:gc-root (assoc-ref opts 'gc-root))))) #:system system)))) (define (process-command command args opts) @@ -876,21 +928,21 @@ argument list and OPTS is the option alist." (let ((pattern (match args (() "") ((pattern) pattern) - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (list-generations pattern))) ;; The following commands need to use the store, but they do not need an ;; operating system configuration file. ((switch-generation) (let ((pattern (match args ((pattern) pattern) - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (with-store store (set-build-options-from-command-line store opts) (switch-to-system-generation store pattern)))) ((roll-back) (let ((pattern (match args (() "") - (x (leave (_ "wrong number of arguments~%")))))) + (x (leave (G_ "wrong number of arguments~%")))))) (with-store store (set-build-options-from-command-line store opts) (roll-back-system store)))) @@ -909,7 +961,7 @@ argument list and OPTS is the option alist." extension-graph shepherd-graph list-generations roll-back switch-generation) (alist-cons 'action action result)) - (else (leave (_ "~a: unknown action~%") action)))))) + (else (leave (G_ "~a: unknown action~%") action)))))) (define (match-pair car) ;; Return a procedure that matches a pair with CAR. @@ -924,14 +976,14 @@ argument list and OPTS is the option alist." (count (length args)) (action (assoc-ref opts 'action))) (define (fail) - (leave (_ "wrong number of arguments for action '~a'~%") + (leave (G_ "wrong number of arguments for action '~a'~%") action)) (unless action (format (current-error-port) - (_ "guix system: missing command name~%")) + (G_ "guix system: missing command name~%")) (format (current-error-port) - (_ "Try 'guix system --help' for more information.~%")) + (G_ "Try 'guix system --help' for more information.~%")) (exit 1)) (case action diff --git a/guix/serialization.scm b/guix/serialization.scm index 4a8cd2086e..e6ae2fc307 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -214,9 +214,8 @@ substitute invalid byte sequences with question marks. This is a (write-string "contents" p) (write-long-long size p) (call-with-binary-input-file file - ;; Use `sendfile' when available (Guile 2.0.8+). - (if (and (compile-time-value (defined? 'sendfile)) - (file-port? p)) + ;; Use 'sendfile' when P is a file port. + (if (file-port? p) (cut sendfile p <> size 0) (cut dump <> p size))) (write-padding size p)) diff --git a/guix/ssh.scm b/guix/ssh.scm index 3548243839..4fb145230d 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +18,10 @@ (define-module (guix ssh) #:use-module (guix store) - #:autoload (guix ui) (N_) + #:use-module ((guix ui) #:select (G_ N_)) + #:use-module (ssh session) + #:use-module (ssh auth) + #:use-module (ssh key) #:use-module (ssh channel) #:use-module (ssh popen) #:use-module (ssh session) @@ -29,7 +32,9 @@ #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) - #:export (connect-to-remote-daemon + #:export (open-ssh-session + remote-daemon-channel + connect-to-remote-daemon send-files retrieve-files remote-store-host @@ -43,11 +48,52 @@ ;;; ;;; Code: -(define* (connect-to-remote-daemon session - #:optional - (socket-name "/var/guix/daemon-socket/socket")) - "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, -an SSH session. Return a <nix-server> object." +(define %compression + "zlib@openssh.com,zlib") + +(define* (open-ssh-session host #:key user port + (compression %compression)) + "Open an SSH session for HOST and return it. When USER and PORT are #f, use +default values or whatever '~/.ssh/config' specifies; otherwise use them. +Throw an error on failure." + (let ((session (make-session #:user user + #:host host + #:port port + #:timeout 10 ;seconds + ;; #:log-verbosity 'protocol + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression compression + #:compression-level 3))) + + ;; Honor ~/.ssh/config. + (session-parse-config! session) + + (match (connect! session) + ('ok + ;; Use public key authentication, via the SSH agent if it's available. + (match (userauth-public-key/auto! session) + ('success + session) + (x + (disconnect! session) + (raise (condition + (&message + (message (format #f (G_ "SSH authentication failed for '~a': ~a~%") + host (get-error session))))))))) + (x + ;; Connection failed or timeout expired. + (raise (condition + (&message + (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") + host (get-error session)))))))))) + +(define* (remote-daemon-channel session + #:optional + (socket-name + "/var/guix/daemon-socket/socket")) + "Return an input/output port (an SSH channel) to the daemon at SESSION." (define redirect ;; Code run in SESSION to redirect the remote process' stdin/stdout to the ;; daemon's socket, à la socat. The SSH protocol supports forwarding to @@ -82,13 +128,20 @@ an SSH session. Return a <nix-server> object." (_ (primitive-exit 1))))))) - (let ((channel - (open-remote-pipe* session OPEN_BOTH - ;; Sort-of shell-quote REDIRECT. - "guile" "-c" - (object->string - (object->string redirect))))) - (open-connection #:port channel))) + (open-remote-pipe* session OPEN_BOTH + ;; Sort-of shell-quote REDIRECT. + "guile" "-c" + (object->string + (object->string redirect)))) + +(define* (connect-to-remote-daemon session + #:optional + (socket-name + "/var/guix/daemon-socket/socket")) + "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, +an SSH session. Return a <nix-server> object." + (open-connection #:port (remote-daemon-channel session))) + (define (store-import-channel session) "Return an output port to which archives to be exported to SESSION's store @@ -216,7 +269,7 @@ LOCAL. When RECURSIVE? is true, retrieve the closure of FILES." (&message (message (format #f - (_ "failed to retrieve store items from '~a'") + (G_ "failed to retrieve store items from '~a'") (remote-store-host remote))))))) (let ((result (import-paths local port))) diff --git a/guix/store.scm b/guix/store.scm index 2f05351767..c94dfea959 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -23,7 +23,8 @@ #:use-module (guix serialization) #:use-module (guix monads) #:use-module (guix base16) - #:autoload (guix base32) (bytevector->base32-string) + #:use-module (guix base32) + #:use-module (guix hash) #:autoload (guix build syscalls) (terminal-columns) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) @@ -39,7 +40,8 @@ #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 popen) - #:export (%daemon-socket-file + #:use-module (web uri) + #:export (%daemon-socket-uri %gc-roots-directory %default-substitute-urls @@ -132,6 +134,9 @@ interned-file %store-prefix + store-path + output-path + fixed-output-path store-path? direct-store-path? derivation-path? @@ -216,8 +221,8 @@ (define %default-socket-path (string-append %state-directory "/daemon-socket/socket")) -(define %daemon-socket-file - ;; File name of the socket the daemon listens too. +(define %daemon-socket-uri + ;; URI or file name of the socket the daemon listens too. (make-parameter (or (getenv "GUIX_DAEMON_SOCKET") %default-socket-path))) @@ -350,6 +355,18 @@ (message nix-protocol-error-message) (status nix-protocol-error-status)) +(define-syntax-rule (system-error-to-connection-error file exp ...) + "Catch 'system-error' exceptions and translate them to +'&nix-connection-error'." + (catch 'system-error + (lambda () + exp ...) + (lambda args + (let ((errno (system-error-errno args))) + (raise (condition (&nix-connection-error + (file file) + (errno errno)))))))) + (define (open-unix-domain-socket file) "Connect to the Unix-domain socket at FILE and return it. Raise a '&nix-connection-error' upon error." @@ -358,21 +375,99 @@ (socket PF_UNIX SOCK_STREAM 0))) (a (make-socket-address PF_UNIX file))) - (catch 'system-error - (lambda () - (connect s a) - s) - (lambda args - ;; Translate the error to something user-friendly. - (let ((errno (system-error-errno args))) - (raise (condition (&nix-connection-error - (file file) - (errno errno))))))))) + (system-error-to-connection-error file + (connect s a) + s))) -(define* (open-connection #:optional (file (%daemon-socket-file)) +(define (open-inet-socket host port) + "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a +'&nix-connection-error' upon error." + ;; Define 'TCP_NODELAY' on Guile 2.0. The value is the same on all GNU + ;; systems. + (cond-expand (guile-2.2 #t) + (else (define TCP_NODELAY 1))) + + (let ((sock (with-fluids ((%default-port-encoding #f)) + ;; This trick allows use of the `scm_c_read' optimization. + (socket PF_UNIX SOCK_STREAM 0)))) + (define addresses + (getaddrinfo host + (if (number? port) (number->string port) port) + (if (number? port) + (logior AI_ADDRCONFIG AI_NUMERICSERV) + AI_ADDRCONFIG))) + + (let loop ((addresses addresses)) + (match addresses + ((ai rest ...) + (let ((s (socket (addrinfo:fam ai) + ;; TCP/IP only + SOCK_STREAM IPPROTO_IP))) + + (catch 'system-error + (lambda () + (connect s (addrinfo:addr ai)) + + ;; Setting this option makes a dramatic difference because it + ;; avoids the "ACK delay" on our RPC messages. + (setsockopt s IPPROTO_TCP TCP_NODELAY 1) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? rest) + (raise (condition (&nix-connection-error + (file host) + (errno (system-error-errno args))))) + (loop rest)))))))))) + +(define (connect-to-daemon uri) + "Connect to the daemon at URI, a string that may be an actual URI or a file +name." + (define (not-supported) + (raise (condition (&nix-connection-error + (file uri) + (errno ENOTSUP))))) + + (define connect + (match (string->uri uri) + (#f ;URI is a file name + open-unix-domain-socket) + ((? uri? uri) + (match (uri-scheme uri) + ((or #f 'file 'unix) + (lambda (_) + (open-unix-domain-socket (uri-path uri)))) + ('guix + (lambda (_) + (unless (uri-port uri) + (raise (condition (&nix-connection-error + (file (uri->string uri)) + (errno EBADR))))) ;bah! + + (open-inet-socket (uri-host uri) (uri-port uri)))) + ((? symbol? scheme) + ;; Try to dynamically load a module for SCHEME. + ;; XXX: Errors are swallowed. + (match (false-if-exception + (resolve-interface `(guix store ,scheme))) + ((? module? module) + (match (false-if-exception + (module-ref module 'connect-to-daemon)) + ((? procedure? connect) + (lambda (_) + (connect uri))) + (x (not-supported)))) + (#f (not-supported)))) + (x + (not-supported)))))) + + (connect uri)) + +(define* (open-connection #:optional (uri (%daemon-socket-uri)) #:key port (reserve-space? #t) cpu-affinity) - "Connect to the daemon over the Unix-domain socket at FILE, or, if PORT is -not #f, use it as the I/O port over which to communicate to a build daemon. + "Connect to the daemon at URI (a string), or, if PORT is not #f, use it as +the I/O port over which to communicate to a build daemon. When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on the file system so that the garbage collector can still operate, @@ -383,10 +478,10 @@ for this connection will be pinned. Return a server object." ;; One of the 'write-' or 'read-' calls below failed, but this is ;; really a connection error. (raise (condition - (&nix-connection-error (file (or port file)) + (&nix-connection-error (file (or port uri)) (errno EPROTO)) (&message (message "build daemon handshake failed")))))) - (let ((port (or port (open-unix-domain-socket file)))) + (let ((port (or port (connect-to-daemon uri)))) (write-int %worker-magic-1 port) (let ((r (read-int port))) (and (eqv? r %worker-magic-2) @@ -495,9 +590,7 @@ encoding conversion errors." (let* ((max-len (read-int p)) (data (make-bytevector max-len)) (len (get-bytevector-n! user-port data 0 max-len))) - (write-int len p) - (put-bytevector p data 0 len) - (write-padding len p) + (write-bytevector data p) #f)) ((= k %stderr-next) ;; Log a string. Build logs are usually UTF-8-encoded, but they @@ -1155,6 +1248,10 @@ be used internally by the daemon's build hook." (define-alias store-return state-return) (define-alias store-bind state-bind) +;; Instantiate templates for %STORE-MONAD since it's syntactically different +;; from %STATE-MONAD. +(template-directory instantiations %store-monad) + (define (preserve-documentation original proc) "Return PROC with documentation taken from ORIGINAL." (set-object-property! proc 'documentation @@ -1261,6 +1358,57 @@ connection, and return the result." ;; Absolute path to the Nix store. (make-parameter %store-directory)) +(define (compressed-hash bv size) ; `compressHash' + "Given the hash stored in BV, return a compressed version thereof that fits +in SIZE bytes." + (define new (make-bytevector size 0)) + (define old-size (bytevector-length bv)) + (let loop ((i 0)) + (if (= i old-size) + new + (let* ((j (modulo i size)) + (o (bytevector-u8-ref new j))) + (bytevector-u8-set! new j + (logxor o (bytevector-u8-ref bv i))) + (loop (+ 1 i)))))) + +(define (store-path type hash name) ; makeStorePath + "Return the store path for NAME/HASH/TYPE." + (let* ((s (string-append type ":sha256:" + (bytevector->base16-string hash) ":" + (%store-prefix) ":" name)) + (h (sha256 (string->utf8 s))) + (c (compressed-hash h 20))) + (string-append (%store-prefix) "/" + (bytevector->nix-base32-string c) "-" + name))) + +(define (output-path output hash name) ; makeOutputPath + "Return an output path for OUTPUT (the name of the output as a string) of +the derivation called NAME with hash HASH." + (store-path (string-append "output:" output) hash + (if (string=? output "out") + name + (string-append name "-" output)))) + +(define* (fixed-output-path name hash + #:key + (output "out") + (hash-algo 'sha256) + (recursive? #t)) + "Return an output path for the fixed output OUTPUT defined by HASH of type +HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for +'add-to-store'." + (if (and recursive? (eq? hash-algo 'sha256)) + (store-path "source" hash name) + (let ((tag (string-append "fixed:" output ":" + (if recursive? "r:" "") + (symbol->string hash-algo) ":" + (bytevector->base16-string hash) ":"))) + (store-path (string-append "output:" output) + (sha256 (string->utf8 tag)) + name)))) + (define (store-path? path) "Return #t if PATH is a store path." ;; This is a lightweight check, compared to using a regexp, but this has to @@ -1330,3 +1478,7 @@ must be an absolute store file name, or a derivation file name." ;; Return the first that works. (any (cut log-file store <>) derivers)) (_ #f))))) + +;;; Local Variables: +;;; eval: (put 'system-error-to-connection-error 'scheme-indent-function 1) +;;; End: diff --git a/guix/store/ssh.scm b/guix/store/ssh.scm new file mode 100644 index 0000000000..09c0832505 --- /dev/null +++ b/guix/store/ssh.scm @@ -0,0 +1,39 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix store ssh) + #:use-module (guix ssh) + #:use-module (web uri) + #:export (connect-to-daemon)) + +;;; Commentary: +;;; +;;; This modules provides the entry point for 'open-connection' in (guix +;;; store). Passing an 'ssh://' URI to 'open-connection' triggers the use of +;;; the code in this module. +;;; +;;; End: + +(define (connect-to-daemon uri) + "Connect to the SSH daemon at URI, a URI object with the 'ssh' scheme." + (remote-daemon-channel + (open-ssh-session (uri-host uri) + #:port (or (uri-port uri) 22) + #:user (uri-userinfo uri)))) + +;;; ssh.scm ends here diff --git a/guix/tests.scm b/guix/tests.scm index 5110075e7d..34e3e0fc2a 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,13 +56,13 @@ (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list) '()))) -(define* (open-connection-for-tests #:optional (file (%daemon-socket-file))) +(define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri))) "Open a connection to the build daemon for tests purposes and return it." (guard (c ((nix-error? c) (format (current-error-port) "warning: build daemon error: ~s~%" c) #f)) - (let ((store (open-connection file))) + (let ((store (open-connection uri))) ;; Make sure we build everything by ourselves. (set-build-options store #:use-substitutes? #f diff --git a/guix/ui.scm b/guix/ui.scm index 345bf490b2..9e0fa26d19 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -26,6 +26,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix ui) + #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) #:use-module (guix config) @@ -54,7 +55,7 @@ #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) - #:export (_ + #:export (G_ N_ P_ report-error @@ -116,7 +117,7 @@ ;; Text domain for package synopses and descriptions. "guix-packages") -(define _ (cut gettext <> %gettext-domain)) +(define G_ (cut gettext <> %gettext-domain)) (define N_ (cut ngettext <> <> <> %gettext-domain)) (define (P_ msgid) @@ -139,7 +140,7 @@ messages." (syntax-case x () ((name (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) - (free-identifier=? #'underscore #'_)) + (free-identifier=? #'underscore #'G_)) (with-syntax ((fmt* (augmented-format-string #'fmt)) (prefix (datum->syntax x prefix))) #'(format (guix-warning-port) (gettext fmt*) @@ -237,7 +238,7 @@ messages." (case on-error ((debug) (newline) - (display (_ "entering debugger; type ',bt' for a backtrace\n")) + (display (G_ "entering debugger; type ',bt' for a backtrace\n")) (start-repl #:debug (make-debug (stack->vector stack) 0 (error-string frame args) #f))) @@ -253,15 +254,19 @@ ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . rest) (let ((err (system-error-errno args))) - (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) + (report-error (G_ "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~%") + (format (current-error-port) (G_ "~a: error: ~a~%") (location->string loc) message))) (('srfi-34 obj) - (report-error (_ "exception thrown: ~s~%") obj)) + (if (message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain)) + (report-error (G_ "exception thrown: ~s~%") obj))) ((error args ...) - (report-error (_ "failed to load '~a':~%") file) + (report-error (G_ "failed to load '~a':~%") file) (apply display-error frame (current-error-port) args)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ @@ -270,16 +275,20 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (match args (('system-error . rest) (let ((err (system-error-errno args))) - (warning (_ "failed to load '~a': ~a~%") file (strerror err)))) + (warning (G_ "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: warning: ~a~%") + (format (current-error-port) (G_ "~a: warning: ~a~%") (location->string loc) message))) (('srfi-34 obj) - (warning (_ "failed to load '~a': exception thrown: ~s~%") - file obj)) + (if (message-condition? obj) + (warning (G_ "failed to load '~a': ~a~%") + file + (gettext (condition-message obj) %gettext-domain)) + (warning (G_ "failed to load '~a': exception thrown: ~s~%") + file obj))) ((error args ...) - (warning (_ "failed to load '~a':~%") file) + (warning (G_ "failed to load '~a':~%") file) (apply display-error #f (current-error-port) args)))) (define (install-locale) @@ -288,11 +297,18 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (lambda _ (setlocale LC_ALL "")) (lambda args - (warning (_ "failed to install locale: ~a~%") + (warning (G_ "failed to install locale: ~a~%") (strerror (system-error-errno args)))))) (define (initialize-guix) "Perform the usual initialization for stand-alone Guix commands." + ;; By default don't annoy users with deprecation warnings. In practice, + ;; 'define-deprecated' in (ice-9 deprecated) arranges so that those warnings + ;; are emitted at expansion-time only, but there are cases where they could + ;; slip through, for instance when interpreting code. + (unless (getenv "GUILE_WARN_DEPRECATED") + (debug-disable 'warn-deprecated)) + (install-locale) (textdomain %gettext-domain) @@ -311,9 +327,9 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ - (_ "(C)") - (_ "the Guix authors\n")) - (display (_"\ + (G_ "(C)") + (G_ "the Guix authors\n")) + (display (G_"\ License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. @@ -325,11 +341,11 @@ There is NO WARRANTY, to the extent permitted by law. ;; package. Please add another line saying "Report translation bugs to ;; ...\n" with the address for translation bugs (typically your translation ;; team's web or email address). - (format #t (_ " + (format #t (G_ " Report bugs to: ~a.") %guix-bug-report-address) - (format #t (_ " + (format #t (G_ " ~a home page: <~a>") %guix-package-name %guix-home-page-url) - (display (_ " + (display (G_ " General help using GNU software: <http://www.gnu.org/gethelp/>")) (newline)) @@ -374,13 +390,13 @@ nicely." (lambda () (apply make-regexp regexp flags)) (lambda (key proc message . rest) - (leave (_ "'~a' is not a valid regular expression: ~a~%") + (leave (G_ "'~a' is not a valid regular expression: ~a~%") regexp message)))) (define (string->number* str) "Like `string->number', but error out with an error message on failure." (or (string->number str) - (leave (_ "~a: invalid number~%") str))) + (leave (G_ "~a: invalid number~%") str))) (define (size->number str) "Convert STR, a storage measurement representation such as \"1024\" or @@ -397,7 +413,7 @@ interpreted." str)) (num (string->number numstr))) (unless num - (leave (_ "invalid number: ~a~%") numstr)) + (leave (G_ "invalid number: ~a~%") numstr)) ((compose inexact->exact round) (* num @@ -420,7 +436,7 @@ interpreted." ("YB" (expt 10 24)) ("" 1) (x - (leave (_ "unknown unit: ~a~%") unit))))))) + (leave (G_ "unknown unit: ~a~%") unit))))))) (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." @@ -437,58 +453,62 @@ interpreted." (file (location-file location)) (line (location-line location)) (column (location-column location))) - (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") + (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") file line column (package-full-name package) input))) ((package-cross-build-system-error? c) (let* ((package (package-error-package c)) (loc (package-location package)) (system (package-build-system package))) - (leave (_ "~a: ~a: build system `~a' does not support cross builds~%") + (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%") (location->string loc) (package-full-name package) (build-system-name system)))) + ((gexp-input-error? c) + (let ((input (package-error-invalid-input c))) + (leave (G_ "~s: invalid G-expression input~%") + (gexp-error-invalid-input c)))) ((profile-not-found-error? c) - (leave (_ "profile '~a' does not exist~%") + (leave (G_ "profile '~a' does not exist~%") (profile-error-profile c))) ((missing-generation-error? c) - (leave (_ "generation ~a of profile '~a' does not exist~%") + (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation c) (profile-error-profile c))) ((nar-error? c) (let ((file (nar-error-file c)) (port (nar-error-port c))) (if file - (leave (_ "corrupt input while restoring '~a' from ~s~%") + (leave (G_ "corrupt input while restoring '~a' from ~s~%") file (or (port-filename* port) port)) - (leave (_ "corrupt input while restoring archive from ~s~%") + (leave (G_ "corrupt input while restoring archive from ~s~%") (or (port-filename* port) port))))) ((nix-connection-error? c) - (leave (_ "failed to connect to `~a': ~a~%") + (leave (G_ "failed to connect to `~a': ~a~%") (nix-connection-error-file c) (strerror (nix-connection-error-code c)))) ((nix-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. - (leave (_ "build failed: ~a~%") + (leave (G_ "build failed: ~a~%") (nix-protocol-error-message c))) ((derivation-missing-output-error? c) - (leave (_ "reference to invalid output '~a' of derivation '~a'~%") + (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") (derivation-missing-output c) (derivation-file-name (derivation-error-derivation c)))) ((file-search-error? c) - (leave (_ "file '~a' could not be found in these \ + (leave (G_ "file '~a' could not be found in these \ directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. - (leave (_ "~a~%") + (leave (G_ "~a~%") (gettext (condition-message c) %gettext-domain)))) ;; Catch EPIPE and the likes. (catch 'system-error thunk (lambda (key proc format-string format-args . rest) - (leave (_ "~a: ~a~%") proc + (leave (G_ "~a: ~a~%") proc (apply format #f format-string format-args)))))) (define-syntax-rule (leave-on-EPIPE exp ...) @@ -523,18 +543,22 @@ similar." (lambda () (call-with-input-string str read)) (lambda args - (leave (_ "failed to read expression ~s: ~s~%") + (leave (G_ "failed to read expression ~s: ~s~%") str args))))) (catch #t (lambda () (eval exp (force %guix-user-module))) (lambda args - (report-error (_ "failed to evaluate expression '~a':~%") exp) + (report-error (G_ "failed to evaluate expression '~a':~%") exp) (match args (('syntax-error proc message properties form . rest) - (report-error (_ "syntax error: ~a~%") message)) + (report-error (G_ "syntax error: ~a~%") message)) (('srfi-34 obj) - (report-error (_ "exception thrown: ~s~%") obj)) + (if (message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain)) + (report-error (G_ "exception thrown: ~s~%") obj))) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) @@ -546,7 +570,7 @@ error." (match (read/eval str) ((? package? p) p) (x - (leave (_ "expression ~s does not evaluate to a package~%") + (leave (G_ "expression ~s does not evaluate to a package~%") str)))) (define (show-derivation-outputs derivation) @@ -754,13 +778,13 @@ replacement if PORT is not Unicode-capable." (define (location->string loc) "Return a human-friendly, GNU-standard representation of LOC." (match loc - (#f (_ "<unknown location>")) + (#f (G_ "<unknown location>")) (($ <location> file line column) (format #f "~a:~a:~a" file line column)))) -(define (config-directory) +(define* (config-directory #:key (ensure? #t)) "Return the name of the configuration directory, after making sure that it -exists. Honor the XDG specs, +exists if ENSURE? is true. Honor the XDG specs, <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>." (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME") (and=> (getenv "HOME") @@ -768,12 +792,13 @@ exists. Honor the XDG specs, (cut string-append <> "/guix")))) (catch 'system-error (lambda () - (mkdir-p dir) + (when ensure? + (mkdir-p dir)) dir) (lambda args (let ((err (system-error-errno args))) ;; ERR is necessarily different from EEXIST. - (leave (_ "failed to create configuration directory `~a': ~a~%") + (leave (G_ "failed to create configuration directory `~a': ~a~%") dir (strerror err))))))) (define* (fill-paragraph str width #:optional (column 0)) @@ -904,7 +929,7 @@ WIDTH columns." (dependencies->recutils (filter package? inputs))))) (format port "location: ~a~%" (or (and=> (package-location p) location->string) - (_ "unknown"))) + (G_ "unknown"))) ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in ;; field identifiers. @@ -918,7 +943,7 @@ WIDTH columns." ((? license? license) (license-name license)) (x - (_ "unknown")))) + (G_ "unknown")))) (format port "synopsis: ~a~%" (string-map (match-lambda (#\newline #\space) @@ -991,6 +1016,7 @@ following patterns: \"1d\", \"1w\", \"1m\"." (make-time time-duration 0 (string->number (match:substring match 1))))) ((string-match "^([0-9]+)h$" str) + => (lambda (match) (hours->duration 1 match))) ((string-match "^([0-9]+)d$" str) @@ -1076,7 +1102,7 @@ DURATION-RELATION with the current time." (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." (unless (zero? number) - (let ((header (format #f (_ "Generation ~a\t~a") number + (let ((header (format #f (G_ "Generation ~a\t~a") number (date->string (time-utc->date (generation-time profile number)) @@ -1086,7 +1112,7 @@ DURATION-RELATION with the current time." ;; TRANSLATORS: The word "current" here is an adjective for ;; "Generation", as in "current generation". Use the appropriate ;; gender where applicable. - (format #t (_ "~a\t(current)~%") header) + (format #t (G_ "~a\t(current)~%") header) (format #t "~a~%" header))))) (define (display-profile-content-diff profile gen1 gen2) @@ -1129,7 +1155,7 @@ way." (profile-manifest (generation-file-name profile number)))))) (define (display-generation-change previous current) - (format #t (_ "switched from generation ~a to ~a~%") previous current)) + (format #t (G_ "switched from generation ~a to ~a~%") previous current)) (define (roll-back* store profile) "Like 'roll-back', but display what is happening." @@ -1145,7 +1171,7 @@ way." (define (delete-generation* store profile generation) "Like 'delete-generation', but display what is going on." - (format #t (_ "deleting ~a~%") + (format #t (G_ "deleting ~a~%") (generation-file-name profile generation)) (delete-generation store profile generation)) @@ -1176,7 +1202,7 @@ optionally contain a version number and an output name, as in these examples: (define (show-guix-usage) (format (current-error-port) - (_ "Try `guix --help' for more information.~%")) + (G_ "Try `guix --help' for more information.~%")) (exit 1)) (define (command-files) @@ -1204,10 +1230,10 @@ optionally contain a version number and an output name, as in these examples: (member command '("substitute" "authenticate" "offload" "perform-download"))) - (format #t (_ "Usage: guix COMMAND ARGS... + (format #t (G_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) (newline) - (format #t (_ "COMMAND must be one of the sub-commands listed below:\n")) + (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n")) (newline) ;; TODO: Display a synopsis of each command. (format #t "~{ ~a~%~}" (sort (remove internal? (commands)) @@ -1227,7 +1253,7 @@ found." (resolve-interface `(guix scripts ,command))) (lambda - (format (current-error-port) - (_ "guix: ~a: command not found~%") command) + (G_ "guix: ~a: command not found~%") command) (show-guix-usage)))) (let ((command-main (module-ref module @@ -1246,7 +1272,7 @@ and signal handling has already been set up." (match args (() (format (current-error-port) - (_ "guix: missing command name~%")) + (G_ "guix: missing command name~%")) (show-guix-usage)) ((or ("-h") ("--help")) (show-guix-help)) @@ -1254,7 +1280,7 @@ and signal handling has already been set up." (show-version-and-exit "guix")) (((? option? o) args ...) (format (current-error-port) - (_ "guix: unrecognized option '~a'~%") o) + (G_ "guix: unrecognized option '~a'~%") o) (show-guix-usage)) (("help" command) (apply run-guix-command (string->symbol command) diff --git a/guix/upstream.scm b/guix/upstream.scm index a47a52be3f..5083e6b805 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -209,9 +209,9 @@ values: 'interactive' (default), 'always', and 'never'." (if ret tarball (begin - (warning (_ "signature verification failed for `~a'~%") + (warning (G_ "signature verification failed for `~a'~%") url) - (warning (_ "(could be because the public key is not in your keyring)~%")) + (warning (G_ "(could be because the public key is not in your keyring)~%")) #f)))))) (define (find2 pred lst1 lst2) @@ -290,12 +290,12 @@ if an update was made, and #f otherwise." old-version version old-hash hash)) version) (begin - (warning (_ "~a: could not locate source file") + (warning (G_ "~a: could not locate source file") (location-file loc)) #f))) (begin (format (current-error-port) - (_ "~a: ~a: no `version' field in source; skipping~%") + (G_ "~a: ~a: no `version' field in source; skipping~%") (location->string (package-location package)) name))))) diff --git a/guix/utils.scm b/guix/utils.scm index fb962df8ba..9bf1cc893f 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -155,7 +155,7 @@ a symbol such as 'xz." (match compression ((or #f 'none) (values input '())) ('bzip2 (filtered-port `(,%bzip2 "-dc") input)) - ('xz (filtered-port `(,%xz "-dc -T0") input)) + ('xz (filtered-port `(,%xz "-dc" "-T0") input)) ('gzip (filtered-port `(,%gzip "-dc") input)) (else (error "unsupported compression scheme" compression)))) @@ -165,7 +165,7 @@ a symbol such as 'xz." (match compression ((or #f 'none) (values input '())) ('bzip2 (filtered-port `(,%bzip2 "-c") input)) - ('xz (filtered-port `(,%xz "-c -T0") input)) + ('xz (filtered-port `(,%xz "-c" "-T0") input)) ('gzip (filtered-port `(,%gzip "-c") input)) (else (error "unsupported compression scheme" compression)))) @@ -222,7 +222,7 @@ program--e.g., '(\"--fast\")." (match compression ((or #f 'none) (values output '())) ('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output)) - ('xz (filtered-output-port `(,%xz "-c -T0" ,@options) output)) + ('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output)) ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) (else (error "unsupported compression scheme" compression)))) @@ -512,7 +512,7 @@ minor version numbers from version-string." (define (compressed-file? file) "Return true if FILE denotes a compressed file." (->bool (member (file-extension file) - '("gz" "bz2" "xz" "lz" "tgz" "tbz2" "zip")))) + '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "zip")))) (define (switch-symlinks link target) "Atomically switch LINK, a symbolic link, to point to TARGET. Works diff --git a/guix/workers.scm b/guix/workers.scm new file mode 100644 index 0000000000..e3452d249a --- /dev/null +++ b/guix/workers.scm @@ -0,0 +1,123 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix workers) + #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (ice-9 q) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:export (pool? + make-pool + pool-enqueue! + pool-idle? + eventually)) + +;;; Commentary: +;;; +;;; This module implements "worker pools". Worker pools are the low-level +;;; mechanism that's behind futures: there's a fixed set of threads +;;; ("workers") that one can submit work to, and one of them will eventually +;;; pick the submitted tasks. +;;; +;;; Unlike futures, these worker pools are meant to be used for tasks that +;;; have a side-effect. Thus, we never "touch" a task that was submitted like +;;; we "touch" a future. Instead, we simply assume that the task will +;;; eventually complete. +;;; +;;; Code: + +(define-record-type <pool> + (%make-pool queue mutex condvar workers) + pool? + (queue pool-queue) + (mutex pool-mutex) + (condvar pool-condition-variable) + (workers pool-workers)) + +(define-syntax-rule (without-mutex mutex exp ...) + (dynamic-wind + (lambda () + (unlock-mutex mutex)) + (lambda () + exp ...) + (lambda () + (lock-mutex mutex)))) + +(define (worker-thunk mutex condvar pop-queue) + "Return the thunk executed by worker threads." + (define (loop) + (match (pop-queue) + (#f ;empty queue + (wait-condition-variable condvar mutex)) + ((? procedure? proc) + ;; Release MUTEX while executing PROC. + (without-mutex mutex + (catch #t proc + (lambda (key . args) + ;; XXX: In Guile 2.0 ports are not thread-safe, so this could + ;; crash (Guile 2.2 is fine). + (display-backtrace (make-stack #t) (current-error-port)) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 0) + key args)))))) + (loop)) + + (lambda () + (with-mutex mutex + (loop)))) + +(define* (make-pool #:optional (count (current-processor-count))) + "Return a pool of COUNT workers." + (let* ((mutex (make-mutex)) + (condvar (make-condition-variable)) + (queue (make-q)) + (procs (unfold (cut >= <> count) + (lambda (n) + (worker-thunk mutex condvar + (lambda () + (and (not (q-empty? queue)) + (q-pop! queue))))) + 1+ + 0)) + (threads (map (lambda (proc) + (call-with-new-thread proc)) + procs))) + (%make-pool queue mutex condvar threads))) + +(define (pool-enqueue! pool thunk) + "Enqueue THUNK for future execution by POOL." + (with-mutex (pool-mutex pool) + (enq! (pool-queue pool) thunk) + (signal-condition-variable (pool-condition-variable pool)))) + +(define (pool-idle? pool) + "Return true if POOL doesn't have any task in its queue." + (with-mutex (pool-mutex pool) + (q-empty? (pool-queue pool)))) + +(define-syntax-rule (eventually pool exp ...) + "Run EXP eventually on one of the workers of POOL." + (pool-enqueue! pool (lambda () exp ...))) + +;;; Local Variables: +;;; eval: (put 'without-mutex 'scheme-indent-function 1) +;;; End: + +;;; workers.scm ends here |