From 3e43166ffc11fb117c55da594e57866a75625900 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Apr 2017 23:52:19 +0200 Subject: gexp: 'lower-object' raises an exception when passed an invalid object. * guix/gexp.scm (&gexp-error, &gexp-input-error): New error conditions. (lower-object): Raise &gexp-input-error when 'lookup-compiler' returns #f. * tests/gexp.scm ("lower-object & gexp-input-error?"): New test. * guix/ui.scm (call-with-error-handling): Add case for 'gexp-input-error?'. --- tests/gexp.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index b3f7323984..41a53ae5a4 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -946,6 +946,13 @@ (string=? (readlink (string-append comp "/text")) text))))))) +(test-assert "lower-object & gexp-input-error?" + (guard (c ((gexp-input-error? c) + (gexp-error-invalid-input c))) + (run-with-store %store + (lower-object (current-module)) + #:guile-for-build (%guile-for-build)))) + (test-assert "printer" (string-match "^#$" -- cgit v1.2.3 From 76c486196f299716be33df86d06b3ce2b79dd77f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 4 Apr 2017 00:00:41 +0200 Subject: packages: Catch invalid input errors for structs. Reported by Thomas Sigurdsen at . * guix/packages.scm (expand-input): Add 'guard' form around call to 'package-source-derivation'. * tests/packages.scm (dummy): New test. --- guix/packages.scm | 12 ++++++++++-- tests/packages.scm | 8 ++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/packages.scm b/guix/packages.scm index 61171b8342..b68b3de6d2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -31,7 +31,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) @@ -846,7 +845,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/tests/packages.scm b/tests/packages.scm index aa29758830..51dc1ba2b0 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -470,6 +470,14 @@ (package-derivation %store p) #f))) +(let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module))))))) + (test-equal "&package-input-error" + (list dummy (current-module)) + (guard (c ((package-input-error? c) + (list (package-error-package c) + (package-error-invalid-input c)))) + (package-derivation %store dummy)))) + (test-assert "reference to non-existent output" ;; See . (parameterize ((%graft? #f)) -- cgit v1.2.3 From f73bb91ebe8d78f54bb90d2168b353a4f5210f02 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 4 Apr 2017 00:06:37 +0200 Subject: tests: Adjust search-paths test following the introduction of aarch64. Fixes a regression introduced in 3b88f3767d9f3ad2cc64173525cd53d429bfe7e7. * tests/search-paths.scm ("evaluate-search-paths, separator is #f"): Change the expected result to "aarch64-linux". --- tests/search-paths.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/search-paths.scm b/tests/search-paths.scm index 2a4c18dd76..8dad424415 100644 --- a/tests/search-paths.scm +++ b/tests/search-paths.scm @@ -29,7 +29,7 @@ (test-equal "evaluate-search-paths, separator is #f" (string-append %top-srcdir - "/gnu/packages/bootstrap/armhf-linux") + "/gnu/packages/bootstrap/aarch64-linux") ;; The following search path spec should evaluate to a single item: the ;; first directory that matches the "-linux$" pattern in -- cgit v1.2.3 From f37f2b83fa95c1fe2bf01c4b8072cfc23d4c67ec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 5 Apr 2017 15:19:15 +0200 Subject: packages: Add 'package-mapping' and base 'package-input-rewriting' on it. * guix/packages.scm (package-mapping): New procedure. (package-input-rewriting): Rewrite in terms of 'package-mapping'. * tests/packages.scm ("package-mapping"): New test. * doc/guix.texi (Defining Packages): Document it. --- doc/guix.texi | 10 ++++++++++ guix/packages.scm | 56 ++++++++++++++++++++++++++++++++++++------------------ tests/packages.scm | 27 ++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index aa779e38e2..b2498d039e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2946,6 +2946,16 @@ with @var{libressl}. Then we use it to define a @dfn{variant} of the This is exactly what the @option{--with-input} command-line option does (@pxref{Package Transformation Options, @option{--with-input}}). +A more generic procedure to rewrite a package dependency graph is +@code{package-mapping}: it supports arbitrary changes to nodes in the +graph. + +@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] +Return a procedure that, given a package, applies @var{proc} to all the packages +depended on and returns the resulting package. The procedure stops recursion +when @var{cut?} returns true for a given package. +@end deffn + @menu * package Reference :: The package data type. * origin Reference:: The origin data type. diff --git a/guix/packages.scm b/guix/packages.scm index b68b3de6d2..44f2c32fb7 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -98,6 +98,7 @@ package-transitive-propagated-inputs package-transitive-native-search-paths package-transitive-supported-systems + package-mapping package-input-rewriting package-source-derivation package-derivation @@ -741,36 +742,53 @@ 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))) + ;;; ;;; Package derivations. diff --git a/tests/packages.scm b/tests/packages.scm index 51dc1ba2b0..930374dabf 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -886,6 +886,33 @@ (and (build-derivations %store (list drv)) (file-exists? (string-append out "/bin/make"))))))) +(test-equal "package-mapping" + 42 + (let* ((dep (dummy-package "chbouib" + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,grep) + ("baz" ,dep))))) + (transform (lambda (p) + (package (inherit p) (source 42)))) + (rewrite (package-mapping transform)) + (p1 (rewrite p0))) + (and (eq? p1 (rewrite p0)) + (eqv? 42 (package-source p1)) + (match (package-inputs p1) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (and (eq? dep1 (rewrite coreutils)) ;memoization + (eq? dep2 (rewrite grep)) + (eq? dep3 (rewrite dep)) + (eqv? 42 + (package-source dep1) (package-source dep2) + (package-source dep3)) + (match (package-native-inputs dep3) + ((("x" dep)) + (and (eq? dep (rewrite grep)) + (package-source dep)))))))))) + (test-assert "package-input-rewriting" (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) -- cgit v1.2.3 From c923f831160ddbda21d8ea1f2df4670550f3e9d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 6 Apr 2017 18:22:53 +0200 Subject: size: Add test to multiple 'store-profile' arguments. * tests/size.scm ("store-profile with multiple items"): New test. --- tests/size.scm | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/size.scm b/tests/size.scm index 068ebc1d68..575b1abfdd 100644 --- a/tests/size.scm +++ b/tests/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -86,6 +86,22 @@ (profile-self-size profile3) (profile-self-size profile4)))))))))))) +(test-assertm "store-profile with multiple items" + (mlet* %store-monad ((file1 (gexp->derivation "file1" + #~(symlink #$%bootstrap-guile + #$output))) + (file2 (text-file* "file2" + "the file => " file1))) + (mbegin %store-monad + (built-derivations (list file2)) + (mlet %store-monad ((profiles (store-profile + (list (derivation->output-path file2) + (derivation->output-path file1)))) + (reference (store-profile + (list (derivation->output-path file2))))) + (return (and (= (length profiles) 4) + (lset= equal? profiles reference))))))) + (test-end "size") ;;; Local Variables: -- cgit v1.2.3 From efe7d19a9edafb793dca21dcefce89ead3465030 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Apr 2017 22:12:37 +0200 Subject: services: 'service-parameters' becomes 'service-value'. * gnu/services.scm ()[parameters]: Rename to... [value]: ... this. Change calls to 'service-parameters' to 'service-value'. * gnu/system.scm, gnu/tests/base.scm, guix/scripts/system.scm, tests/services.scm: Likewise. * doc/guix.texi (Service Reference): Adjust accordingly. --- doc/guix.texi | 2 +- gnu/services.scm | 21 +++++++++++++-------- gnu/system.scm | 8 ++++---- gnu/tests/base.scm | 2 +- guix/scripts/system.scm | 6 +++--- tests/services.scm | 4 ++-- 6 files changed, 24 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 07f52becf8..bf46f89bf2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -15684,7 +15684,7 @@ Return true if @var{obj} is a service. Return the type of @var{service}---i.e., a @code{} object. @end deffn -@deffn {Scheme Procedure} service-parameters @var{service} +@deffn {Scheme Procedure} service-value @var{service} Return the value associated with @var{service}. It represents its parameters. @end deffn diff --git a/gnu/services.scm b/gnu/services.scm index 9f6e323e18..af4cffe819 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -51,7 +51,8 @@ service service? service-kind - service-parameters + service-value + service-parameters ;deprecated simple-service modify-services @@ -142,10 +143,14 @@ ;; Services of a given type. (define-record-type - (service type parameters) + (service type value) service? (type service-kind) - (parameters service-parameters)) + (value service-value)) + +(define service-parameters + ;; Deprecated alias. + service-value) (define (simple-service name target value) "Return a service that extends TARGET with VALUE. This works by creating a @@ -161,7 +166,7 @@ singleton service type NAME, of which the returned service is an instance." service) ((_ svc (kind param => exp ...) clauses ...) (if (eq? (service-kind svc) kind) - (let ((param (service-parameters svc))) + (let ((param (service-value svc))) (service (service-kind svc) (begin exp ...))) (%modify-service svc clauses ...))))) @@ -321,7 +326,7 @@ file." (define* (activation-service->script service) "Return as a monadic value the activation script for SERVICE, a service of ACTIVATION-SCRIPT-TYPE." - (activation-script (service-parameters service))) + (activation-script (service-value service))) (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." @@ -432,7 +437,7 @@ and FILE could be \"/usr/bin/env\"." (define (etc-directory service) "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." - (files->etc-directory (service-parameters service))) + (files->etc-directory (service-value service))) (define (files->etc-directory files) (file-union "etc" files)) @@ -605,7 +610,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (match (find (matching-extension target) (service-type-extensions (service-kind service))) (($ _ compute) - (compute (service-parameters service)))))) + (compute (service-value service)))))) (match (filter (lambda (service) (eq? (service-kind service) target-type)) @@ -616,7 +621,7 @@ TARGET-TYPE; return the root service adjusted accordingly." (extensions (map (apply-extension sink) dependents)) (extend (service-type-extend (service-kind sink))) (compose (service-type-compose (service-kind sink))) - (params (service-parameters sink))) + (params (service-value sink))) ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a ;; different type than the elements of EXTENSIONS. (if extend diff --git a/gnu/system.scm b/gnu/system.scm index 69cbc8a081..89c4150f99 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -615,7 +615,7 @@ hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) (boot (fold-services services #:target-type boot-service-type))) ;; BOOT is the script as a monadic value. - (service-parameters boot))) + (service-value boot))) (define (operating-system-user-accounts os) "Return the list of user accounts of OS." @@ -623,12 +623,12 @@ hardware-related operations as necessary when booting a Linux container." (account (fold-services services #:target-type account-service-type))) (filter user-account? - (service-parameters account)))) + (service-value account)))) (define (operating-system-shepherd-service-names os) "Return the list of Shepherd service names for OS." (append-map shepherd-service-provision - (service-parameters + (service-value (fold-services (operating-system-services os) #:target-type shepherd-root-service-type)))) @@ -638,7 +638,7 @@ hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) (system (fold-services services))) ;; SYSTEM contains the derivation as a monadic value. - (service-parameters system))) + (service-value system))) (define* (operating-system-profile os #:key container?) "Return a derivation that builds the system profile of OS." diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index bcb8299c73..6ce5ab3de1 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -56,7 +56,7 @@ passed a gexp denoting the marionette, and it must return gexp that is inserted before the first test. This is used to introduce an extra initialization step, such as entering a LUKS passphrase." (define special-files - (service-parameters + (service-value (fold-services (operating-system-services os) #:target-type special-files-service-type))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9d86efdd77..9ffdc15abb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -289,7 +289,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))) @@ -487,7 +487,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))) @@ -711,7 +711,7 @@ output when building a system derivation, such as a disk image." (let* ((services (operating-system-services os)) (pid1 (fold-services services #:target-type shepherd-root-service-type)) - (shepherds (service-parameters pid1)) ;list of + (shepherds (service-value pid1)) ;list of (sinks (filter (lambda (service) (null? (shepherd-service-requirement service))) shepherds))) diff --git a/tests/services.scm b/tests/services.scm index 8993c3dafc..7983427a7d 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,7 +75,7 @@ (iota 5 1))) #:target-type t1))) (and (eq? (service-kind r) t1) - (service-parameters r)))) + (service-value r)))) (test-assert "fold-services, ambiguity" (let* ((t1 (service-type (name 't1) (extensions '()) -- cgit v1.2.3 From 1bb895eabf74a1e571887eb1521915e668a5c28d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Apr 2017 23:53:23 +0200 Subject: services: Service types can now specify a default value for instances. * gnu/services.scm (&no-default-value): New variable. ()[default-value]: New field. (): Rename constructor from 'service' to 'make-service'. (service): New macro. (%service-with-default-value): New procedure. (&missing-value-service-error): New error condition. * tests/services.scm ("services, default value"): New test. * doc/guix.texi (Service Types and Services): Document 'default-value'. (Service Reference): Explain default values. --- doc/guix.texi | 39 ++++++++++++++++++++++++++++++---- gnu/services.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++----- tests/services.scm | 11 ++++++++++ 3 files changed, 103 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index bf46f89bf2..fdd71141f0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -15555,11 +15555,12 @@ with a simple example, the service type for the Guix build daemon (extensions (list (service-extension shepherd-root-service-type guix-shepherd-service) (service-extension account-service-type guix-accounts) - (service-extension activation-service-type guix-activation))))) + (service-extension activation-service-type guix-activation))) + (default-value (guix-configuration)))) @end example @noindent -It defines two things: +It defines three things: @enumerate @item @@ -15572,6 +15573,9 @@ service, returns a list of objects to extend the service of that type. Every service type has at least one service extension. The only exception is the @dfn{boot service type}, which is the ultimate service. + +@item +Optionally, a default value for instances of this type. @end enumerate In this example, @var{guix-service-type} extends three services: @@ -15607,7 +15611,13 @@ A service of this type is instantiated like this: The second argument to the @code{service} form is a value representing the parameters of this specific service instance. @xref{guix-configuration-type, @code{guix-configuration}}, for -information about the @code{guix-configuration} data type. +information about the @code{guix-configuration} data type. When the +value is omitted, the default value specified by +@code{guix-service-type} is used: + +@example +(service guix-service-type) +@end example @var{guix-service-type} is quite simple because it extends other services but is not extensible itself. @@ -15670,10 +15680,31 @@ Services}). This section provides a reference on how to manipulate services and service types. This interface is provided by the @code{(gnu services)} module. -@deffn {Scheme Procedure} service @var{type} @var{value} +@deffn {Scheme Procedure} service @var{type} [@var{value}] Return a new service of @var{type}, a @code{} object (see below.) @var{value} can be any object; it represents the parameters of this particular service instance. + +When @var{value} is omitted, the default value specified by @var{type} +is used; if @var{type} does not specify a default value, an error is +raised. + +For instance, this: + +@example +(service openssh-service-type) +@end example + +@noindent +is equivalent to this: + +@example +(service openssh-service-type + (openssh-configuration)) +@end example + +In both cases the result is an instance of @code{openssh-service-type} +with the default configuration. @end deffn @deffn {Scheme Procedure} service? @var{obj} diff --git a/gnu/services.scm b/gnu/services.scm index af4cffe819..b1b53fd18b 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -25,6 +25,7 @@ #:use-module (guix profiles) #:use-module (guix sets) #:use-module (guix ui) + #:use-module ((guix utils) #:select (source-properties->location)) #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) @@ -47,6 +48,7 @@ service-type-extensions service-type-compose service-type-extend + service-type-default-value service service? @@ -60,6 +62,9 @@ fold-services service-error? + missing-value-service-error? + missing-value-service-error-type + missing-value-service-error-location missing-target-service-error? missing-target-service-error-service missing-target-service-error-target-type @@ -119,6 +124,10 @@ (target service-extension-target) ; (compute service-extension-compute)) ;params -> params +(define &no-default-value + ;; Value used to denote service types that have no associated default value. + '(no default value)) + (define-record-type* service-type make-service-type service-type? (name service-type-name) ;symbol (for debugging) @@ -132,7 +141,11 @@ ;; Extend the services' own parameters with the extension composition. (extend service-type-extend ;list of Any -> parameters - (default #f))) + (default #f)) + + ;; Optional default value for instances of this type. + (default-value service-type-default-value ;Any + (default &no-default-value))) (define (write-service-type type port) (format port "#" @@ -143,11 +156,53 @@ ;; Services of a given type. (define-record-type - (service type value) + (make-service type value) service? (type service-kind) (value service-value)) +(define-syntax service + (syntax-rules () + "Return a service instance of TYPE. The service value is VALUE or, if +omitted, TYPE's default value." + ((_ type value) + (make-service type value)) + ((_ type) + (%service-with-default-value (current-source-location) + type)))) + +(define (%service-with-default-value location type) + "Return a instance of service type TYPE with its default value, if any. If +TYPE does not have a default value, an error is raised." + ;; TODO: Currently this is a run-time error but with a little bit macrology + ;; we could turn it into an expansion-time error. + (let ((default (service-type-default-value type))) + (if (eq? default &no-default-value) + (let ((location (source-properties->location location))) + (raise + (condition + (&missing-value-service-error (type type) (location location)) + (&message + (message (format #f (_ "~a: no value specified \ +for service of type '~a'") + (location->string location) + (service-type-name type))))))) + (service type default)))) + +(define-condition-type &service-error &error + service-error?) + +(define-condition-type &missing-value-service-error &service-error + missing-value-service-error? + (type missing-value-service-error-type) + (location missing-value-service-error-location)) + + + +;;; +;;; Helpers. +;;; + (define service-parameters ;; Deprecated alias. service-value) @@ -541,9 +596,6 @@ kernel." ;;; Service folding. ;;; -(define-condition-type &service-error &error - service-error?) - (define-condition-type &missing-target-service-error &service-error missing-target-service-error? (service missing-target-service-error-service) diff --git a/tests/services.scm b/tests/services.scm index 7983427a7d..8484ee982a 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -31,6 +31,17 @@ (test-begin "services") +(test-equal "services, default value" + '(42 123 234 error) + (let* ((t1 (service-type (name 't1) (extensions '()))) + (t2 (service-type (name 't2) (extensions '()) + (default-value 42)))) + (list (service-value (service t2)) + (service-value (service t2 123)) + (service-value (service t1 234)) + (guard (c ((missing-value-service-error? c) 'error)) + (service t1))))) + (test-assert "service-back-edges" (let* ((t1 (service-type (name 't1) (extensions '()) (compose +) (extend *))) -- cgit v1.2.3 From 1563d6c79f759cb9a6cc5561463653f0f184cb36 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Apr 2017 22:04:31 +0200 Subject: Add (guix workers). * guix/workers.scm, tests/workers.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * .dir-locals.el: Add rule for 'eventually'. --- .dir-locals.el | 1 + Makefile.am | 2 + guix/workers.scm | 123 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/workers.scm | 45 ++++++++++++++++++++ 4 files changed, 171 insertions(+) create mode 100644 guix/workers.scm create mode 100644 tests/workers.scm (limited to 'tests') diff --git a/.dir-locals.el b/.dir-locals.el index 917fd3004a..a2d1eb8160 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -68,6 +68,7 @@ (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) + (eval . (put 'eventually 'scheme-indent-function 1)) ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols. ;; This notably allows '(' in Paredit to not insert a space when the diff --git a/Makefile.am b/Makefile.am index c9671e2d14..46f9547117 100644 --- a/Makefile.am +++ b/Makefile.am @@ -61,6 +61,7 @@ MODULES = \ guix/licenses.scm \ guix/graph.scm \ guix/cve.scm \ + guix/workers.scm \ guix/zlib.scm \ guix/build-system.scm \ guix/build-system/ant.scm \ @@ -296,6 +297,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/challenge.scm \ tests/cve.scm \ + tests/workers.scm \ tests/zlib.scm \ tests/file-systems.scm \ tests/system.scm \ 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 +;;; +;;; 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 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 + (%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 diff --git a/tests/workers.scm b/tests/workers.scm new file mode 100644 index 0000000000..44b882f691 --- /dev/null +++ b/tests/workers.scm @@ -0,0 +1,45 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 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-workers) + #:use-module (guix workers) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-64)) + +(test-begin "workers") + +(test-equal "enqueue" + 4242 + (let* ((pool (make-pool)) + (result 0) + (1+! (let ((lock (make-mutex))) + (lambda () + (with-mutex lock + (set! result (+ result 1))))))) + (let loop ((i 4242)) + (unless (zero? i) + (pool-enqueue! pool 1+!) + (loop (- i 1)))) + (let poll () + (unless (pool-idle? pool) + (pk 'busy result) + (sleep 1) + (poll))) + result)) + +(test-end) -- cgit v1.2.3 From 00753f7038234a0f5a79be3ec9ab949840a18743 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Apr 2017 23:13:40 +0200 Subject: publish: Add '--cache' and '--workers'. Fixes . Reported by . These options allow nars to be "baked" off-line and cached instead of being compressed on the fly. As a side-effect, this allows us to provide a 'Content-Length' header for nars. * guix/scripts/publish.scm (show-help, %options): Add '--cache' and '--workers'. (%default-options): Add 'workers'. (nar-cache-file, narinfo-cache-file, run-single-baker): New procedures. (single-baker): New macro. (render-narinfo/cached, bake-narinfo+nar) (render-nar/cached): New procedures. (make-request-handler): Add #:cache and #:pool parameters and honor them. (run-publish-server): Likewise. (guix-publish): Honor '--cache' and '--workers'. * tests/publish.scm ("with cache"): New test. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 46 ++++++++++- guix/scripts/publish.scm | 197 +++++++++++++++++++++++++++++++++++++++++++---- tests/publish.scm | 54 +++++++++++++ 3 files changed, 280 insertions(+), 17 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index fd3483ee5d..bbb2ba732d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6522,6 +6522,13 @@ archive}), the daemon may download substitutes from it: guix-daemon --substitute-urls=http://example.org:8080 @end example +By default, @command{guix publish} compresses archives on the fly as it +serves them. This ``on-the-fly'' mode is convenient in that it requires +no setup and is immediately available. However, when serving lots of +clients, we recommend using the @option{--cache} option, which enables +caching of the archives before they are sent to clients---see below for +details. + As a bonus, @command{guix publish} also serves as a content-addressed mirror for source files referenced in @code{origin} records (@pxref{origin Reference}). For instance, assuming @command{guix @@ -6559,10 +6566,43 @@ 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. -Compression occurs on the fly and the compressed streams are not +Unless @option{--cache} is used, 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. +publish}, it may be a good idea to choose a low compression level, to +run @command{guix publish} behind a caching proxy, or to use +@option{--cache}. Using @option{--cache} has the advantage that it +allows @command{guix publish} to add @code{Content-Length} HTTP header +to its responses. + +@item --cache=@var{directory} +@itemx -c @var{directory} +Cache archives and meta-data (@code{.narinfo} URLs) to @var{directory} +and only serve archives that are in cache. + +When this option is omitted, archives and meta-data are created +on-the-fly. This can reduce the available bandwidth, especially when +compression is enabled, since this may become CPU-bound. Another +drawback of the default mode is that the length of archives is not known +in advance, so @command{guix publish} does not add a +@code{Content-Length} HTTP header to its responses, which in turn +prevents clients from knowing the amount of data being downloaded. + +Conversely, when @option{--cache} is used, the first request for a store +item (@i{via} a @code{.narinfo} URL) returns 404 and triggers a +background process to @dfn{bake} the archive---computing its +@code{.narinfo} and compressing the archive, if needed. Once the +archive is cached in @var{directory}, subsequent requests succeed and +are served directly from the cache, which guarantees that clients get +the best possible bandwidth. + +The ``baking'' process is performed by worker threads. By default, one +thread per CPU core is created, but this can be customized. See +@option{--workers} below. + +@item --workers=@var{N} +When @option{--cache} is used, request the allocation of @var{N} worker +threads to ``bake'' archives. @item --ttl=@var{ttl} Produce @code{Cache-Control} HTTP headers that advertise a time-to-live diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index f54757b4c9..70d914d60c 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) @@ -45,13 +46,15 @@ #: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 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)) #:export (%public-key %private-key @@ -69,6 +72,10 @@ Publish ~a over HTTP.\n") %store-directory) (display (_ " -C, --compression[=LEVEL] compress archives at LEVEL")) + (display (_ " + -c, --cache=DIRECTORY cache published items to DIRECTORY")) + (display (_ " + --workers=N use N workers to bake items")) (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " @@ -154,6 +161,13 @@ if ITEM is already compressed." (warning (_ "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))) @@ -190,6 +204,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))) @@ -308,6 +325,121 @@ 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* (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." + (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))) + (not-found request)) + (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)) + (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) + 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 . @@ -339,6 +471,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 + ;; . + 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 @@ -495,6 +642,7 @@ blocking." (define* (make-request-handler store #:key + cache pool narinfo-ttl (nar-path "nar") (compression %no-compression)) @@ -515,10 +663,17 @@ 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 - #: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) @@ -534,13 +689,16 @@ blocking." ;; /nar/gzip/ ((components ... "gzip" store-item) (if (and (nar-path? components) (zlib-available?)) - (render-nar store request store-item - #:compression - (match compression - (($ 'gzip) - compression) - (_ - %default-gzip-compression))) + (let ((compression (match 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/ @@ -555,8 +713,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) @@ -606,6 +767,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. @@ -631,6 +794,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/tests/publish.scm b/tests/publish.scm index ea0f4a3477..233b71ce93 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -314,4 +314,58 @@ References: ~%" (call-with-input-string "" port-sha256)))))) (response-code (http-get uri)))) +(unless (zlib-available?) + (test-skip 1)) +(test-equal "with cache" + (list #t + `(("StorePath" . ,%item) + ("URL" . ,(string-append "nar/gzip/" (basename %item))) + ("Compression" . "gzip")) + 200 ;nar/gzip/… + #t ;Content-Length + 200) ;nar/… + (call-with-temporary-directory + (lambda (cache) + (define (wait-for-file file) + (let loop ((i 20)) + (or (file-exists? file) + (begin + (pk 'wait-for-file file) + (sleep 1) + (loop (- i 1)))))) + + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6797" "-C2" + (string-append "--cache=" cache))))))) + (wait-until-ready 6797) + (let* ((base "http://localhost:6797/") + (part (store-path-hash-part %item)) + (url (string-append base part ".narinfo")) + (nar-url (string-append base "/nar/gzip/" (basename %item))) + (cached (string-append cache "/gzip/" (basename %item) + ".narinfo")) + (nar (string-append cache "/gzip/" + (basename %item) ".nar")) + (response (http-get url))) + (and (= 404 (response-code response)) + (wait-for-file cached) + (let ((body (http-get-port url)) + (compressed (http-get nar-url)) + (uncompressed (http-get (string-append base "nar/" + (basename %item))))) + (list (file-exists? nar) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body)) + (response-code compressed) + (= (response-content-length compressed) + (stat:size (stat nar))) + (response-code uncompressed))))))))) + (test-end "publish") -- cgit v1.2.3 From 2ea2aac6e9d58a07c029504f94fb5015cd407e31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Apr 2017 22:07:49 +0200 Subject: Add (guix cache) and use it in (guix scripts substitute). * guix/cache.scm, tests/cache.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * guix/scripts/substitute.scm (obsolete?): Remove. (remove-expired-cached-narinfos): Rename to... (cached-narinfo-expiration-time): ... this. Remove the removal part and only keep the expiration time part. (narinfo-cache-directories): Add optional 'directory' parameter and honor it. (maybe-remove-expired-cached-narinfo): Remove. (cached-narinfo-files): New procedure. (guix-substitute): Use 'maybe-remove-expired-cache-entries' instead of 'maybe-remove-expired-cached-narinfo'. --- Makefile.am | 2 + guix/cache.scm | 106 ++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/substitute.scm | 97 +++++++++++++++------------------------- tests/cache.scm | 81 +++++++++++++++++++++++++++++++++ 4 files changed, 225 insertions(+), 61 deletions(-) create mode 100644 guix/cache.scm create mode 100644 tests/cache.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 46f9547117..a997ed8b99 100644 --- a/Makefile.am +++ b/Makefile.am @@ -60,6 +60,7 @@ MODULES = \ guix/upstream.scm \ guix/licenses.scm \ guix/graph.scm \ + guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ guix/zlib.scm \ @@ -296,6 +297,7 @@ SCM_TESTS = \ tests/size.scm \ tests/graph.scm \ tests/challenge.scm \ + tests/cache.scm \ tests/cve.scm \ tests/workers.scm \ tests/zlib.scm \ diff --git a/guix/cache.scm b/guix/cache.scm new file mode 100644 index 0000000000..077b0780bd --- /dev/null +++ b/guix/cache.scm @@ -0,0 +1,106 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017 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 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: + +(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/scripts/substitute.scm b/guix/scripts/substitute.scm index d3bccf4ddb..748c334e3c 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)) @@ -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." @@ -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 %narinfo-negative-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 @@ -1013,7 +983,12 @@ default value." (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 diff --git a/tests/cache.scm b/tests/cache.scm new file mode 100644 index 0000000000..0e1e08b693 --- /dev/null +++ b/tests/cache.scm @@ -0,0 +1,81 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 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-cache) + #:use-module (guix cache) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-64) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (ice-9 match)) + +(test-begin "cache") + +(test-equal "remove-expired-cache-entries" + '("o" "l" "d") + (let* ((removed '()) + (now (time-second (current-time time-monotonic))) + (ttl 100) + (stamp (match-lambda + ((or "n" "e" "w") (+ now 100)) + ((or "o" "l" "d") (- now 100)))) + (delete (lambda (entry) + (set! removed (cons entry removed))))) + (remove-expired-cache-entries (reverse '("n" "e" "w" + "o" "l" "d")) + #:entry-expiration stamp + #:delete-entry delete) + removed)) + +(define-syntax-rule (test-cache-cleanup cache exp ...) + (call-with-temporary-directory + (lambda (cache) + (let* ((deleted '()) + (delete! (lambda (entry) + (set! deleted (cons entry deleted))))) + exp ... + (maybe-remove-expired-cache-entries cache + (const '("a" "b" "c")) + #:entry-expiration (const 0) + #:delete-entry delete!) + (reverse deleted))))) + +(test-equal "maybe-remove-expired-cache-entries, first cleanup" + '("a" "b" "c") + (test-cache-cleanup cache)) + +(test-equal "maybe-remove-expired-cache-entries, no cleanup needed" + '() + (test-cache-cleanup cache + (call-with-output-file (string-append cache "/last-expiry-cleanup") + (lambda (port) + (display (+ (time-second (current-time time-monotonic)) 100) + port))))) + +(test-equal "maybe-remove-expired-cache-entries, cleanup needed" + '("a" "b" "c") + (test-cache-cleanup cache + (call-with-output-file (string-append cache "/last-expiry-cleanup") + (lambda (port) + (display 0 port))))) + +(test-end "cache") + +;;; Local Variables: +;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1) +;;; End: -- cgit v1.2.3 From 2363bdd707ba382d89c96e03c04038c047d7228c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 19 Apr 2017 16:11:25 +0200 Subject: gexp: 'gexp-modules' accepts plain Scheme objects. * guix/gexp.scm (gexp-modules): Return '() when not (gexp? GEXP). * tests/gexp.scm ("gexp-modules and literal Scheme object"): New test. --- guix/gexp.scm | 33 ++++++++++++++++++--------------- tests/gexp.scm | 4 ++++ 2 files changed, 22 insertions(+), 15 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 80d8f735b3..d9c4cb461e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -459,21 +459,24 @@ 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))))) + "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? exp)) + (gexp-modules exp)) + (($ (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/tests/gexp.scm b/tests/gexp.scm index 41a53ae5a4..cf88a9db80 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -627,6 +627,10 @@ #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) +(test-equal "gexp-modules and literal Scheme object" + '() + (gexp-modules #t)) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin -- cgit v1.2.3 From 1397b422e254929de1805aaf1d0759cd5da6a60b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Apr 2017 11:39:49 +0200 Subject: store: 'GUIX_DAEMON_SOCKET' can now be a URI. * guix/store.scm (%daemon-socket-file): Rename to... (%daemon-socket-uri): ... this. (connect-to-daemon): New procedure. (open-connection): Rename 'file' to 'uri'. Use 'connect-to-daemon' instead of 'open-unix-domain-socket'. * guix/tests.scm (open-connection-for-tests): Rename 'file' to 'uri'. * tests/guix-build.sh: Add tests. * tests/store.scm ("open-connection with file:// URI"): New tests. --- doc/guix.texi | 26 +++++++++++++++++++++++--- guix/store.scm | 36 ++++++++++++++++++++++++++++-------- guix/tests.scm | 6 +++--- tests/guix-build.sh | 8 ++++++++ tests/store.scm | 8 ++++++++ 5 files changed, 70 insertions(+), 14 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 753c3998e5..5f973e2fe1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3666,10 +3666,30 @@ accidental modifications. @end quotation The @code{(guix store)} module provides procedures to connect to the -daemon, and to perform RPCs. These are described below. +daemon, and to perform RPCs. These are described below. By default, +@code{open-connection}, and thus all the @command{guix} commands, +connect to the local daemon or to the URI specified by the +@code{GUIX_DAEMON_SOCKET} environment variable. -@deffn {Scheme Procedure} open-connection [@var{file}] [#:reserve-space? #t] -Connect to the daemon over the Unix-domain socket at @var{file}. When +@defvr {Environment Variable} GUIX_DAEMON_SOCKET +When set, the value of this variable should be a file name or a URI +designating the daemon endpoint. When it is a file name, it denotes a +Unix-domain socket to connect to. In addition to file names, the +supported URI schemes are: + +@table @code +@item file +@itemx unix +These are for Unix-domain sockets. +@code{file:///var/guix/daemon-socket/socket} is equivalent to +@file{/var/guix/daemon-socket/socket}. +@end table + +Additional URI schemes may be supported in the future. +@end defvr + +@deffn {Scheme Procedure} open-connection [@var{uri}] [#:reserve-space? #t] +Connect to the daemon over the Unix-domain socket at @var{uri} (a string). When @var{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 should the disk become full. Return a server object. diff --git a/guix/store.scm b/guix/store.scm index 2f05351767..bd07976c37 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -39,7 +39,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 @@ -216,8 +217,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))) @@ -369,10 +370,29 @@ (file file) (errno errno))))))))) -(define* (open-connection #:optional (file (%daemon-socket-file)) +(define (connect-to-daemon uri) + "Connect to the daemon at URI, a string that may be an actual URI or a file +name." + (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)))) + (x + (raise (condition (&nix-connection-error + (file (uri->string uri)) + (errno ENOTSUP))))))))) + + (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 +403,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) 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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; 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/tests/guix-build.sh b/tests/guix-build.sh index ab911b7210..9494e7371f 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -36,6 +36,14 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' | \ guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' +# Passing a URI. +GUIX_DAEMON_SOCKET="file://$NIX_STATE_DIR/daemon-socket/socket" \ +guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' + +( if GUIX_DAEMON_SOCKET="weird://uri" \ + guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \ + then exit 1; fi ) + # Check --sources option with its arguments module_dir="t-guix-build-$$" mkdir "$module_dir" diff --git a/tests/store.scm b/tests/store.scm index 45150d36ca..3eb8b7be5a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -48,6 +48,14 @@ (test-begin "store") +(test-assert "open-connection with file:// URI" + (let ((store (open-connection (string-append "file://" + (%daemon-socket-uri))))) + (and (add-text-to-store store "foo" "bar") + (begin + (close-connection store) + #t)))) + (test-equal "connection handshake error" EPROTO (let ((port (%make-void-port "rw"))) -- cgit v1.2.3 From 9231ef12f2a595b8f1e677dbe50cc499555302b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Apr 2017 22:43:28 +0200 Subject: derivations: Restore UTF-8 encoding of build scripts. Reported by Mark H Weaver at . * guix/derivations.scm (build-expression->derivation): Use a string output port for the expression. This reverts part of 2dce88d5bbe7a65e101c0734d1c6db44ecc8c299. * tests/derivations.scm ("build-expression->derivation and builder encoding"): New test. --- guix/derivations.scm | 10 ++++------ tests/derivations.scm | 13 +++++++++++++ 2 files changed, 17 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 410c41083e..d5e0f453e2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1238,16 +1238,15 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." ;; Guile sets it, but remove it to avoid conflicts when ;; building Guile-using packages. (unsetenv "LD_LIBRARY_PATH"))) - (builder (add-data-to-store store + (builder (add-text-to-store store (string-append name "-guile-builder") ;; Explicitly use UTF-8 for determinism, ;; and also because UTF-8 output is faster. (with-fluids ((%default-port-encoding "UTF-8")) - (call-with-values - open-bytevector-output-port - (lambda (port get-bv) + (call-with-output-string + (lambda (port) (write prologue port) (write `(exit @@ -1255,8 +1254,7 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." ((_ ...) (remove module-form? exp)) (_ `(,exp)))) - port) - (get-bv)))) + port)))) ;; The references don't really matter ;; since the builder is always used in diff --git a/tests/derivations.scm b/tests/derivations.scm index 75c8d1dfb1..626e4d20e2 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -701,6 +701,19 @@ #:modules '((guix module that does not exist))))) +(test-equal "build-expression->derivation and builder encoding" + '("UTF-8" #t) + (let* ((exp '(λ (α) (+ α 1))) + (drv (build-expression->derivation %store "foo" exp))) + (match (derivation-builder-arguments drv) + ((... builder) + (call-with-input-file builder + (lambda (port) + (list (port-encoding port) + (->bool + (string-contains (get-string-all port) + "(λ (α) (+ α 1))"))))))))) + (test-assert "build-expression->derivation and derivation-prerequisites" (let ((drv (build-expression->derivation %store "fail" #f))) (any (match-lambda -- cgit v1.2.3 From 904c6c42eb8c3805edd293666eeb4b3837e2b7a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Apr 2017 22:53:59 +0200 Subject: tests: Adjust to the addition of a new Coreutils version. * tests/scripts-build.scm ("options->transformation, with-input"): Use 'specification->package' rather than refer to Coreutils by its variable. This is a followup to e162050dfc0dee708a7ac5bfcf37d2afd6081604. --- tests/scripts-build.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index a1f684c736..a408ea6f8d 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #:use-module (guix scripts build) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages busybox) #:use-module (ice-9 match) @@ -97,8 +98,8 @@ (test-assert "options->transformation, with-input" (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,coreutils) - ("bar" ,grep) + (inputs `(("foo" ,(specification->package "coreutils")) + ("bar" ,(specification->package "grep")) ("baz" ,(dummy-package "chbouib" (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-input . "coreutils=busybox") -- cgit v1.2.3 From 8a8e2d2ed5932a13a73583d32b152133d28aedf5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 22 Apr 2017 14:05:38 +0200 Subject: derivations: Adjust builder encoding test. This is a followup to 9231ef12f2a595b8f1e677dbe50cc499555302b6. * tests/derivations.scm ("build-expression->derivation and builder encoding"): Set '%default-port-encoding' to "UTF-8". --- tests/derivations.scm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 626e4d20e2..cabbf7b951 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -707,12 +707,13 @@ (drv (build-expression->derivation %store "foo" exp))) (match (derivation-builder-arguments drv) ((... builder) - (call-with-input-file builder - (lambda (port) - (list (port-encoding port) - (->bool - (string-contains (get-string-all port) - "(λ (α) (+ α 1))"))))))))) + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-input-file builder + (lambda (port) + (list (port-encoding port) + (->bool + (string-contains (get-string-all port) + "(λ (α) (+ α 1))")))))))))) (test-assert "build-expression->derivation and derivation-prerequisites" (let ((drv (build-expression->derivation %store "fail" #f))) -- cgit v1.2.3 From 25a49294caf2386e65fc1b12a2508324be0b1cc2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 22 Apr 2017 14:40:51 +0200 Subject: cache: Work around 'time-monotonic' bug in Guile 2.2.2. * guix/cache.scm (time-monotonic) [guile-2.2]: New variable. * tests/cache.scm (time-monotonic) [guile-2.2]: Likewise. * guix/build/download.scm (time-monotonic) [guile-2.2]: Adjust comment: it's a 2.2.2 bug. --- guix/build/download.scm | 5 ++--- guix/cache.scm | 7 +++++++ tests/cache.scm | 7 +++++++ 3 files changed, 16 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/build/download.scm b/guix/build/download.scm index 6563341b9f..67a8952599 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -142,9 +142,8 @@ Otherwise return STORE-PATH." (cond-expand (guile-2.2 - ;; Guile 2.2.0 to 2.2.2 included has a bug whereby 'time-monotonic' objects - ;; have seconds and nanoseconds swapped (fixed in Guile commit 886ac3e). - ;; Work around it. + ;; 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)) diff --git a/guix/cache.scm b/guix/cache.scm index 077b0780bd..1dc0083f1d 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -33,6 +33,13 @@ ;;; ;;; 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)) diff --git a/tests/cache.scm b/tests/cache.scm index 0e1e08b693..e46cdd816d 100644 --- a/tests/cache.scm +++ b/tests/cache.scm @@ -24,6 +24,13 @@ #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (ice-9 match)) +(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)) + (test-begin "cache") (test-equal "remove-expired-cache-entries" -- cgit v1.2.3 From e30c2be10da8929e42aafc7770257e84de49ffbb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 May 2017 15:45:41 +0200 Subject: packages: Remove support for PACKAGE-VERSION deprecated syntax. This syntax had been deprecated since 2016-02-28. * gnu/packages.scm (%find-package): Remove #:fallback? parameter and handling. * tests/guix-build.sh: Remove test for "time-1.7" syntax. * doc/guix.texi (Invoking guix lint): Update 'guix lint' output in example. --- doc/guix.texi | 6 +++--- gnu/packages.scm | 17 ++--------------- tests/guix-build.sh | 1 - 3 files changed, 5 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 9f63413bbf..9b2fe3fdb8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16281,9 +16281,9 @@ distribution: @smallexample $ guix lint -c cve -gnu/packages/base.scm:652:2: glibc-2.21: probably vulnerable to CVE-2015-1781, CVE-2015-7547 -gnu/packages/gcc.scm:334:2: gcc-4.9.3: probably vulnerable to CVE-2015-5276 -gnu/packages/image.scm:312:2: openjpeg-2.1.0: probably vulnerable to CVE-2016-1923, CVE-2016-1924 +gnu/packages/base.scm:652:2: glibc@@2.21: probably vulnerable to CVE-2015-1781, CVE-2015-7547 +gnu/packages/gcc.scm:334:2: gcc@@4.9.3: probably vulnerable to CVE-2015-5276 +gnu/packages/image.scm:312:2: openjpeg@@2.1.0: probably vulnerable to CVE-2016-1923, CVE-2016-1924 @dots{} @end smallexample diff --git a/gnu/packages.scm b/gnu/packages.scm index 92bab7228a..bec8163b2b 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -306,7 +306,7 @@ return its return value." ;;; Package specification. ;;; -(define* (%find-package spec name version #:key fallback?) +(define* (%find-package spec name version) (match (find-best-packages-by-name name version) ((pkg . pkg*) (unless (null? pkg*) @@ -314,10 +314,6 @@ return its return value." (warning (_ "choosing ~a@~a from ~a~%") (package-name pkg) (package-version pkg) (location->string (package-location pkg)))) - (when fallback? - (warning (_ "deprecated NAME-VERSION syntax; \ -use NAME@VERSION instead~%"))) - (match (package-superseded pkg) ((? package? new) (info (_ "package '~a' has been superseded by '~a'~%") @@ -328,16 +324,7 @@ use NAME@VERSION instead~%"))) (x (if version (leave (_ "~A: package not found for version ~a~%") name version) - (if (not fallback?) - ;; XXX: Fallback to the older specification style with an hyphen - ;; between NAME and VERSION, for backward compatibility. - (call-with-values - (lambda () - (hyphen-separated-name->name+version name)) - (cut %find-package spec <> <> #:fallback? #t)) - - ;; The fallback case didn't find anything either, so bail out. - (leave (_ "~A: unknown package~%") name)))))) + (leave (_ "~A: unknown package~%") name))))) (define (specification->package spec) "Return a package matching SPEC. SPEC may be a package name, or a package diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 9494e7371f..880a582777 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -185,7 +185,6 @@ test "`guix build superseded -d`" = "`guix build bar -d`" # Parsing package names and versions. guix build -n time # PASS guix build -n time@1.7 # PASS, version found -guix build -n time-1.7 # PASS, deprecated version syntax if guix build -n time@3.2; # FAIL, version not found then false; else true; fi if guix build -n something-that-will-never-exist; # FAIL -- cgit v1.2.3 From dff3189c7d5d95177ff592789e1bcb73a4adcc9e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 May 2017 17:24:41 +0200 Subject: publish: Produce a "FileSize" narinfo field when possible. * guix/scripts/publish.scm (narinfo-string): Add #:file-size parameter. Produce a "FileSize" field when COMPRESSION is eq? to '%no-compression' or when FILE-SIZE is true. (bake-narinfo+nar): Pass #:file-size. * tests/publish.scm ("/*.narinfo") ("/*.narinfo with properly encoded '+' sign") ("with cache"): Check for "FileSize". --- guix/scripts/publish.scm | 18 +++++++++++++----- tests/publish.scm | 25 +++++++++++++++++-------- 2 files changed, 30 insertions(+), 13 deletions(-) (limited to 'tests') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3faff061a7..a589f149d3 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -240,10 +240,12 @@ 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 (actual-compression store-path compression)) (url (encode-and-join-uri-path @@ -257,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)) " ")) @@ -268,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) @@ -465,7 +472,8 @@ requested using POOL." (display (narinfo-string store item (%private-key) #:nar-path nar-path - #:compression compression) + #:compression compression + #:file-size (stat:size (stat nar))) port)))))) ;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for diff --git a/tests/publish.scm b/tests/publish.scm index 233b71ce93..6238f37bc1 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -122,13 +122,15 @@ URL: nar/~a Compression: none NarHash: sha256:~a NarSize: ~d -References: ~a~%" +References: ~a +FileSize: ~a~%" %item (basename %item) (bytevector->nix-base32-string (path-info-hash info)) (path-info-nar-size info) - (basename (first (path-info-references info))))) + (basename (first (path-info-references info))) + (path-info-nar-size info))) (signature (base64-encode (string->utf8 (canonical-sexp->string @@ -152,11 +154,13 @@ URL: nar/~a Compression: none NarHash: sha256:~a NarSize: ~d -References: ~%" +References: ~%\ +FileSize: ~a~%" item (uri-encode (basename item)) (bytevector->nix-base32-string (path-info-hash info)) + (path-info-nar-size info) (path-info-nar-size info))) (signature (base64-encode (string->utf8 @@ -323,6 +327,7 @@ References: ~%" ("Compression" . "gzip")) 200 ;nar/gzip/… #t ;Content-Length + #t ;FileSize 200) ;nar/… (call-with-temporary-directory (lambda (cache) @@ -351,10 +356,11 @@ References: ~%" (response (http-get url))) (and (= 404 (response-code response)) (wait-for-file cached) - (let ((body (http-get-port url)) - (compressed (http-get nar-url)) - (uncompressed (http-get (string-append base "nar/" - (basename %item))))) + (let* ((body (http-get-port url)) + (compressed (http-get nar-url)) + (uncompressed (http-get (string-append base "nar/" + (basename %item)))) + (narinfo (recutils->alist body))) (list (file-exists? nar) (filter (lambda (item) (match item @@ -362,10 +368,13 @@ References: ~%" (("StorePath" . _) #t) (("URL" . _) #t) (_ #f))) - (recutils->alist body)) + narinfo) (response-code compressed) (= (response-content-length compressed) (stat:size (stat nar))) + (= (string->number + (assoc-ref narinfo "FileSize")) + (stat:size (stat nar))) (response-code uncompressed))))))))) (test-end "publish") -- cgit v1.2.3 From cd903ef7871170d3c4eced45418459d293ef48a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 May 2017 23:03:20 +0200 Subject: Add (guix discovery). * guix/discovery.scm, tests/discovery.scm: New files. * gnu/packages.scm (scheme-files, file-name->module-name) (scheme-modules, all-package-modules): Remove. (fold-packages): Rewrite in terms of 'fold-module-public-variables'. * gnu/tests.scm: Use (guix discovery). * Makefile.am (MODULES): Add guix/discovery.scm. (SCM_TESTS): Add tests/discovery.scm. --- Makefile.am | 2 + gnu/packages.scm | 93 ++++--------------------------------- gnu/tests.scm | 2 +- guix/discovery.scm | 131 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/discovery.scm | 52 +++++++++++++++++++++ 5 files changed, 194 insertions(+), 86 deletions(-) create mode 100644 guix/discovery.scm create mode 100644 tests/discovery.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 426f8327d9..c6d8de68bc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -50,6 +50,7 @@ MODULES = \ guix/sets.scm \ guix/modules.scm \ guix/download.scm \ + guix/discovery.scm \ guix/git-download.scm \ guix/hg-download.scm \ guix/monads.scm \ @@ -279,6 +280,7 @@ SCM_TESTS = \ tests/records.scm \ tests/upstream.scm \ tests/combinators.scm \ + tests/discovery.scm \ tests/utils.scm \ tests/build-utils.scm \ tests/packages.scm \ diff --git a/gnu/packages.scm b/gnu/packages.scm index 08f1340612..57907155fb 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -24,12 +24,11 @@ #:use-module (guix packages) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix discovery) #:use-module (guix memoization) - #:use-module (guix combinators) #:use-module ((guix build utils) #:select ((package-name->name+version . hyphen-separated-name->name+version))) - #:use-module (ice-9 ftw) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -48,7 +47,6 @@ %package-module-path fold-packages - scheme-modules ;XXX: for lack of a better place find-packages-by-name find-best-packages-by-name @@ -140,92 +138,17 @@ for system '~a'") directory)) %load-path))) -(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) - (warning (G_ "cannot access `~a': ~a~%") - path (strerror errno)) - result) - '() - directory - stat) - stringmodule-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* (all-package-modules #:optional (path (%package-module-path))) - "Return the list of package modules found in PATH, a list of directories to -search." - (fold-right (lambda (spec result) - (match spec - ((? string? directory) - (append (scheme-modules directory) result)) - ((directory . sub-directory) - (append (scheme-modules directory sub-directory) - result)))) - '() - path)) - (define (fold-packages proc init) "Call (PROC PACKAGE RESULT) for each available package, using INIT as the initial value of RESULT. It is guaranteed to never traverse the same package twice." - (identity ; discard second return value - (fold2 (lambda (module result seen) - (fold2 (lambda (var result seen) - (if (and (package? var) - (not (vhash-assq var seen)) - (not (hidden-package? var))) - (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 - (all-package-modules)))) + (fold-module-public-variables (lambda (object result) + (if (and (package? object) + (not (hidden-package? object))) + (proc object result) + result)) + init + (all-modules (%package-module-path)))) (define find-packages-by-name (let ((packages (delay diff --git a/gnu/tests.scm b/gnu/tests.scm index e84d1ebb20..0df6e5a2ef 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -27,7 +27,7 @@ #:use-module (gnu services) #:use-module (gnu services base) #:use-module (gnu services shepherd) - #:use-module ((gnu packages) #:select (scheme-modules)) + #:use-module ((guix discovery) #:select (scheme-modules)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) 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 +;;; +;;; 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 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) + stringmodule-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/tests/discovery.scm b/tests/discovery.scm new file mode 100644 index 0000000000..b838731e16 --- /dev/null +++ b/tests/discovery.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 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-discovery) + #:use-module (guix discovery) + #:use-module (guix build-system) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(define %top-srcdir + (dirname (search-path %load-path "guix.scm"))) + +(test-begin "discovery") + +(test-assert "scheme-modules" + (match (map module-name (scheme-modules %top-srcdir "guix/import")) + ((('guix 'import _ ...) ..1) + #t))) + +(test-assert "all-modules" + (match (map module-name + (all-modules `((,%top-srcdir . "guix/build-system")))) + ((('guix 'build-system names) ..1) + names))) + +(test-assert "fold-module-public-variables" + (let ((modules (all-modules `((,%top-srcdir . "guix/build-system"))))) + (match (fold-module-public-variables (lambda (obj result) + (if (build-system? obj) + (cons obj result) + result)) + '() + modules) + (((? build-system? bs) ..1) + bs)))) + +(test-end "discovery") -- cgit v1.2.3 From 1a0adad83f804d1d7190af7accb58284e4c69e3e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 7 May 2017 00:16:01 +0200 Subject: tests: Corrupt archive import test is robust against different store prefixes. * tests/store.scm ("import corrupt path"): Set 'index' to #x70. --- tests/store.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 3eb8b7be5a..45aeb329b0 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -758,8 +758,9 @@ (cut export-paths %store (list file) <>)))) (delete-paths %store (list file)) - ;; Flip a bit in the stream's payload. - (let* ((index (quotient (bytevector-length dump) 4)) + ;; Flip a bit in the stream's payload. INDEX here falls in the middle of + ;; the file contents in DUMP, regardless of the store prefix. + (let* ((index #x70) (byte (bytevector-u8-ref dump index))) (bytevector-u8-set! dump index (logxor #xff byte))) -- cgit v1.2.3 From 30d2397f73d6fa9e77eed70ec6df8afd3b9f5f5e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 May 2017 15:25:07 +0200 Subject: ui: 'string->duration' correctly handles hours. * guix/ui.scm (string->duration): Add missing '=>' for hours. * tests/ui.scm ("duration, 2 hours"): New test. --- guix/ui.scm | 1 + tests/ui.scm | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/ui.scm b/guix/ui.scm index e551d48c33..e7cb40927b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1008,6 +1008,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) diff --git a/tests/ui.scm b/tests/ui.scm index cfe417d497..1e98e3534b 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -189,6 +189,10 @@ Second line" 24)) (string->duration "1m") (string->duration "30d")) +(test-equal "duration, 2 hours" + 7200 + (time-second (string->duration "2h"))) + (test-equal "duration, 1 second" (make-time time-duration 0 1) (string->duration "1s")) -- cgit v1.2.3 From 24b21720f7c3a368efc32017c126e107a5d76f52 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 May 2017 10:23:27 +0200 Subject: publish: Advertise a short TTL for "baking" 404s. * guix/scripts/publish.scm (not-found): Add #:phrase and #:ttl parameters and honor them. * tests/publish.scm ("with cache"): Check the 'cache-control' header on of the 404 response. --- guix/scripts/publish.scm | 15 +++++++++++---- tests/publish.scm | 7 +++++++ 2 files changed, 18 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index efaa549676..8da75cb825 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -300,10 +300,15 @@ References: ~a~%~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) @@ -434,7 +439,9 @@ requested using POOL." (file-expiration-time ttl) #:delete-entry delete-entry #:cleanup-period ttl)))) - (not-found request)) + (not-found request + #:phrase "We're baking it" + #:ttl 300)) ;should be available within 5m (else (not-found request))))) diff --git a/tests/publish.scm b/tests/publish.scm index 6238f37bc1..268c324551 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -355,6 +355,13 @@ FileSize: ~a~%" (basename %item) ".nar")) (response (http-get url))) (and (= 404 (response-code response)) + + ;; We should get an explicitly short TTL for 404 in this case + ;; because it's going to become 200 shortly. + (match (assq-ref (response-headers response) 'cache-control) + ((('max-age . ttl)) + (< ttl 3600))) + (wait-for-file cached) (let* ((body (http-get-port url)) (compressed (http-get nar-url)) -- cgit v1.2.3 From db427602d8f993ee0025fa68d1af274aa8d69ab9 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 4 May 2017 11:52:33 +0200 Subject: import: cran: Robustify cran-package?. * guix/import/cran.scm (package->upstream-name): Return #f if url start and end index could not be determined. (cran-package?): Check if the upstream-name can be extracted from given package. * tests/cran.scm: Add "r-minimal is not a cran package" to make sure that r-minimal is not detected as a cran package. This fixes a failure of guix refresh on r-minimal because no upsteam-name can be determined from ".../R-version.tar.gz" uri. --- guix/import/cran.scm | 6 +++++- tests/cran.scm | 6 ++++++ 2 files changed, 11 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index be34a75c8d..a94051655c 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 ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -374,7 +375,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))))) @@ -415,6 +416,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)) diff --git a/tests/cran.scm b/tests/cran.scm index c162d45d8a..d785ec5db1 100644 --- a/tests/cran.scm +++ b/tests/cran.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Ricardo Wurmus +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (test-cran) + #:use-module (gnu packages statistics) #:use-module (guix import cran) #:use-module (guix tests) #:use-module (srfi srfi-1) @@ -86,6 +88,10 @@ Date/Publication: 2015-07-14 14:15:16 '() ((@@ (guix import cran) listify) simple-alist "BadList")) +(test-equal "r-mininal is not a cran package" + #f + ((@@ (guix import cran) cran-package?) r-minimal)) + (test-assert "description->package" ;; Replace network resources with sample data. (mock ((guix build download) url-fetch -- cgit v1.2.3 From 22ef06b801b284760b4ffd9587ea1a3dffd31baa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 18 May 2017 11:35:45 +0200 Subject: union: Gracefully handle dangling symlinks in the input. Fixes . Reported by Pjotr Prins . * guix/build/union.scm (file-is-directory?): Return #f when FILE does not exist or is a dangling symlink. (file=?): Pass #f as a second argument to 'stat'; return #f when both ST1 or ST2 is #f. * tests/profiles.scm (test-equalm): New macro. ("union vs. dangling symlink"): New test. --- .dir-locals.el | 1 + guix/build/union.scm | 43 +++++++++++++++++++++++-------------------- tests/profiles.scm | 29 +++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 20 deletions(-) (limited to 'tests') diff --git a/.dir-locals.el b/.dir-locals.el index 4aaeae95c9..04b58d2ce0 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,7 @@ (eval . (put 'call-with-prompt 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) (eval . (put 'test-assertm 'scheme-indent-function 1)) + (eval . (put 'test-equalm 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) (eval . (put 'test-eq 'scheme-indent-function 1)) (eval . (put 'call-with-input-string 'scheme-indent-function 1)) diff --git a/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/tests/profiles.scm b/tests/profiles.scm index d0b1e14a86..093422792f 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -50,6 +50,12 @@ (run-with-store %store exp #:guile-for-build (%guile-for-build)))) +(define-syntax-rule (test-equalm name value exp) + (test-equal name + value + (run-with-store %store exp + #:guile-for-build (%guile-for-build)))) + ;; Example manifest entries. (define guile-1.8.8 @@ -366,6 +372,29 @@ get-string-all) "foo!")))))) +(test-equalm "union vs. dangling symlink" ; + "does-not-exist" + (mlet* %store-monad + ((thing1 -> (dummy-package "dummy" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (symlink "does-not-exist" + (string-append out "/dangling")) + #t))))) + (thing2 -> (package (inherit thing1) (name "dummy2"))) + (drv (profile-derivation (packages->manifest + (list thing1 thing2)) + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (readlink (readlink (string-append profile "/dangling"))))))) + (test-end "profiles") ;;; Local Variables: -- cgit v1.2.3 From ffa5e0a6d2851832b7f0e6f943bc69e69e1bc8b0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 18 May 2017 21:19:49 +0200 Subject: publish: Fix narinfo rendering for already-compressed items. Fixes . Reported by Mark H Weaver . * guix/scripts/publish.scm (bake-narinfo+nar): Pass #f as the 2nd argument to 'stat' and properly handle #f. * tests/publish.scm (wait-for-file): New procedure. ("with cache"): Remove 'wait-for-file' procedure. ("with cache, uncompressed"): New test. --- guix/scripts/publish.scm | 3 +- tests/publish.scm | 71 ++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 65 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 8da75cb825..db7f6a957e 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -481,7 +481,8 @@ requested using POOL." (%private-key) #:nar-path nar-path #:compression compression - #:file-size (stat:size (stat nar))) + #:file-size (and=> (stat nar #f) + stat:size)) port)))))) ;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for diff --git a/tests/publish.scm b/tests/publish.scm index 268c324551..31043f71fa 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -98,6 +98,18 @@ (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port)) (loop))))) +(define (wait-for-file file) + ;; Wait until FILE shows up. + (let loop ((i 20)) + (cond ((file-exists? file) + #t) + ((zero? i) + (error "file didn't show up" file)) + (else + (pk 'wait-for-file file) + (sleep 1) + (loop (- i 1)))))) + ;; Wait until the two servers are ready. (wait-until-ready 6789) @@ -331,14 +343,6 @@ FileSize: ~a~%" 200) ;nar/… (call-with-temporary-directory (lambda (cache) - (define (wait-for-file file) - (let loop ((i 20)) - (or (file-exists? file) - (begin - (pk 'wait-for-file file) - (sleep 1) - (loop (- i 1)))))) - (let ((thread (with-separate-output-ports (call-with-new-thread (lambda () @@ -384,4 +388,55 @@ FileSize: ~a~%" (stat:size (stat nar))) (response-code uncompressed))))))))) +(unless (zlib-available?) + (test-skip 1)) +(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" + (random-text)))) + (test-equal "with cache, uncompressed" + (list #f + `(("StorePath" . ,item) + ("URL" . ,(string-append "nar/" (basename item))) + ("Compression" . "none")) + 200 ;nar/… + (path-info-nar-size + (query-path-info %store item)) ;FileSize + 404) ;nar/gzip/… + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6796" "-C2" + (string-append "--cache=" cache))))))) + (wait-until-ready 6796) + (let* ((base "http://localhost:6796/") + (part (store-path-hash-part item)) + (url (string-append base part ".narinfo")) + (cached (string-append cache "/none/" + (basename item) ".narinfo")) + (nar (string-append cache "/none/" + (basename item) ".nar")) + (response (http-get url))) + (and (= 404 (response-code response)) + + (wait-for-file cached) + (let* ((body (http-get-port url)) + (compressed (http-get (string-append base "nar/gzip/" + (basename item)))) + (uncompressed (http-get (string-append base "nar/" + (basename item)))) + (narinfo (recutils->alist body))) + (list (file-exists? nar) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + narinfo) + (response-code uncompressed) + (string->number + (assoc-ref narinfo "FileSize")) + (response-code compressed)))))))))) + (test-end "publish") -- cgit v1.2.3