From 77559f23b02f80d9e5dd4030e1f67cd954a871ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jun 2016 23:51:58 +0200 Subject: tests: Strengthen regexp in 'packages.scm'. * tests/packages.scm ("--search-paths with pattern"): Call 'regexp-quote' on the result of 'derivation->output-path'. --- tests/packages.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/packages.scm b/tests/packages.scm index d3f432ada..94f5ea71a 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -797,7 +797,7 @@ #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof)) (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n" - (derivation->output-path prof)) + (regexp-quote (derivation->output-path prof))) (with-output-to-string (lambda () (guix-package "-p" (derivation->output-path prof) -- cgit v1.3 From 25a3bfbe77cb45aa26f9af8c72e7f978a177187e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jun 2016 00:42:19 +0200 Subject: tests: Skip all the container tests when needed. Reported by myglc2 at . * tests/containers.scm (skip-if-unsupported): New procedure. Call it before each test. --- tests/containers.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/tests/containers.scm b/tests/containers.scm index 5a0f9937b..bbcff3f51 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -30,15 +30,18 @@ ;; Skip these tests unless user namespaces are available and the setgroups ;; file (introduced in Linux 3.19 to address a security issue) exists. -(unless (and (user-namespace-supported?) - (unprivileged-user-namespace-supported?) - (setgroups-supported?)) - (test-skip 7)) +(define (skip-if-unsupported) + (unless (and (user-namespace-supported?) + (unprivileged-user-namespace-supported?) + (setgroups-supported?)) + (test-skip 1))) +(skip-if-unsupported) (test-assert "call-with-container, exit with 0 when there is no error" (zero? (call-with-container '() (const #t) #:namespaces '(user)))) +(skip-if-unsupported) (test-assert "call-with-container, user namespace" (zero? (call-with-container '() @@ -47,6 +50,7 @@ (assert-exit (and (zero? (getuid)) (zero? (getgid))))) #:namespaces '(user)))) +(skip-if-unsupported) (test-assert "call-with-container, uts namespace" (zero? (call-with-container '() @@ -57,6 +61,7 @@ (primitive-exit 0)) #:namespaces '(user uts)))) +(skip-if-unsupported) (test-assert "call-with-container, pid namespace" (zero? (call-with-container '() @@ -72,6 +77,7 @@ (status:exit-val status))))))) #:namespaces '(user pid)))) +(skip-if-unsupported) (test-assert "call-with-container, mnt namespace" (zero? (call-with-container '(("none" device "/testing" "tmpfs" () #f #f)) @@ -79,6 +85,7 @@ (assert-exit (file-exists? "/testing"))) #:namespaces '(user mnt)))) +(skip-if-unsupported) (test-equal "call-with-container, mnt namespace, wrong bind mount" `(system-error ,ENOENT) ;; An exception should be raised; see . @@ -91,12 +98,14 @@ (lambda args (list 'system-error (system-error-errno args))))) +(skip-if-unsupported) (test-assert "call-with-container, all namespaces" (zero? (call-with-container '() (lambda () (primitive-exit 0))))) +(skip-if-unsupported) (test-assert "container-excursion" (call-with-temporary-directory (lambda (root) -- cgit v1.3 From 5b8e564ccdc734cda20d151adc1d60d7119fff3b Mon Sep 17 00:00:00 2001 From: Alex Sassmannshausen Date: Sat, 2 Jul 2016 20:06:02 +0200 Subject: import: cpan: Use our mirrors for 'https' URLs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/cpan.scm (fix-source-url): New procedure. (cpan-module->sexp): Use it to construct our source-url. * tests/cpan.scm: Add tests for fix-source-url. Signed-off-by: Ludovic Courtès --- guix/import/cpan.scm | 13 +++++++++---- tests/cpan.scm | 11 +++++++++++ 2 files changed, 20 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index ad61ee791..213a155fd 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2016 Alex Sassmannshausen ;;; ;;; This file is part of GNU Guix. ;;; @@ -99,6 +100,13 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" (define (cpan-home name) (string-append "http://search.cpan.org/dist/" name)) +(define (fix-source-url download-url) + "Return a new download URL based on DOWNLOAD-URL which now uses our mirrors, +if the original's domain was metacpan." + (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" download-url + 'pre "mirror://cpan" 'post)) + + (define %corelist (delay (let* ((perl (with-store store @@ -183,10 +191,7 @@ META." (list (list guix-name (list 'quasiquote inputs)))))) - (define source-url - (regexp-substitute/global #f "http://cpan.metacpan.org" - (assoc-ref meta "download_url") - 'pre "mirror://cpan" 'post)) + (define source-url (fix-source-url (assoc-ref meta "download_url"))) (let ((tarball (with-store store (download-to-store store source-url)))) diff --git a/tests/cpan.scm b/tests/cpan.scm index 5d56f0bd2..898081b3e 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Eric Bavier +;;; Copyright © 2016 Alex Sassmannshausen ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,4 +98,14 @@ (x (pk 'fail x #f))))) +(test-equal "source-url-http" + ((@@ (guix import cpan) fix-source-url) + "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + +(test-equal "source-url-https" + ((@@ (guix import cpan) fix-source-url) + "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") + (test-end "cpan") -- cgit v1.3 From 0bb9929eaa3f963ae75478e789723f9e8582116b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Jul 2016 22:26:19 +0200 Subject: gexp: Add 'with-imported-modules' macro. * guix/gexp.scm ()[modules]: New field. (gexp-modules): New procedure. (gexp->derivation): Use it and append the result to %MODULES. Update docstring to mark #:modules as deprecated. (current-imported-modules, with-imported-modules): New macros. (gexp): Pass CURRENT-IMPORTED-MODULES as second argument to 'gexp'. (gexp->script): Use and honor 'gexp-modules'; define '%modules'. * tests/gexp.scm ("gexp->derivation & with-imported-modules") ("gexp->derivation & nested with-imported-modules") ("gexp-modules & ungexp", "gexp-modules & ungexp-splicing"): New tests. ("program-file"): Use 'with-imported-modules'. Remove #:modules argument to 'program-file'. * doc/guix.texi (G-Expressions): Document 'with-imported-modules'. Mark #:modules of 'gexp->derivation' as deprecated. * emacs/guix-devel.el: Add syntax for 'with-imported-modules'. (guix-devel-keywords): Add it. * .dir-locals.el: Likewise. --- .dir-locals.el | 1 + doc/guix.texi | 38 ++++++++++++++++++++++++++++++- emacs/guix-devel.el | 2 ++ guix/gexp.scm | 47 ++++++++++++++++++++++++++++++++++----- tests/gexp.scm | 64 +++++++++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 142 insertions(+), 10 deletions(-) (limited to 'tests') diff --git a/.dir-locals.el b/.dir-locals.el index 0873c1d74..c7ceb9e9f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -59,6 +59,7 @@ (eval . (put 'run-with-store 'scheme-indent-function 1)) (eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1)) + (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index c9d9bd897..b31532503 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3697,6 +3697,30 @@ In the example above, the native build of @var{coreutils} is used, so that @command{ln} can actually run on the host; but then the cross-compiled build of @var{emacs} is referenced. +@cindex imported modules, for gexps +@findex with-imported-modules +Another gexp feature is @dfn{imported modules}: sometimes you want to be +able to use certain Guile modules from the ``host environment'' in the +gexp, so those modules should be imported in the ``build environment''. +The @code{with-imported-modules} form allows you to express that: + +@example +(let ((build (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")))))) + (gexp->derivation "empty-dir" + #~(begin + #$build + (display "success!\n") + #t))) +@end example + +@noindent +In this example, the @code{(guix build utils)} module is automatically +pulled into the isolated build environment of our gexp, such that +@code{(use-modules (guix build utils))} works as expected. + The syntactic form to construct gexps is summarized below. @deffn {Scheme Syntax} #~@var{exp} @@ -3756,6 +3780,16 @@ G-expressions created by @code{gexp} or @code{#~} are run-time objects of the @code{gexp?} type (see below.) @end deffn +@deffn {Scheme Syntax} with-imported-modules @var{modules} @var{body}@dots{} +Mark the gexps defined in @var{body}@dots{} as requiring @var{modules} +in their execution environment. @var{modules} must be a list of Guile +module names, such as @code{'((guix build utils) (guix build gremlin))}. + +This form has @emph{lexical} scope: it has an effect on the gexps +directly defined in @var{body}@dots{}, but not on those defined, say, in +procedures called from @var{body}@dots{}. +@end deffn + @deffn {Scheme Procedure} gexp? @var{obj} Return @code{#t} if @var{obj} is a G-expression. @end deffn @@ -3781,7 +3815,9 @@ stored in a file called @var{script-name}. When @var{target} is true, it is used as the cross-compilation target triplet for packages referred to by @var{exp}. -Make @var{modules} available in the evaluation context of @var{exp}; +@var{modules} is deprecated in favor of @code{with-imported-modules}. +Its meaning is to +make @var{modules} available in the evaluation context of @var{exp}; @var{modules} is a list of names of Guile modules searched in @var{module-path} to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el index ee8371ce8..b71670cdf 100644 --- a/emacs/guix-devel.el +++ b/emacs/guix-devel.el @@ -216,6 +216,7 @@ to find 'modify-phases' keywords." "with-derivation-substitute" "with-directory-excursion" "with-error-handling" + "with-imported-modules" "with-monad" "with-mutex" "with-store")) @@ -306,6 +307,7 @@ Each rule should have a form (SYMBOL VALUE). See `put' for details." (with-derivation-substitute 2) (with-directory-excursion 1) (with-error-handling 0) + (with-imported-modules 1) (with-monad 1) (with-mutex 1) (with-store 1) diff --git a/guix/gexp.scm b/guix/gexp.scm index c86f4d0fd..e9274a05f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -29,6 +29,7 @@ #:use-module (ice-9 match) #:export (gexp gexp? + with-imported-modules gexp-input gexp-input? @@ -98,9 +99,10 @@ ;; "G expressions". (define-record-type - (make-gexp references proc) + (make-gexp references modules proc) gexp? (references gexp-references) ;list of + (modules gexp-self-modules) ;list of module names (proc gexp-proc)) ;procedure (define (write-gexp gexp port) @@ -384,6 +386,23 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! 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? exp)) + (gexp-modules exp)) + (($ (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp))))) + (define raw-derivation (store-lift derivation)) @@ -465,7 +484,8 @@ derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When TARGET is true, it is used as the cross-compilation target triplet for packages referred to by EXP. -Make MODULES available in the evaluation context of EXP; MODULES is a list of +MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to +make MODULES available in the evaluation context of EXP; MODULES is a list of names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). @@ -494,7 +514,9 @@ Similarly for DISALLOWED-REFERENCES, which can list items that must not be referenced by the outputs. The other arguments are as for 'derivation'." - (define %modules modules) + (define %modules + (delete-duplicates + (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) (define (graphs-file-names graphs) @@ -724,6 +746,17 @@ and in the current monad setting (system type, etc.)" (simple-format #f "~a:~a" line column))) ""))) +(define-syntax-parameter current-imported-modules + ;; Current list of imported modules. + (identifier-syntax '())) + +(define-syntax-rule (with-imported-modules modules body ...) + "Mark the gexps defined in BODY... as requiring MODULES in their execution +environment." + (syntax-parameterize ((current-imported-modules + (identifier-syntax modules))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -819,6 +852,7 @@ and in the current monad setting (system type, etc.)" (sexp (substitute-references #'exp (zip escapes formals))) (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) + current-imported-modules (lambda #,formals #,sexp))))))) @@ -960,8 +994,11 @@ they can refer to each other." #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in its search path." - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules))) + (define %modules + (append (gexp-modules exp) modules)) + + (mlet %store-monad ((modules (imported-modules %modules)) + (compiled (compiled-modules %modules))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) diff --git a/tests/gexp.scm b/tests/gexp.scm index f44f0eaf9..36ce66f7c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -526,6 +526,18 @@ get-bytevector-all)))) files)))))) +(test-equal "gexp-modules & ungexp" + '((bar) (foo)) + ((@@ (guix gexp) gexp-modules) + #~(foo #$(with-imported-modules '((foo)) #~+) + #+(with-imported-modules '((bar)) #~-)))) + +(test-equal "gexp-modules & ungexp-splicing" + '((foo) (bar)) + ((@@ (guix gexp) gexp-modules) + #~(foo #$@(list (with-imported-modules '((foo)) #~+) + (with-imported-modules '((bar)) #~-))))) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin @@ -540,6 +552,50 @@ (s (stat (string-append p "/guile/guix/nix")))) (return (eq? (stat:type s) 'directory)))))) +(test-assertm "gexp->derivation & with-imported-modules" + ;; Same test as above, but using 'with-imported-modules'. + (mlet* %store-monad + ((build -> (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t))) + (drv (gexp->derivation "test-with-modules" build))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix")))) + (return (eq? (stat:type s) 'directory)))))) + +(test-assertm "gexp->derivation & nested with-imported-modules" + (mlet* %store-monad + ((build1 -> (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/guile/guix/nix")) + #t))) + (build2 -> (with-imported-modules '((guix build bournish)) + #~(begin + (use-modules (guix build bournish) + (system base compile)) + #+build1 + (call-with-output-file (string-append #$output "/b") + (lambda (port) + (write + (read-and-compile (open-input-string "cd /foo") + #:from %bournish-language + #:to 'scheme) + port)))))) + (drv (gexp->derivation "test-with-modules" build2))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((p (derivation->output-path drv)) + (s (stat (string-append p "/guile/guix/nix"))) + (b (string-append p "/b"))) + (return (and (eq? (stat:type s) 'directory) + (equal? '(chdir "/foo") + (call-with-input-file b read)))))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) @@ -676,11 +732,11 @@ (test-assertm "program-file" (let* ((n (random (expt 2 50))) - (exp (gexp (begin - (use-modules (guix build utils)) - (display (ungexp n))))) + (exp (with-imported-modules '((guix build utils)) + (gexp (begin + (use-modules (guix build utils)) + (display (ungexp n)))))) (file (program-file "program" exp - #:modules '((guix build utils)) #:guile %bootstrap-guile))) (mlet* %store-monad ((drv (lower-object file)) (out -> (derivation->output-path drv))) -- cgit v1.3 From 66a35ceb43f53c3f3e363714c9a6a402f243670d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 18:00:16 +0200 Subject: gexp: Remove more uses of #:modules. * guix/scripts/system.scm (switch-to-system): Adjust comment. * tests/gexp.scm ("gexp->derivation #:references-graphs"): Use 'with-imported-modules' instead of #:modules. * tests/grafts.scm ("graft-derivation, preserve empty directories"): Likewise. --- guix/scripts/system.scm | 2 +- tests/gexp.scm | 36 ++++++++++++++++++------------------ tests/grafts.scm | 16 ++++++++-------- 3 files changed, 27 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index dd1e534c9..e2c6b2efe 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -362,7 +362,7 @@ it atomically, and then run OS's activation script." ;; The activation script may modify '%load-path' & co., so protect ;; against that. This is necessary to ensure that ;; 'upgrade-shepherd-services' gets to see the right modules when it - ;; computes derivations with (gexp->derivation #:modules …). + ;; computes derivations with 'gexp->derivation'. (save-load-path-excursion (primitive-load (derivation->output-path script)))) diff --git a/tests/gexp.scm b/tests/gexp.scm index 36ce66f7c..03a64fa6b 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -601,26 +601,26 @@ ((one (text-file "one" (random-text))) (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) - (drv (gexp->derivation "ref-graphs" - #~(begin - (use-modules (guix build store-copy)) - (with-output-to-file #$output - (lambda () - (write (call-with-input-file "guile" - read-reference-graph)))) - (with-output-to-file #$output:one - (lambda () - (write (call-with-input-file "one" - read-reference-graph)))) - (with-output-to-file #$output:two - (lambda () - (write (call-with-input-file "two" - read-reference-graph))))) + (build -> (with-imported-modules '((guix build store-copy) + (guix build utils)) + #~(begin + (use-modules (guix build store-copy)) + (with-output-to-file #$output + (lambda () + (write (call-with-input-file "guile" + read-reference-graph)))) + (with-output-to-file #$output:one + (lambda () + (write (call-with-input-file "one" + read-reference-graph)))) + (with-output-to-file #$output:two + (lambda () + (write (call-with-input-file "two" + read-reference-graph))))))) + (drv (gexp->derivation "ref-graphs" build #:references-graphs `(("one" ,one) ("two" ,two "chbouib") - ("guile" ,%bootstrap-guile)) - #:modules '((guix build store-copy) - (guix build utils)))) + ("guile" ,%bootstrap-guile)))) (ok? (built-derivations (list drv))) (guile-drv (package->derivation %bootstrap-guile)) (bash (interned-file (search-bootstrap-binary "bash" diff --git a/tests/grafts.scm b/tests/grafts.scm index 8cd048552..13c56750e 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -135,14 +135,14 @@ (replacement fake))) (drv (gexp->derivation "to-graft" - #~(begin - (use-modules (guix build utils)) - (mkdir-p (string-append #$output - "/a/b/c/d")) - (symlink #$%bash - (string-append #$output - "/bash"))) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output + "/a/b/c/d")) + (symlink #$%bash + (string-append #$output + "/bash")))))) (grafted ((store-lift graft-derivation) drv (list graft))) (_ (built-derivations (list grafted))) -- cgit v1.3 From c1629416d89b187b1f37ed0c834570846f8a087a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 21:56:22 +0200 Subject: gnu: Remove unneeded 'imported-modules' fields for 'origin'. * gnu/packages/engineering.scm (fastcap)[source](modules, imported-modules): Remove. * gnu/packages/wm.scm (awesome)[source](imported-modules): Remove. * tests/packages.scm ("package-source-derivation, snippet"): Remove 'imported-modules' field. --- gnu/packages/engineering.scm | 4 ---- gnu/packages/wm.scm | 1 - tests/packages.scm | 1 - 3 files changed, 6 deletions(-) (limited to 'tests') diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm index a045bf2a5..906638664 100644 --- a/gnu/packages/engineering.scm +++ b/gnu/packages/engineering.scm @@ -229,10 +229,6 @@ optimizer; and it can produce photorealistic and design review images.") (snippet ;; Remove a non-free file. '(delete-file "doc/psfig.sty")) - (modules '((guix build utils) - (guix build download) - (guix ftp-client))) - (imported-modules modules) (patches (search-patches "fastcap-mulSetup.patch" "fastcap-mulGlobal.patch")))) (build-system gnu-build-system) diff --git a/gnu/packages/wm.scm b/gnu/packages/wm.scm index f385d2b4f..790c74bbf 100644 --- a/gnu/packages/wm.scm +++ b/gnu/packages/wm.scm @@ -393,7 +393,6 @@ experience.") "1m910lr7wkw2dgzmirfvz7dasfswhhccdf65l21iiciv24c3w1bb")) (modules '((guix build utils) (srfi srfi-19))) - (imported-modules '((guix build utils))) (snippet ;; Remove non-reproducible timestamp and use the date of the ;; source file instead. diff --git a/tests/packages.scm b/tests/packages.scm index 94f5ea71a..fc75e3873 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -335,7 +335,6 @@ ("patch" ,%bootstrap-coreutils&co))) (patch-guile %bootstrap-guile) (modules '((guix build utils))) - (imported-modules modules) (snippet '(begin ;; We end up in 'bin', because it's the first ;; directory, alphabetically. Not a very good -- cgit v1.3 From bfcb3d767bbc24dc6c6d834619073351fbcc61b5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 13 Jul 2016 00:50:05 +0200 Subject: lint: 'validate-uri' reports suspiciously small 200 responses. * guix/scripts/lint.scm (validate-uri): Upon 200 http-response, check the 'response-content-length' and emit a warning when it is <= 1000. * tests/lint.scm (call-with-http-server): Add 'data' parameter. (with-http-server): Likewise. (%long-string): New variable. ("home-page: 200"): Pass %LONG-STRING to 'with-http-server'. ("home-page: 404", "source: 200", "source: 404"): Likewise. ("home-page: 200 but short length"): New test. ("source: 200 but short length"): New test. --- guix/scripts/lint.scm | 17 ++++++++++++++++- tests/lint.scm | 52 ++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 57 insertions(+), 12 deletions(-) (limited to 'tests') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b4fdb6f90..d5e9197cc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -359,7 +359,22 @@ warning for PACKAGE mentionning the FIELD." (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) - (or (= 200 (response-code argument)) + (if (= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect such + ;; malicious behavior. + (or (> length 1000) + (begin + (emit-warning package + (format #f + (_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (uri->string uri) + length)) + #f))) + (_ #t)) (begin (emit-warning package (format #f diff --git a/tests/lint.scm b/tests/lint.scm index 1f1b0c95e..ce751c42c 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -102,14 +102,14 @@ http-write (@@ (web server http) http-close)) -(define (call-with-http-server code thunk) - "Call THUNK with an HTTP server running and returning CODE on HTTP -requests." +(define (call-with-http-server code data thunk) + "Call THUNK with an HTTP server running and returning CODE and DATA (a +string) on HTTP requests." (define (server-body) (define (handle request body) (values (build-response #:code code #:reason-phrase "Such is life") - "Hello, world.")) + data)) (catch 'quit (lambda () @@ -123,8 +123,11 @@ requests." ;; Normally SERVER exits automatically once it has received a request. (thunk)))) -(define-syntax-rule (with-http-server code body ...) - (call-with-http-server code (lambda () body ...))) +(define-syntax-rule (with-http-server code data body ...) + (call-with-http-server code data (lambda () body ...))) + +(define %long-string + (make-string 2000 #\a)) (test-begin "lint") @@ -402,18 +405,30 @@ requests." (test-equal "home-page: 200" "" (with-warnings - (with-http-server 200 + (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) (home-page %local-url)))) (check-home-page pkg))))) +(test-skip (if %http-server-socket 0 1)) +(test-assert "home-page: 200 but short length" + (->bool + (string-contains + (with-warnings + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page %local-url)))) + (check-home-page pkg)))) + "suspiciously small"))) + (test-skip (if %http-server-socket 0 1)) (test-assert "home-page: 404" (->bool (string-contains (with-warnings - (with-http-server 404 + (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) (home-page %local-url)))) @@ -501,7 +516,7 @@ requests." (test-equal "source: 200" "" (with-warnings - (with-http-server 200 + (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -510,12 +525,27 @@ requests." (sha256 %null-sha256)))))) (check-source pkg))))) +(test-skip (if %http-server-socket 0 1)) +(test-assert "source: 200 but short length" + (->bool + (string-contains + (with-warnings + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri %local-url) + (sha256 %null-sha256)))))) + (check-source pkg)))) + "suspiciously small"))) + (test-skip (if %http-server-socket 0 1)) (test-assert "source: 404" (->bool (string-contains (with-warnings - (with-http-server 404 + (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -617,6 +647,6 @@ requests." (test-end "lint") ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 1) +;; eval: (put 'with-http-server 'scheme-indent-function 2) ;; eval: (put 'with-warnings 'scheme-indent-function 0) ;; End: -- cgit v1.3 From babc2c80a7e1f1b5e72fd1685ef6604b93157a8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 14 Jul 2016 18:58:36 +0200 Subject: records: Improve reporting of invalid field specifiers. Fixes . Reported by Vincent Legoll . * guix/records.scm (report-invalid-field-specifier): New procedure. * tests/records.scm ("define-record-type* & wrong field specifier"): New test. --- guix/records.scm | 19 +++++++++++++++++-- tests/records.scm | 29 ++++++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/records.scm b/guix/records.scm index 0d35a747b..f3f3aafb0 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 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +42,15 @@ (format #f fmt args ...) form)))) +(define (report-invalid-field-specifier name bindings) + "Report the first invalid binding among BINDINGS." + (let loop ((bindings bindings)) + (syntax-case bindings () + (((field value) rest ...) ;good + (loop #'(rest ...))) + ((weird _ ...) ;weird! + (syntax-violation name "invalid field specifier" #'weird))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -147,7 +156,13 @@ fields, and DELAYED is the list of identifiers of delayed fields." "missing field initializers ~a" (lset-difference eq? '(expected ...) - fields))))))))))))) + fields))))))) + ((_ bindings (... ...)) + ;; One of BINDINGS doesn't match the (field value) pattern. + ;; Report precisely which one is faulty, instead of letting the + ;; "source expression failed to match any pattern" error. + (report-invalid-field-specifier 'name + #'(bindings (... ...)))))))))) (define-syntax-rule (define-field-property-predicate predicate property) "Define PREDICATE as a procedure that takes a syntax object and, when passed diff --git a/tests/records.scm b/tests/records.scm index c6f85d4a8..d6d27bb96 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (test-records) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -214,6 +215,32 @@ (equal? (foo-bar y) 1)) ;promise was already forced (eq? (foo-baz y) 'b))))) +(test-assert "define-record-type* & wrong field specifier" + (let ((exp '(begin + (define-record-type* foo make-foo + foo? + (bar foo-bar (default 42)) + (baz foo-baz)) + + (foo (baz 1 2 3 4 5)))) ;syntax error + (loc (current-source-location))) ;keep this alignment! + (catch 'syntax-error + (lambda () + (eval exp (test-module)) + #f) + (lambda (key proc message location form . args) + (and (eq? proc 'foo) + (string-match "invalid field" message) + (equal? form '(baz 1 2 3 4 5)) + + ;; Make sure the location is that of the field specifier. + ;; See . + (lset= equal? + (pk 'expected-loc + `((line . ,(- (assq-ref loc 'line) 1)) + ,@(alist-delete 'line loc))) + (pk 'actual-loc location))))))) + (test-assert "define-record-type* & missing initializers" (catch 'syntax-error (lambda () -- cgit v1.3 From 2bdd7ac17ceff60cd5ef77e530f62cea902bf90d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 00:51:02 +0200 Subject: system: Honor the 'dependencies' field of file systems. This allows mapped devices listed in 'dependencies' to be properly taken into account. Reported by Andreas Enge . * gnu/system.scm (mapped-device-user): Check whether DEVICE is a member of the 'dependencies' of FS. * tests/system.scm (%luks-device, %os-with-mapped-device): New variables. ("operating-system-user-mapped-devices") ("operating-system-boot-mapped-devices") ("operating-system-boot-mapped-devices, implicit dependency"): New tests. --- gnu/system.scm | 7 +++++-- tests/system.scm | 43 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/gnu/system.scm b/gnu/system.scm index a49b3f29b..476720b9f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -81,6 +81,8 @@ operating-system-mapped-devices operating-system-file-systems operating-system-store-file-system + operating-system-user-mapped-devices + operating-system-boot-mapped-devices operating-system-activation-script operating-system-user-accounts operating-system-shepherd-service-names @@ -208,8 +210,9 @@ as 'needed-for-boot'." "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." (let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) (find (lambda (fs) - (and (eq? 'device (file-system-title fs)) - (string=? (file-system-device fs) target))) + (or (member device (file-system-dependencies fs)) + (and (eq? 'device (file-system-title fs)) + (string=? (file-system-device fs) target)))) file-systems))) (define (operating-system-user-mapped-devices os) diff --git a/tests/system.scm b/tests/system.scm index b935bd07e..b5bb9af01 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -41,6 +41,25 @@ (users %base-user-accounts))) +(define %luks-device + (mapped-device + (source "/dev/foo") (target "my-luks-device") + (type luks-device-mapping))) + +(define %os-with-mapped-device + (operating-system + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.utf8") + (bootloader (grub-configuration (device "/dev/sdX"))) + (mapped-devices (list %luks-device)) + (file-systems (cons (file-system + (inherit %root-fs) + (dependencies (list %luks-device))) + %base-file-systems)) + (users %base-user-accounts))) + + (test-begin "system") (test-assert "operating-system-store-file-system" @@ -71,4 +90,28 @@ %base-file-systems))))) (eq? gnu (operating-system-store-file-system os)))) +(test-equal "operating-system-user-mapped-devices" + '() + (operating-system-user-mapped-devices %os-with-mapped-device)) + +(test-equal "operating-system-boot-mapped-devices" + (list %luks-device) + (operating-system-boot-mapped-devices %os-with-mapped-device)) + +(test-equal "operating-system-boot-mapped-devices, implicit dependency" + (list %luks-device) + + ;; Here we expect the implicit dependency between "/" and + ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a + ;; 'dependencies' field in the root file system. + (operating-system-boot-mapped-devices + (operating-system + (inherit %os-with-mapped-device) + (file-systems (cons (file-system + (device "/dev/mapper/my-luks-device") + (title 'device) + (mount-point "/") + (type "ext4")) + %base-file-systems))))) + (test-end) -- cgit v1.3 From 721539026dda02e58addbb618f2102b31a2927f8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 23:14:14 +0200 Subject: Add (guix zlib). * guix/zlib.scm, tests/zlib.scm: New files. * Makefile.am (MODULES): Add guix/zlib.scm. (SCM_TESTS): Add tests/zlib.scm. * m4/guix.m4 (GUIX_LIBGCRYPT_LIBDIR): New macro. * configure.ac (LIBGCRYPT_LIBDIR): Use it. Define and substitute 'LIBZ'. * guix/config.scm.in (%libz): New variable. --- .dir-locals.el | 2 + Makefile.am | 2 + configure.ac | 11 +++ guix/config.scm.in | 6 +- guix/zlib.scm | 234 +++++++++++++++++++++++++++++++++++++++++++++++++++++ m4/guix.m4 | 11 +++ tests/zlib.scm | 63 +++++++++++++++ 7 files changed, 328 insertions(+), 1 deletion(-) create mode 100644 guix/zlib.scm create mode 100644 tests/zlib.scm (limited to 'tests') diff --git a/.dir-locals.el b/.dir-locals.el index c7ceb9e9f..572a35f82 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -41,6 +41,8 @@ (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) (eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2)) (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) + (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1)) (eval . (put 'signature-case 'scheme-indent-function 1)) (eval . (put 'emacs-batch-eval 'scheme-indent-function 0)) (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 37a0aef7d..576177f6d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -57,6 +57,7 @@ MODULES = \ guix/licenses.scm \ guix/graph.scm \ guix/cve.scm \ + guix/zlib.scm \ guix/build-system.scm \ guix/build-system/ant.scm \ guix/build-system/cmake.scm \ @@ -258,6 +259,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/challenge.scm \ tests/cve.scm \ + tests/zlib.scm \ tests/file-systems.scm \ tests/system.scm \ tests/services.scm \ diff --git a/configure.ac b/configure.ac index 7c6fcc9ec..8367b41f3 100644 --- a/configure.ac +++ b/configure.ac @@ -194,6 +194,17 @@ AC_SUBST([LIBGCRYPT_LIBDIR]) GUIX_ASSERT_LIBGCRYPT_USABLE +dnl Library name of zlib suitable for 'dynamic-link'. +GUIX_LIBZ_LIBDIR([libz_libdir]) +if test "x$libz_libdir" = "x"; then + LIBZ="libz" +else + LIBZ="$libz_libdir/libz" +fi +AC_MSG_CHECKING([for zlib's shared library name]) +AC_MSG_RESULT([$LIBZ]) +AC_SUBST([LIBZ]) + AC_CACHE_SAVE m4_include([config-daemon.ac]) diff --git a/guix/config.scm.in b/guix/config.scm.in index adffa0cfe..6d42cf233 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ %guix-register-program %system %libgcrypt + %libz %nix-instantiate %gzip %bzip2 @@ -72,6 +73,9 @@ (define %libgcrypt "@LIBGCRYPT@") +(define %libz + "@LIBZ@") + (define %nix-instantiate "@NIX_INSTANTIATE@") diff --git a/guix/zlib.scm b/guix/zlib.scm new file mode 100644 index 000000000..51e5e9e42 --- /dev/null +++ b/guix/zlib.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix zlib) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (system foreign) + #:use-module (guix config) + #:export (zlib-available? + make-gzip-input-port + make-gzip-output-port + call-with-gzip-input-port + call-with-gzip-output-port + %default-buffer-size + %default-compression-level)) + +;;; Commentary: +;;; +;;; Bindings to the gzip-related part of zlib's API. The main limitation of +;;; this API is that it requires a file descriptor as the source or sink. +;;; +;;; Code: + +(define %zlib + ;; File name of zlib's shared library. When updating via 'guix pull', + ;; '%libz' might be undefined so protect against it. + (delay (dynamic-link (if (defined? '%libz) + %libz + "libz")))) + +(define (zlib-available?) + "Return true if zlib is available, #f otherwise." + (false-if-exception (force %zlib))) + +(define (zlib-procedure ret name parameters) + "Return a procedure corresponding to C function NAME in libz, or #f if +either zlib or the function could not be found." + (match (false-if-exception (dynamic-func name (force %zlib))) + ((? pointer? ptr) + (pointer->procedure ret ptr parameters)) + (#f + #f))) + +(define-wrapped-pointer-type + ;; Scheme counterpart of the 'gzFile' opaque type. + gzip-file? + pointer->gzip-file + gzip-file->pointer + (lambda (obj port) + (format port "#" + (number->string (object-address obj) 16)))) + +(define gzerror + (let ((proc (zlib-procedure '* "gzerror" '(* *)))) + (lambda (gzfile) + (let* ((errnum* (make-bytevector (sizeof int))) + (ptr (proc (gzip-file->pointer gzfile) + (bytevector->pointer errnum*)))) + (values (bytevector-sint-ref errnum* 0 + (native-endianness) (sizeof int)) + (pointer->string ptr)))))) + +(define gzdopen + (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) + (lambda (fd mode) + "Open file descriptor FD as a gzip stream with the given MODE. MODE must +be a string denoting the how FD is to be opened, such as \"r\" for reading or +\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also +closes FD." + (let ((result (proc fd (string->pointer mode)))) + (if (null-pointer? result) + (throw 'zlib-error 'gzdopen) + (pointer->gzip-file result)))))) + +(define gzread! + (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Read up to COUNT bytes from GZFILE into BV at offset START. Return the +number of uncompressed bytes actually read." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (< ret 0) + (throw 'zlib-error 'gzread! ret) + ret))))) + +(define gzwrite + (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Write up to COUNT bytes from BV at offset START into GZFILE. Return +the number of uncompressed bytes written, a strictly positive integer." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (<= ret 0) + (throw 'zlib-error 'gzwrite ret) + ret))))) + +(define gzbuffer! + (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) + (lambda (gzfile size) + "Change the internal buffer size of GZFILE to SIZE bytes." + (let ((ret (proc (gzip-file->pointer gzfile) size))) + (unless (zero? ret) + (throw 'zlib-error 'gzbuffer! ret)))))) + +(define gzeof? + (let ((proc (zlib-procedure int "gzeof" '(*)))) + (lambda (gzfile) + "Return true if the end-of-file has been reached on GZFILE." + (not (zero? (proc (gzip-file->pointer gzfile))))))) + +(define gzclose + (let ((proc (zlib-procedure int "gzclose" '(*)))) + (lambda (gzfile) + "Close GZFILE." + (let ((ret (proc (gzip-file->pointer gzfile)))) + (unless (zero? ret) + (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) + + + +;;; +;;; Port interface. +;;; + +(define %default-buffer-size + ;; Default buffer size, as documented in . + 8192) + +(define %default-compression-level + ;; Z_DEFAULT_COMPRESSION. + -1) + +(define (close-procedure gzfile port) + "Return a procedure that closes GZFILE, ensuring its underlying PORT is +closed even if closing GZFILE triggers an exception." + (lambda () + (catch 'zlib-error + (lambda () + ;; 'gzclose' closes the underlying file descriptor. 'close-port' + ;; calls close(2), gets EBADF, which is ignores. + (gzclose gzfile) + (close-port port)) + (lambda args + ;; Make sure PORT is closed despite the zlib error. + (close-port port) + (apply throw args))))) + +(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) + "Return an input port that decompresses data read from PORT, a file port. +PORT is automatically closed when the resulting port is closed. BUFFER-SIZE +is the size in bytes of the internal buffer, 8 KiB by default; using a larger +buffer increases decompression speed." + (define gzfile + (gzdopen (fileno port) "r")) + + (define (read! bv start count) + ;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF? + (gzread! gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-input-port "gzip-input" read! #f #f + (close-procedure gzfile port))) + +(define* (make-gzip-output-port port + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Return an output port that compresses data at the given LEVEL, using PORT, +a file port, as its sink. PORT is automatically closed when the resulting +port is closed." + (define gzfile + (gzdopen (fileno port) + (string-append "w" (number->string level)))) + + (define (write! bv start count) + (gzwrite gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-output-port "gzip-output" write! #f #f + (close-procedure gzfile port))) + +(define* (call-with-gzip-input-port port proc + #:key (buffer-size %default-buffer-size)) + "Call PROC with a port that wraps PORT and decompresses data read from it. +PORT is closed upon completion. The gzip internal buffer size is set to +BUFFER-SIZE bytes." + (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +(define* (call-with-gzip-output-port port proc + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Call PROC with an output port that wraps PORT and compresses data. PORT is +close upon completion. The gzip internal buffer size is set to BUFFER-SIZE +bytes." + (let ((gzip (make-gzip-output-port port + #:level level + #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +;;; zlib.scm ends here diff --git a/m4/guix.m4 b/m4/guix.m4 index 2d3dfd282..a4f83f029 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -308,6 +308,17 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [ $1="$guix_cv_libgcrypt_libdir" ]) +dnl GUIX_LIBZ_LIBDIR VAR +dnl +dnl Attempt to determine libz's LIBDIR; store the result in VAR. +AC_DEFUN([GUIX_LIBZ_LIBDIR], [ + AC_REQUIRE([PKG_PROG_PKG_CONFIG]) + AC_CACHE_CHECK([zlib's library directory], + [guix_cv_libz_libdir], + [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"]) + $1="$guix_cv_libz_libdir" +]) + dnl GUIX_CURRENT_LOCALSTATEDIR dnl dnl Determine the localstatedir of an existing Guix installation and set diff --git a/tests/zlib.scm b/tests/zlib.scm new file mode 100644 index 000000000..5455240a7 --- /dev/null +++ b/tests/zlib.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-zlib) + #:use-module (guix zlib) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) + +;; Test the (guix zlib) module. + +(unless (zlib-available?) + (exit 77)) + +(test-begin "zlib") + +(test-assert "compression/decompression pipe" + (let ((data (random-bytevector (+ (random 10000) + (* 20 1024))))) + (match (pipe) + ((parent . child) + (match (primitive-fork) + (0 ;compress + (dynamic-wind + (const #t) + (lambda () + (close-port parent) + (call-with-gzip-output-port child + (lambda (port) + (put-bytevector port data)))) + (lambda () + (primitive-exit 0)))) + (pid ;decompress + (begin + (close-port child) + (let ((received (call-with-gzip-input-port parent + (lambda (port) + (get-bytevector-all port)) + #:buffer-size (* 64 1024)))) + (match (waitpid pid) + ((_ . status) + (and (zero? status) + (port-closed? parent) + (bytevector=? received data)))))))))))) + +(test-end) -- cgit v1.3 From 4a1fc562ae5eedf40f6ae4eabe30580b0983b8f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Jul 2016 23:58:34 +0200 Subject: publish: Add '--compression'. * guix/scripts/publish.scm (show-help, %options): Add '--compression'. (): New record type. (%no-compression, %default-gzip-compression): New variables. (%default-options): Add 'compression' key. (narinfo-string): Add #:compression parameter and honor it. (render-narinfo): Likewise. (render-nar): Likewise. : Add call to 'declare-header!'. (swallow-zlib-error): New macro. (nar-response-port): New procedure. (http-write): Add call to 'force-output'. Use 'nar-response-port' instead of 'response-port'. Use 'swallow-zlib-error'. (make-request-handler): Add #:compression parameter and honor it. Add "nar/gzip" URL handler. (run-publish-server): Add #:compression parameter and honor it. (guix-publish): Honor --compression. * tests/publish.scm (http-get-port, wait-until-ready): New procedures. : Run main server with "-C0". Call 'wait-until-ready'. ("/nar/gzip/*", "/*.narinfo with compression"): New tests. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 12 ++++ guix/scripts/publish.scm | 163 ++++++++++++++++++++++++++++++++++++++++------- tests/publish.scm | 59 +++++++++++++++-- 3 files changed, 203 insertions(+), 31 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index a2732dede..6e8fb483f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5644,6 +5644,18 @@ accept connections from any interface. Change privileges to @var{user} as soon as possible---i.e., once the server socket is open and the signing key has been read. +@item --compression[=@var{level}] +@itemx -C [@var{level}] +Compress data using the given @var{level}. When @var{level} is zero, +disable compression. The range 1 to 9 corresponds to different gzip +compression levels: 1 is the fastest, and 9 is the best (CPU-intensive). +The default is 3. + +Note compression occurs on the fly and the compressed streams are not +cached. Thus, to reduce load on the machine that runs @command{guix +publish}, it may be a good idea to choose a low compression level, or to +run @command{guix publish} behind a caching proxy. + @item --ttl=@var{ttl} Produce @code{Cache-Control} HTTP headers that advertise a time-to-live (TTL) of @var{ttl}. @var{ttl} must denote a duration: @code{5d} means 5 diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4c0aa8e41..3e1ecb9d1 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -27,6 +27,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -45,6 +46,7 @@ #:use-module (guix pk-crypto) #:use-module (guix store) #:use-module (guix serialization) + #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) #:export (guix-publish)) @@ -58,6 +60,9 @@ Publish ~a over HTTP.\n") %store-directory) --listen=HOST listen on the network interface for HOST")) (display (_ " -u, --user=USER change privileges to USER as soon as possible")) + (display (_ " + -C, --compression[=LEVEL] + compress archives at LEVEL")) (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " @@ -79,6 +84,20 @@ Publish ~a over HTTP.\n") %store-directory) (leave (_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) +;; Nar compression parameters. +(define-record-type + (compression type level) + compression? + (type compression-type) + (level compression-level)) + +(define %no-compression + (compression 'none 0)) + +(define %default-gzip-compression + ;; Since we compress on the fly, default to fast compression. + (compression 'gzip 3)) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -102,6 +121,14 @@ Publish ~a over HTTP.\n") %store-directory) (() (leave (_ "lookup of host '~a' returned nothing") name))))) + (option '(#\C "compression") #f #t + (lambda (opt name arg result) + (match (if arg (string->number* arg) 3) + (0 + (alist-cons 'compression %no-compression result)) + (level + (alist-cons 'compression (compression 'gzip level) + result))))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -117,6 +144,12 @@ Publish ~a over HTTP.\n") %store-directory) (define %default-options `((port . 8080) + + ;; Default to fast & low compression. + (compression . ,(if (zlib-available?) + %default-gzip-compression + %no-compression)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -152,12 +185,20 @@ Publish ~a over HTTP.\n") %store-directory) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store store-path key) +(define* (narinfo-string store store-path key + #:key (compression %no-compression)) "Generate a narinfo key/value string for STORE-PATH; an exception is raised -if STORE-PATH is invalid. The narinfo is signed with KEY." +if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The +narinfo is signed with KEY." (let* ((path-info (query-path-info store store-path)) - (url (encode-and-join-uri-path (list "nar" - (basename store-path)))) + (url (encode-and-join-uri-path + `("nar" + ,@(match compression + (($ 'none) + '()) + (($ type) + (list (symbol->string type)))) + ,(basename store-path)))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -166,13 +207,16 @@ if STORE-PATH is invalid. The narinfo is signed with KEY." " ")) (deriver (path-info-deriver path-info)) (base-info (format #f - "StorePath: ~a + "\ +StorePath: ~a URL: ~a -Compression: none +Compression: ~a NarHash: sha256:~a NarSize: ~d References: ~a~%" - store-path url hash size references)) + store-path url + (compression-type compression) + hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -209,7 +253,8 @@ References: ~a~%" (format port "~a: ~a~%" key value))) %nix-cache-info)))) -(define* (render-narinfo store request hash #:key ttl) +(define* (render-narinfo store request hash + #:key ttl (compression %no-compression)) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the 'Cache-Control' header. This allows 'guix substitute' to cache it for an @@ -222,18 +267,35 @@ appropriate duration." `((cache-control (max-age . ,ttl))) '())) (cut display - (narinfo-string store store-path (force %private-key)) - <>))))) - -(define (render-nar store request store-item) + (narinfo-string store store-path (force %private-key) + #:compression compression) + <>))))) + +;; 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 . +(declare-header! "Guix-Nar-Compression" + (lambda (str) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) + compression? + (lambda (compression port) + (match compression + (($ type level) + (write `(compression ,type ,level) port))))) + +(define* (render-nar store request store-item + #:key (compression %no-compression)) "Render archive of the store path corresponding to STORE-ITEM." (let ((store-path (string-append %store-directory "/" store-item))) ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte ;; sequences. (if (valid-path? store store-path) - (values '((content-type . (application/x-nix-archive - (charset . "ISO-8859-1")))) + (values `((content-type . (application/x-nix-archive + (charset . "ISO-8859-1"))) + (guix-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; . @@ -282,6 +344,28 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (values) (apply throw args))))) +(define-syntax-rule (swallow-zlib-error exp ...) + "Swallow 'zlib-error' exceptions raised by EXP..." + (catch 'zlib-error + (lambda () + exp ...) + (const #f))) + +(define (nar-response-port response) + "Return a port on which to write the body of RESPONSE, the response of a +/nar request, according to COMPRESSION." + (match (assoc-ref (response-headers response) 'guix-nar-compression) + (($ 'gzip level) + ;; Note: We cannot used chunked encoding here because + ;; 'make-gzip-output-port' wants a file port. + (make-gzip-output-port (response-port response) + #:level level + #:buffer-size (* 64 1024))) + (($ 'none) + (response-port response)) + (#f + (response-port response)))) + (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." @@ -293,16 +377,20 @@ blocking." (lambda () (let* ((response (write-response (sans-content-length response) client)) - (port (response-port response))) + (port (begin + (force-output client) + (nar-response-port response)))) ;; XXX: Given our ugly workaround for in ;; 'render-nar', BODY here is just the file name of the store item. ;; We call 'write-file' from here because we know that's the only ;; way to avoid building the whole nar in memory, which could ;; quickly become a real problem. As a bonus, we even do ;; sendfile(2) directly from the store files to the socket. - (swallow-EPIPE - (write-file (utf8->string body) port)) - (close-port port) + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port)) (values))))) (_ ;; Handle other responses sequentially. @@ -316,7 +404,10 @@ blocking." http-write (@@ (web server http) http-close)) -(define* (make-request-handler store #:key narinfo-ttl) +(define* (make-request-handler store + #:key + narinfo-ttl + (compression %no-compression)) (lambda (request body) (format #t "~a ~a~%" (request-method request) @@ -330,16 +421,37 @@ blocking." (((= 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)) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:compression compression)) + + ;; Use different URLs depending on the compression type. This + ;; guarantees that /nar URLs remain valid even when 'guix publish' + ;; is restarted with different compression parameters. + ;; /nar/ (("nar" store-item) - (render-nar store request store-item)) + (render-nar store request store-item + #:compression %no-compression)) + ;; /nar/gzip/ + (("nar" "gzip" store-item) + (if (zlib-available?) + (render-nar store request store-item + #:compression + (match compression + (($ 'gzip) + compression) + (_ + %default-gzip-compression))) + (not-found request))) (_ (not-found request))) (not-found request)))) (define* (run-publish-server socket store - #:key narinfo-ttl) - (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl) + #:key (compression %no-compression) narinfo-ttl) + (run-server (make-request-handler store + #:narinfo-ttl narinfo-ttl + #:compression compression) concurrent-http-server `(#:socket ,socket))) @@ -378,6 +490,7 @@ blocking." (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) (ttl (assoc-ref opts 'narinfo-ttl)) + (compression (assoc-ref opts 'compression)) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) @@ -404,4 +517,6 @@ consider using the '--user' option!~%"))) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server socket store #:narinfo-ttl ttl))))) + (run-publish-server socket store + #:compression compression + #:narinfo-ttl ttl))))) diff --git a/tests/publish.scm b/tests/publish.scm index d6d537c58..9bf181f1f 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -28,12 +28,15 @@ #:use-module (guix store) #:use-module (guix base32) #:use-module (guix base64) + #:use-module ((guix records) #:select (recutils->alist)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix pk-crypto) + #:use-module (guix zlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) @@ -52,20 +55,28 @@ (call-with-values (lambda () (http-get uri)) (lambda (response body) body))) +(define (http-get-port uri) + (call-with-values (lambda () (http-get uri #:streaming? #t)) + (lambda (response port) port))) + (define (publish-uri route) (string-append "http://localhost:6789" route)) ;; Run a local publishing server in a separate thread. (call-with-new-thread (lambda () - (guix-publish "--port=6789"))) ; attempt to avoid port collision + (guix-publish "--port=6789" "-C0"))) ;attempt to avoid port collision + +(define (wait-until-ready port) + ;; Wait until the server is accepting connections. + (let ((conn (socket PF_INET SOCK_STREAM 0))) + (let loop () + (unless (false-if-exception + (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port)) + (loop))))) -;; Wait until the server is accepting connections. -(let ((conn (socket PF_INET SOCK_STREAM 0))) - (let loop () - (unless (false-if-exception - (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789)) - (loop)))) +;; Wait until the two servers are ready. +(wait-until-ready 6789) (test-begin "publish") @@ -145,6 +156,40 @@ References: ~%" (call-with-input-string nar (cut restore-file <> temp))) (call-with-input-file temp read-string)))) +(unless (zlib-available?) + (test-skip 1)) +(test-equal "/nar/gzip/*" + "bar" + (call-with-temporary-output-file + (lambda (temp port) + (let ((nar (http-get-port + (publish-uri + (string-append "/nar/gzip/" (basename %item)))))) + (call-with-gzip-input-port nar + (cut restore-file <> temp))) + (call-with-input-file temp read-string)))) + +(unless (zlib-available?) + (test-skip 1)) +(test-equal "/*.narinfo with compression" + `(("StorePath" . ,%item) + ("URL" . ,(string-append "nar/gzip/" (basename %item))) + ("Compression" . "gzip")) + (let ((thread (call-with-new-thread + (lambda () + (guix-publish "--port=6799" "-C5"))))) + (wait-until-ready 6799) + (let* ((url (string-append "http://localhost:6799/" + (store-path-hash-part %item) ".narinfo")) + (body (http-get-port url))) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body))))) + (test-equal "/nar/ with properly encoded '+' sign" "Congrats!" (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) -- cgit v1.3