From 759756a992625940e26bdb6cc1f96731b1c8b90f Mon Sep 17 00:00:00 2001 From: Paul van der Walt Date: Wed, 21 Oct 2015 15:46:25 +0200 Subject: import: hackage: Update GHC libraries for 7.10.2. Update ghc-standard-libraries to match the output of `ghc-pkg list` when using GHC 7.10.2. * guix/import/hackage.scm (ghc-standard-libraries): Sort and update list of core GHC libraries. --- guix/import/hackage.scm | 40 +++++++++++++++++++--------------------- 1 file changed, 19 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index b5574a8d9f..3baa514aa1 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -32,37 +32,35 @@ (define-module (guix import hackage) #:export (hackage->guix-package)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as + ;; List of libraries distributed with ghc (7.10.2). We include GHC itself as ;; some packages list it. - '("ghc" - "haskell98" - "hoopl" + '("array" "base" - "transformers" - "deepseq" - "array" + "bin-package-db" "binary" "bytestring" + "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but + ;; hackage-name->package-name takes this into account. "containers" - "time" - "cabal" - "bin-package-db" + "deepseq" + "directory" + "filepath" + "ghc" "ghc-prim" + "haskeline" + "hoopl" + "hpc" "integer-gmp" - "integer-simple" - "win32" - "template-haskell" + "pretty" "process" - "haskeline" + "rts" + "template-haskell" "terminfo" - "directory" - "filepath" - "old-locale" + "time" + "transformers" "unix" - "old-time" - "pretty" - "xhtml" - "hpc")) + "win32" + "xhtml")) (define package-name-prefix "ghc-") -- cgit v1.2.3 From 8e01e30077a70376baefa7bc88ea01818d94aeee Mon Sep 17 00:00:00 2001 From: Paul van der Walt Date: Wed, 21 Oct 2015 15:52:15 +0200 Subject: import: hackage: Fix grammar. Minor clarification regarding the test-dependencies command line option. * guix/scripts/import/hackage.scm (show-help): Minor grammatical fix. --- guix/scripts/import/hackage.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 8d31128c47..8c4e640bf3 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -55,7 +55,7 @@ (define (show-help) (display (_ " -s, --stdin read from standard input")) (display (_ " - -t, --no-test-dependencies don't include test only dependencies")) + -t, --no-test-dependencies don't include test-only dependencies")) (display (_ " -V, --version display version information and exit")) (newline) -- cgit v1.2.3 From f535dcbe198e7f88f3b0cd8aa4d7585191b31080 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 19 Jun 2015 08:57:44 -0400 Subject: scripts: environment: Add --container option. * guix/scripts/system.scm (specification->file-system-mapping): Move from here... * guix/ui.scm (specification->file-system-mapping): ... to here. * guix/scripts/enviroment.scm (show-help): Show help for new options. (%options): Add --container --network, --expose, and --share options. (%network-configuration-files): New variable. (launch-environment, launch-environment/container, requisites*, inputs->requisites): New procedures. (guix-environment): Spawn new process in a container when requested. * doc/guix.texi (Invoking guix environment): Document it. * tests/guix-environment-container.sh: New file. * Makefile.am (SH_TESTS): Add it. --- Makefile.am | 1 + doc/guix.texi | 56 ++++++++ guix/scripts/environment.scm | 276 ++++++++++++++++++++++++++++++------ guix/scripts/system.scm | 13 -- guix/ui.scm | 19 +++ tests/guix-environment-container.sh | 75 ++++++++++ 6 files changed, 385 insertions(+), 55 deletions(-) create mode 100644 tests/guix-environment-container.sh (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 1427203fb2..4f90b1d15b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -253,6 +253,7 @@ SH_TESTS = \ tests/guix-archive.sh \ tests/guix-authenticate.sh \ tests/guix-environment.sh \ + tests/guix-environment-container.sh \ tests/guix-graph.sh \ tests/guix-lint.sh diff --git a/doc/guix.texi b/doc/guix.texi index 99c10d8dc7..7715b72818 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4681,6 +4681,18 @@ NumPy: guix environment --ad-hoc python2-numpy python-2.7 -- python @end example +Sometimes it is desirable to isolate the environment as much as +possible, for maximal purity and reproducibility. In particular, when +using Guix on a host distro that is not GuixSD, it is desirable to +prevent access to @file{/usr/bin} and other system-wide resources from +the development environment. For example, the following command spawns +a Guile REPL in a ``container'' where only the store and the current +working directory are mounted: + +@example +guix environment --ad-hoc --container guile -- guile +@end example + The available options are summarized below. @table @code @@ -4741,6 +4753,49 @@ environment. @item --system=@var{system} @itemx -s @var{system} Attempt to build for @var{system}---e.g., @code{i686-linux}. + +@item --container +@itemx -C +@cindex container +Run @var{command} within an isolated container. The current working +directory outside the container is mapped to @file{/env} inside the +container. Additionally, the spawned process runs as the current user +outside the container, but has root privileges in the context of the +container. + +@item --network +@itemx -N +For containers, share the network namespace with the host system. +Containers created without this flag only have access to the loopback +device. + +@item --expose=@var{source}[=@var{target}] +For containers, expose the file system @var{source} from the host system +as the read-only file system @var{target} within the container. If +@var{target} is not specified, @var{source} is used as the target mount +point in the container. + +The example below spawns a Guile REPL in a container in which the user's +home directory is accessible read-only via the @file{/exchange} +directory: + +@example +guix environment --container --expose=$HOME=/exchange guile -- guile +@end example + +@item --share +For containers, share the file system @var{source} from the host system +as the writable file system @var{target} within the container. If +@var{target} is not specified, @var{source} is used as the target mount +point in the container. + +The example below spawns a Guile REPL in a container in which the user's +home directory is accessible for both reading and writing via the +@file{/exchange} directory: + +@example +guix environment --container --share=$HOME=/exchange guile -- guile +@end example @end table It also supports all of the common build options that @command{guix @@ -7064,6 +7119,7 @@ This command also installs GRUB on the device specified in @item vm @cindex virtual machine @cindex VM +@anchor{guix system vm} Build a virtual machine that contain the operating system declared in @var{file}, and return a script to run that virtual machine (VM). Arguments given to the script are passed as is to QEMU. diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2408420e18..1d21a768dc 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -25,13 +25,19 @@ (define-module (guix scripts environment) #:use-module (guix profiles) #:use-module (guix search-paths) #:use-module (guix utils) + #:use-module (guix build utils) #:use-module (guix monads) #:use-module ((guix gexp) #:select (lower-inputs)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (gnu build linux-container) + #:use-module (gnu system linux-container) + #:use-module (gnu system file-systems) #:use-module (gnu packages) + #:use-module (gnu packages bash) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -60,6 +66,12 @@ (define %precious-variables (define %default-shell (or (getenv "SHELL") "/bin/sh")) +(define %network-configuration-files + '("/etc/resolv.conf" + "/etc/nsswitch.conf" + "/etc/services" + "/etc/hosts")) + (define (purify-environment) "Unset almost all environment variables. A small number of variables such as 'HOME' and 'USER' are left untouched." @@ -124,6 +136,18 @@ (define (show-help) --search-paths display needed environment variable definitions")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -C, --container run command within an isolated container")) + (display (_ " + -N, --network allow containers to access the network")) + (display (_ " + --share=SPEC for containers, share writable host file system + according to SPEC")) + (display (_ " + --expose=SPEC for containers, expose read-only host file system + according to SPEC")) + (display (_ " + --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) (newline) @@ -176,6 +200,25 @@ (define %options (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '(#\C "container") #f #f + (lambda (opt name arg result) + (alist-cons 'container? #t result))) + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'network? #t result))) + (option '("share") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #t) + result))) + (option '("expose") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #f) + result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) %standard-build-options)) (define (pick-all alist key) @@ -231,6 +274,131 @@ (define (build-inputs inputs opts) (built-derivations derivations) (return derivations)))))))) +(define requisites* (store-lift requisites)) + +(define (inputs->requisites inputs) + "Convert INPUTS, a list of input tuples or store path strings, into a set of +requisite store items i.e. the union closure of all the inputs." + (define (input->requisites input) + (requisites* + (match input + ((drv output) + (derivation->output-path drv output)) + ((drv) + (derivation->output-path drv)) + ((? direct-store-path? path) + path)))) + + (mlet %store-monad ((reqs (sequence %store-monad + (map input->requisites inputs)))) + (return (delete-duplicates (concatenate reqs))))) + +(define exit/status (compose exit status:exit-val)) +(define primitive-exit/status (compose primitive-exit status:exit-val)) + +(define (launch-environment command inputs paths pure?) + "Run COMMAND in a new environment containing INPUTS, using the native search +paths defined by the list PATHS. When PURE?, pre-existing environment +variables are cleared before setting the new ones." + (create-environment inputs paths pure?) + (apply system* command)) + +(define* (launch-environment/container #:key command bash user-mappings + inputs paths network?) + "Run COMMAND within a Linux container. The environment features INPUTS, a +list of derivations to be shared from the host system. Environment variables +are set according to PATHS, a list of native search paths. The global shell +is BASH, a file name for a GNU Bash binary in the store. When NETWORK?, +access to the host system network is permitted. USER-MAPPINGS, a list of file +system mappings, contains the user-specified host file systems to mount inside +the container." + (mlet %store-monad ((reqs (inputs->requisites + (cons (direct-store-path bash) inputs)))) + (return + (let* ((cwd (getcwd)) + ;; Bind-mount all requisite store items, user-specified mappings, + ;; /bin/sh, the current working directory, and possibly networking + ;; configuration files within the container. + (mappings + (append user-mappings + ;; Current working directory. + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + ;; When in Rome, do as Nix build.cc does: Automagically + ;; map common network configuration files. + (if network? + (filter-map (lambda (file) + (and (file-exists? file) + (file-system-mapping + (source file) + (target file) + (writable? #f)))) + %network-configuration-files) + '()) + ;; Mappings for the union closure of all inputs. + (map (lambda (dir) + (file-system-mapping + (source dir) + (target dir) + (writable? #f))) + reqs))) + (file-systems (append %container-file-systems + (map mapping->file-system mappings)))) + (exit/status + (call-with-container (map file-system->spec file-systems) + (lambda () + ;; Setup global shell. + (mkdir-p "/bin") + (symlink bash "/bin/sh") + + ;; Setup directory for temporary files. + (mkdir-p "/tmp") + (for-each (lambda (var) + (setenv var "/tmp")) + ;; The same variables as in Nix's 'build.cc'. + '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) + + ;; From Nix build.cc: + ;; + ;; Set HOME to a non-existing path to prevent certain + ;; programs from using /etc/passwd (or NIS, or whatever) + ;; to locate the home directory (for example, wget looks + ;; for ~/.wgetrc). I.e., these tools use /etc/passwd if + ;; HOME is not set, but they will just assume that the + ;; settings file they are looking for does not exist if + ;; HOME is set but points to some non-existing path. + (setenv "HOME" "/homeless-shelter") + + ;; For convenience, start in the user's current working + ;; directory rather than the root directory. + (chdir cwd) + + (primitive-exit/status + ;; A container's environment is already purified, so no need to + ;; request it be purified again. + (launch-environment command inputs paths #f))) + #:namespaces (if network? + (delq 'net %namespaces) ; share host network + %namespaces))))))) + +(define (environment-bash container? bootstrap? system) + "Return a monadic value in the store monad for the version of GNU Bash +needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f. +If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash. +Otherwise, return the derivation for the Bash package." + (with-monad %store-monad + (cond + ((and container? (not bootstrap?)) + (package->derivation bash)) + ;; Use the bootstrap Bash instead. + ((and container? bootstrap?) + (interned-file + (search-bootstrap-binary "bash" system))) + (else + (return #f))))) + (define (parse-args args) "Parse the list of command line arguments ARGS." (define (handle-argument arg result) @@ -248,52 +416,76 @@ (define (handle-argument arg result) ;; Entry point. (define (guix-environment . args) (with-error-handling - (let* ((opts (parse-args args)) - (pure? (assoc-ref opts 'pure)) - (ad-hoc? (assoc-ref opts 'ad-hoc?)) - (command (assoc-ref opts 'exec)) - (packages (pick-all (options/resolve-packages opts) 'package)) - (inputs (if ad-hoc? - (append-map (match-lambda - ((package output) - (package+propagated-inputs package - output))) - packages) - (append-map (compose bag-transitive-inputs - package->bag - first) - packages))) - (paths (delete-duplicates - (cons $PATH - (append-map (match-lambda - ((label (? package? p) _ ...) - (package-native-search-paths p)) - (_ - '())) - inputs)) - eq?))) + (let* ((opts (parse-args args)) + (pure? (assoc-ref opts 'pure)) + (container? (assoc-ref opts 'container?)) + (network? (assoc-ref opts 'network?)) + (ad-hoc? (assoc-ref opts 'ad-hoc?)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (system (assoc-ref opts 'system)) + (command (assoc-ref opts 'exec)) + (packages (pick-all (options/resolve-packages opts) 'package)) + (mappings (pick-all opts 'file-system-mapping)) + (inputs (if ad-hoc? + (append-map (match-lambda + ((package output) + (package+propagated-inputs package + output))) + packages) + (append-map (compose bag-transitive-inputs + package->bag + first) + packages))) + (paths (delete-duplicates + (cons $PATH + (append-map (match-lambda + ((label (? package? p) _ ...) + (package-native-search-paths p)) + (_ + '())) + inputs)) + eq?))) (with-store store (run-with-store store - (mlet %store-monad ((inputs (lower-inputs - (map (match-lambda + (mlet* %store-monad ((inputs (lower-inputs + (map (match-lambda ((label item) (list item)) ((label item output) (list item output))) - inputs) - #:system (assoc-ref opts 'system)))) + inputs) + #:system system)) + ;; Containers need a Bourne shell at /bin/sh. + (bash (environment-bash container? + bootstrap? + system))) (mbegin %store-monad - ;; First build INPUTS. This is necessary even for - ;; --search-paths. - (build-inputs inputs opts) - (cond ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths inputs paths pure?) - (return #t)) - (else - (create-environment inputs paths pure?) - (return - (exit - (status:exit-val - (apply system* command))))))))))))) + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash + ;; for a container. + (build-inputs (if (derivation? bash) + `((,bash "out") ,@inputs) + inputs) + opts) + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths inputs paths pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user-mappings mappings + #:inputs inputs + #:paths paths + #:network? network?))) + (else + (return + (exit/status + (launch-environment command inputs paths pure?)))))))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b5da57a9ce..8775267f80 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -488,19 +488,6 @@ (define (show-help) (newline) (show-bug-report-information)) -(define (specification->file-system-mapping spec writable?) - "Read the SPEC and return the corresponding ." - (let ((index (string-index spec #\=))) - (if index - (file-system-mapping - (source (substring spec 0 index)) - (target (substring spec (+ 1 index))) - (writable? writable?)) - (file-system-mapping - (source spec) - (target spec) - (writable? writable?))))) - (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f diff --git a/guix/ui.scm b/guix/ui.scm index fb8121c213..9cc1908e6e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -34,6 +34,7 @@ (define-module (guix ui) #:use-module (guix serialization) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix licenses) #:select (license? license-name)) + #:use-module (gnu system file-systems) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -80,6 +81,7 @@ (define-module (guix ui) string->recutils package->recutils package-specification->name+version+output + specification->file-system-mapping string->generations string->duration run-guix-command @@ -966,6 +968,23 @@ (define* (package-specification->name+version+output spec (package-name->name+version name))) (values name version sub-drv))) +(define (specification->file-system-mapping spec writable?) + "Read the SPEC and return the corresponding . SPEC is +a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies +that SOURCE from the host should be mounted at SOURCE in the other system. +The latter format specifies that SOURCE from the host should be mounted at +TARGET in the other system." + (let ((index (string-index spec #\=))) + (if index + (file-system-mapping + (source (substring spec 0 index)) + (target (substring spec (+ 1 index))) + (writable? writable?)) + (file-system-mapping + (source spec) + (target spec) + (writable? writable?))))) + ;;; ;;; Command-line option processing. diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh new file mode 100644 index 0000000000..9c3e93dd8c --- /dev/null +++ b/tests/guix-environment-container.sh @@ -0,0 +1,75 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2015 David Thompson +# +# 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 . + +# +# Test 'guix environment'. +# + +set -e + +guix environment --version + +tmpdir="t-guix-environment-$$" +trap 'rm -r "$tmpdir"' EXIT + +mkdir "$tmpdir" + +# Make sure the exit value is preserved. +if guix environment --container --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(exit 42)' +then + false +else + test $? = 42 +fi + +# Make sure that the right directories are mapped. +mount_test_code=" +(use-modules (ice-9 rdelim) + (ice-9 match) + (srfi srfi-1)) + +(define mappings + (filter-map (lambda (line) + (match (string-split line #\space) + ;; Empty line. + ((\"\") #f) + ;; Ignore these types of file systems. + ((_ _ (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\" + \"devpts\" \"cgroup\" \"mqueue\") _ _ _) + #f) + ((_ mount _ _ _ _) + mount))) + (string-split (call-with-input-file \"/proc/mounts\" read-string) + #\newline))) + +(for-each (lambda (mount) + (display mount) + (newline)) + mappings)" + +guix environment --container --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c "$mount_test_code" > $tmpdir/mounts + +test `wc -l < $tmpdir/mounts` -eq 3 + +grep -e "$PWD$" $tmpdir/mounts # current directory +grep $(guix build guile-bootstrap) $tmpdir/mounts +grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash + +rm $tmpdir/mounts -- cgit v1.2.3 From f862f38ade0c6a648d5a8711d636281314b2db62 Mon Sep 17 00:00:00 2001 From: Paul van der Walt Date: Fri, 23 Oct 2015 19:33:43 +0200 Subject: build-system/haskell: CONFIG_SHELL env variable. For Cabal packages with "build-type: Configure", a configure shell script is run to set up build parameters. These scripts need the CONFIG_SHELL environment variable to be set to function properly. * guix/build/haskell-build-system.scm (configure): Set CONFIG_SHELL if necessary. --- guix/build/haskell-build-system.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index c0cb789581..4506e96af9 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa +;;; Copyright © 2015 Paul van der Walt ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,6 +97,14 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) '("--enable-tests") '()) configure-flags))) + ;; For packages where the Cabal build-type is set to "Configure", + ;; ./configure will be executed. In these cases, the following + ;; environment variable is needed to be able to find the shell executable. + ;; For other package types, the configure script isn't present. For more + ;; information, see the Build Information section of + ;; . + (when (file-exists? "configure") + (setenv "CONFIG_SHELL" "sh")) (run-setuphs "configure" params))) (define* (build #:rest empty) -- cgit v1.2.3 From e49de93aa53eecb769c8e1522dc6352380121af3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 19:03:56 +0100 Subject: ui: Add 'matching-generations'. * guix/scripts/package.scm (matching-generations): Move to... * guix/ui.scm (matching-generations): ... here. --- guix/scripts/package.scm | 66 ----------------------------------------------- guix/ui.scm | 67 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 66 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e0fe1ddb27..804ca954f2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -177,72 +177,6 @@ (define (delete-generations store profile generations) (for-each (cut delete-generation store profile <>) generations)) -(define* (matching-generations str #:optional (profile %current-profile) - #:key (duration-relation <=)) - "Return the list of available generations matching a pattern in STR. See -'string->generations' and 'string->duration' for the list of valid patterns. -When STR is a duration pattern, return all the generations whose ctime has -DURATION-RELATION with the current time." - (define (valid-generations lst) - (define (valid-generation? n) - (any (cut = n <>) (generation-numbers profile))) - - (fold-right (lambda (x acc) - (if (valid-generation? x) - (cons x acc) - acc)) - '() - lst)) - - (define (filter-generations generations) - (match generations - (() '()) - (('>= n) - (drop-while (cut > n <>) - (generation-numbers profile))) - (('<= n) - (valid-generations (iota n 1))) - ((lst ..1) - (valid-generations lst)) - (_ #f))) - - (define (filter-by-duration duration) - (define (time-at-midnight time) - ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and - ;; hours to zeros. - (let ((d (time-utc->date time))) - (date->time-utc - (make-date 0 0 0 0 - (date-day d) (date-month d) - (date-year d) (date-zone-offset d))))) - - (define generation-ctime-alist - (map (lambda (number) - (cons number - (time-second - (time-at-midnight - (generation-time profile number))))) - (generation-numbers profile))) - - (match duration - (#f #f) - (res - (let ((s (time-second - (subtract-duration (time-at-midnight (current-time)) - duration)))) - (delete #f (map (lambda (x) - (and (duration-relation s (cdr x)) - (first x))) - generation-ctime-alist)))))) - - (cond ((string->generations str) - => - filter-generations) - ((string->duration str) - => - filter-by-duration) - (else #f))) - (define (delete-matching-generations store profile pattern) "Delete from PROFILE all the generations matching PATTERN. PATTERN must be a string denoting a set of generations: the empty list means \"all generations diff --git a/guix/ui.scm b/guix/ui.scm index 9cc1908e6e..59ff2a7fba 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -84,6 +84,7 @@ (define-module (guix ui) specification->file-system-mapping string->generations string->duration + matching-generations run-guix-command run-guix program-name @@ -948,6 +949,72 @@ (define (hours->duration hours match) (hours->duration (* 24 30) match))) (else #f))) +(define* (matching-generations str profile + #:key (duration-relation <=)) + "Return the list of available generations matching a pattern in STR. See +'string->generations' and 'string->duration' for the list of valid patterns. +When STR is a duration pattern, return all the generations whose ctime has +DURATION-RELATION with the current time." + (define (valid-generations lst) + (define (valid-generation? n) + (any (cut = n <>) (generation-numbers profile))) + + (fold-right (lambda (x acc) + (if (valid-generation? x) + (cons x acc) + acc)) + '() + lst)) + + (define (filter-generations generations) + (match generations + (() '()) + (('>= n) + (drop-while (cut > n <>) + (generation-numbers profile))) + (('<= n) + (valid-generations (iota n 1))) + ((lst ..1) + (valid-generations lst)) + (_ #f))) + + (define (filter-by-duration duration) + (define (time-at-midnight time) + ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and + ;; hours to zeros. + (let ((d (time-utc->date time))) + (date->time-utc + (make-date 0 0 0 0 + (date-day d) (date-month d) + (date-year d) (date-zone-offset d))))) + + (define generation-ctime-alist + (map (lambda (number) + (cons number + (time-second + (time-at-midnight + (generation-time profile number))))) + (generation-numbers profile))) + + (match duration + (#f #f) + (res + (let ((s (time-second + (subtract-duration (time-at-midnight (current-time)) + duration)))) + (delete #f (map (lambda (x) + (and (duration-relation s (cdr x)) + (first x))) + generation-ctime-alist)))))) + + (cond ((string->generations str) + => + filter-generations) + ((string->duration str) + => + filter-by-duration) + (else #f))) + (define* (package-specification->name+version+output spec #:optional (output "out")) "Parse package specification SPEC and return three value: the specified -- cgit v1.2.3 From deaab8e314982d1ddb65e41d043ceb5de3c3b723 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 19:50:56 +0100 Subject: guix system: Extract action processing. * guix/scripts/system.scm (process-action): New procedure. Extracted from... (guix-system): ... here. Use it. --- guix/scripts/system.scm | 95 ++++++++++++++++++++++++++----------------------- 1 file changed, 51 insertions(+), 44 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8775267f80..d973e60730 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -550,6 +550,55 @@ (define %default-options ;;; Entry point. ;;; +(define (process-action action args opts) + "Process ACTION, a sub-command, whose arguments are listed in ARGS. OPTS is +the raw alist of options resulting from command-line parsing." + (let* ((file (match args + (() #f) + ((x . _) x))) + (system (assoc-ref opts 'system)) + (os (if file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error)) + (leave (_ "no configuration file specified~%")))) + + (dry? (assoc-ref opts 'dry-run?)) + (grub? (assoc-ref opts 'install-grub?)) + (target (match args + ((first second) second) + (_ #f))) + (device (and grub? + (grub-configuration-device + (operating-system-bootloader os))))) + + (with-store store + (set-build-options-from-command-line store opts) + + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (case action + ((extension-graph) + (export-extension-graph os (current-output-port))) + ((dmd-graph) + (export-dmd-graph os (current-output-port))) + (else + (perform-action action os + #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:image-size (assoc-ref opts 'image-size) + #:full-boot? (assoc-ref opts 'full-boot?) + #:mappings (filter-map (match-lambda + (('file-system-mapping . m) + m) + (_ #f)) + opts) + #:grub? grub? + #:target target #:device device)))) + #:system system)))) + (define (guix-system . args) (define (parse-sub-command arg result) ;; Parse sub-command ARG and augment RESULT accordingly. @@ -600,49 +649,7 @@ (define (fail) #:argument-handler parse-sub-command)) (args (option-arguments opts)) - (file (first args)) - (action (assoc-ref opts 'action)) - (system (assoc-ref opts 'system)) - (os (if file - (load* file %user-module - #:on-error (assoc-ref opts 'on-error)) - (leave (_ "no configuration file specified~%")))) - - (dry? (assoc-ref opts 'dry-run?)) - (grub? (assoc-ref opts 'install-grub?)) - (target (match args - ((first second) second) - (_ #f))) - (device (and grub? - (grub-configuration-device - (operating-system-bootloader os)))) - - (store (open-connection))) - (set-build-options-from-command-line store opts) - - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (case action - ((extension-graph) - (export-extension-graph os (current-output-port))) - ((dmd-graph) - (export-dmd-graph os (current-output-port))) - (else - (perform-action action os - #:dry-run? dry? - #:derivations-only? (assoc-ref opts - 'derivations-only?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:image-size (assoc-ref opts 'image-size) - #:full-boot? (assoc-ref opts 'full-boot?) - #:mappings (filter-map (match-lambda - (('file-system-mapping . m) - m) - (_ #f)) - opts) - #:grub? grub? - #:target target #:device device)))) - #:system system)))) + (command (assoc-ref opts 'action))) + (process-action command args opts)))) ;;; system.scm ends here -- cgit v1.2.3 From d50cb56d9b58f3e1605f59b35ce99942c3b70d24 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 20:01:45 +0100 Subject: utils: Add 'readlink*'. * guix/scripts/package.scm (readlink*): Move to... * guix/utils.scm (readlink*): ... here. New procedure. --- guix/scripts/package.scm | 28 ---------------------------- guix/utils.scm | 28 ++++++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 804ca954f2..ee45cddedd 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -612,34 +612,6 @@ (define absolute (add-indirect-root store absolute)) -(define (readlink* file) - "Call 'readlink' until the result is not a symlink." - (define %max-symlink-depth 50) - - (let loop ((file file) - (depth 0)) - (define (absolute target) - (if (absolute-file-name? target) - target - (string-append (dirname file) "/" target))) - - (if (>= depth %max-symlink-depth) - file - (call-with-values - (lambda () - (catch 'system-error - (lambda () - (values #t (readlink file))) - (lambda args - (let ((errno (system-error-errno args))) - (if (or (= errno EINVAL)) - (values #f file) - (apply throw args)))))) - (lambda (success? target) - (if success? - (loop (absolute target) (+ depth 1)) - file)))))) - ;;; ;;; Entry point. diff --git a/guix/utils.scm b/guix/utils.scm index 190b787185..f1317ac756 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -82,6 +82,7 @@ (define-module (guix utils) fold-tree-leaves split cache-directory + readlink* filtered-port compressed-port @@ -710,6 +711,33 @@ (define (cache-directory) (and=> (getenv "HOME") (cut string-append <> "/.cache/guix")))) +(define (readlink* file) + "Call 'readlink' until the result is not a symlink." + (define %max-symlink-depth 50) + + (let loop ((file file) + (depth 0)) + (define (absolute target) + (if (absolute-file-name? target) + target + (string-append (dirname file) "/" target))) + + (if (>= depth %max-symlink-depth) + file + (call-with-values + (lambda () + (catch 'system-error + (lambda () + (values #t (readlink file))) + (lambda args + (let ((errno (system-error-errno args))) + (if (or (= errno EINVAL)) + (values #f file) + (apply throw args)))))) + (lambda (success? target) + (if success? + (loop (absolute target) (+ depth 1)) + file)))))) ;;; ;;; Source location. -- cgit v1.2.3 From ad18c7e64c844350f295a2f79605800a7718ed78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 21:16:20 +0100 Subject: ui: Add procedures to display a profile generation. * guix/scripts/package.scm (guix-package)[process-query](list-generations): Move part of the body to 'delete-generation' and 'display-profile-content'. * guix/ui.scm (display-generation, display-profile-content): New procedures. --- guix/scripts/package.scm | 21 ++------------------- guix/ui.scm | 28 ++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ee45cddedd..49df3349e8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -789,25 +789,8 @@ (define (process-query opts) (('list-generations pattern) (define (list-generation number) (unless (zero? number) - (let ((header (format #f (_ "Generation ~a\t~a") number - (date->string - (time-utc->date - (generation-time profile number)) - "~b ~d ~Y ~T"))) - (current (generation-number profile))) - (if (= number current) - (format #t (_ "~a\t(current)~%") header) - (format #t "~a~%" header))) - (for-each (match-lambda - (($ name version output location _) - (format #t " ~a\t~a\t~a\t~a~%" - name version output location))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest - (generation-file-name profile number))))) + (display-generation profile number) + (display-profile-content profile number) (newline))) (cond ((not (file-exists? profile)) ; XXX: race condition diff --git a/guix/ui.scm b/guix/ui.scm index 59ff2a7fba..c45c50fa16 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -85,6 +85,8 @@ (define-module (guix ui) string->generations string->duration matching-generations + display-generation + display-profile-content run-guix-command run-guix program-name @@ -1015,6 +1017,32 @@ (define generation-ctime-alist filter-by-duration) (else #f))) +(define (display-generation profile number) + "Display a one-line summary of generation NUMBER of PROFILE." + (unless (zero? number) + (let ((header (format #f (_ "Generation ~a\t~a") number + (date->string + (time-utc->date + (generation-time profile number)) + "~b ~d ~Y ~T"))) + (current (generation-number profile))) + (if (= number current) + (format #t (_ "~a\t(current)~%") header) + (format #t "~a~%" header))))) + +(define (display-profile-content profile number) + "Display the packages in PROFILE, generation NUMBER, in a human-readable +way." + (for-each (match-lambda + (($ name version output location _) + (format #t " ~a\t~a\t~a\t~a~%" + name version output location))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest (generation-file-name profile number)))))) + (define* (package-specification->name+version+output spec #:optional (output "out")) "Parse package specification SPEC and return three value: the specified -- cgit v1.2.3 From 5b516ef3696270f21327d9f63a9ccb4f1b83f346 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 21:19:42 +0100 Subject: guix system: Factorize boot parameter parsing. * guix/scripts/system.scm (): New record type. (read-boot-parameters): New procedure. (previous-grub-entries)[system->grub-entry]: Use it. --- guix/scripts/system.scm | 74 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 50 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d973e60730..6db6a01ac9 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -25,6 +25,7 @@ (define-module (guix scripts system) #:use-module (guix packages) #:use-module (guix utils) #:use-module (guix monads) + #:use-module (guix records) #:use-module (guix profiles) #:use-module (guix scripts) #:use-module (guix scripts build) @@ -184,6 +185,39 @@ (define (maybe-copy to-copy) (mwhen grub? (install-grub* grub.cfg device target))))) + +;;; +;;; Boot parameters +;;; + +(define-record-type* + boot-parameters make-boot-parameters boot-parameters? + (label boot-parameters-label) + (root-device boot-parameters-root-device) + (kernel boot-parameters-kernel) + (kernel-arguments boot-parameters-kernel-arguments)) + +(define (read-boot-parameters port) + "Read boot parameters from PORT and return the corresponding + object or #f if the format is unrecognized." + (match (read port) + (('boot-parameters ('version 0) + ('label label) ('root-device root) + ('kernel linux) + rest ...) + (boot-parameters + (label label) + (root-device root) + (kernel linux) + (kernel-arguments + (match (assq 'kernel-arguments rest) + ((_ args) args) + (#f '()))))) ;the old format + (x ;unsupported format + (warning (_ "unrecognized boot parameters for '~a'~%") + system) + #f))) + ;;; ;;; Reconfiguration. @@ -247,30 +281,22 @@ (define* (previous-grub-entries #:optional (profile %system-profile)) "Return a list of 'menu-entry' for the generations of PROFILE." (define (system->grub-entry system number time) (unless-file-not-found - (call-with-input-file (string-append system "/parameters") - (lambda (port) - (match (read port) - (('boot-parameters ('version 0) - ('label label) ('root-device root) - ('kernel linux) - rest ...) - (menu-entry - (label (string-append label " (#" - (number->string number) ", " - (seconds->string time) ")")) - (linux linux) - (linux-arguments - (cons* (string-append "--root=" root) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system "/boot") - (match (assq 'kernel-arguments rest) - ((_ args) args) - (#f '())))) ;old format - (initrd #~(string-append #$system "/initrd")))) - (_ ;unsupported format - (warning (_ "unrecognized boot parameters for '~a'~%") - system) - #f)))))) + (let ((file (string-append system "/parameters"))) + (match (call-with-input-file file read-boot-parameters) + (($ label root kernel kernel-arguments) + (menu-entry + (label (string-append label " (#" + (number->string number) ", " + (seconds->string time) ")")) + (linux kernel) + (linux-arguments + (cons* (string-append "--root=" root) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system "/boot") + kernel-arguments)) + (initrd #~(string-append #$system "/initrd")))) + (#f ;invalid format + #f))))) (let* ((numbers (generation-numbers profile)) (systems (map (cut generation-file-name profile <>) -- cgit v1.2.3 From 65797bfffd1b4d9126f11ffb6b59a1a7a18d48f0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 21:24:26 +0100 Subject: guix system: Add the 'list-generations' command. * guix/scripts/system.scm (display-system-generation, list-generations): New procedures. (process-action): Clarify docstring. (process-command): New procedure. (guix-system)[parse-sub-command]: Add 'list-generations' Call 'process-command' instead of 'process-action'. * doc/guix.texi (Using the Configuration System): Mention generations, rollback, and 'list-generations'. (Invoking guix system): Document 'list-generations'. --- doc/guix.texi | 47 +++++++++++++++++++++++++++++--- guix/scripts/system.scm | 72 +++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 110 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 7715b72818..20bf28424e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5369,9 +5369,24 @@ information about the @code{nss-certs} package that is used here. Assuming the above snippet is stored in the @file{my-system-config.scm} file, the @command{guix system reconfigure my-system-config.scm} command instantiates that configuration, and makes it the default GRUB boot -entry (@pxref{Invoking guix system}). The normal way to change the -system's configuration is by updating this file and re-running the -@command{guix system} command. +entry (@pxref{Invoking guix system}). + +The normal way to change the system's configuration is by updating this +file and re-running @command{guix system reconfigure}. One should never +have to touch files in @command{/etc} or to run commands that modify the +system state such as @command{useradd} or @command{grub-install}. In +fact, you must avoid that since that would not only void your warranty +but also prevent you from rolling back to previous versions of your +system, should you ever need to. + +@cindex roll-back, of the operating system +Speaking of roll-back, each time you run @command{guix system +reconfigure}, a new @dfn{generation} of the system is created---without +modifying or deleting previous generations. Old system generations get +an entry in the GRUB boot menu, allowing you to boot them in case +something went wrong with the latest generation. Reassuring, no? The +@command{guix system list-generations} command lists the system +generations available on disk. At the Scheme level, the bulk of an @code{operating-system} declaration is instantiated with the following monadic procedure (@pxref{The Store @@ -7077,7 +7092,7 @@ supported: @item reconfigure Build the operating system described in @var{file}, activate it, and switch to it@footnote{This action is usable only on systems already -running GNU.}. +running GuixSD.}. This effects all the configuration specified in @var{file}: user accounts, system services, global package list, setuid programs, etc. @@ -7218,6 +7233,30 @@ KVM kernel module should be loaded, and the @file{/dev/kvm} device node must exist and be readable and writable by the user and by the daemon's build users. +Once you have built, configured, re-configured, and re-re-configured +your GuixSD installation, you may find it useful to list the operating +system generations available on disk---and that you can choose from the +GRUB boot menu: + +@table @code + +@item list-generations +List a summary of each generation of the operating system available on +disk, in a human-readable way. This is similar to the +@option{--list-generations} option of @command{guix package} +(@pxref{Invoking guix package}). + +Optionally, one can specify a pattern, with the same syntax that is used +in @command{guix package --list-generations}, to restrict the list of +generations displayed. For instance, the following command displays +generations up to 10-day old: + +@example +$ guix system list-generations 10d +@end example + +@end table + The @command{guix system} command has even more to offer! The following sub-commands allow you to visualize how your system services relate to each other: diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6db6a01ac9..d847c75444 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -42,6 +42,8 @@ (define-module (guix scripts system) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-system @@ -351,6 +353,48 @@ (define (dmd-service-node-type services) (label dmd-service-node-label) (edges (lift1 (dmd-service-back-edges services) %store-monad)))) + +;;; +;;; Generations. +;;; + +(define* (display-system-generation number + #:optional (profile %system-profile)) + "Display a summary of system generation NUMBER in a human-readable format." + (unless (zero? number) + (let* ((generation (generation-file-name profile number)) + (param-file (string-append generation "/parameters")) + (params (call-with-input-file param-file read-boot-parameters))) + (display-generation profile number) + (format #t (_ " file name: ~a~%") generation) + (format #t (_ " canonical file name: ~a~%") (readlink* generation)) + (match params + (($ label root kernel) + ;; TRANSLATORS: Please preserve the two-space indentation. + (format #t (_ " label: ~a~%") label) + (format #t (_ " root device: ~a~%") root) + (format #t (_ " kernel: ~a~%") kernel)) + (_ + #f))))) + +(define* (list-generations pattern #:optional (profile %system-profile)) + "Display in a human-readable format all the system generations matching +PATTERN, a string. When PATTERN is #f, display all the system generations." + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each display-system-generation (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each display-system-generation numbers))))) + (else + (leave (_ "invalid syntax: ~a~%") pattern)))) + ;;; ;;; Action. @@ -468,13 +512,15 @@ (define (export-dmd-graph os port) ;;; (define (show-help) - (display (_ "Usage: guix system [OPTION] ACTION FILE + (display (_ "Usage: guix system [OPTION] ACTION [FILE] Build the operating system declared in FILE according to ACTION.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) (newline) (display (_ "\ reconfigure switch to a new operating system configuration\n")) + (display (_ "\ + list-generations list the system generations\n")) (display (_ "\ build build the operating system without installing anything\n")) (display (_ "\ @@ -577,8 +623,10 @@ (define %default-options ;;; (define (process-action action args opts) - "Process ACTION, a sub-command, whose arguments are listed in ARGS. OPTS is -the raw alist of options resulting from command-line parsing." + "Process ACTION, a sub-command, with the arguments are listed in ARGS. +ACTION must be one of the sub-commands that takes an operating system +declaration as an argument (a file name.) OPTS is the raw alist of options +resulting from command-line parsing." (let* ((file (match args (() #f) ((x . _) x))) @@ -625,6 +673,20 @@ (define (process-action action args opts) #:target target #:device device)))) #:system system)))) +(define (process-command command args opts) + "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its +argument list and OPTS is the option alist." + (case command + ((list-generations) + ;; List generations. No need to connect to the daemon, etc. + (let ((pattern (match args + (() "") + ((pattern) pattern) + (x (leave (_ "wrong number of arguments~%")))))) + (list-generations pattern))) + (else + (process-action command args opts)))) + (define (guix-system . args) (define (parse-sub-command arg result) ;; Parse sub-command ARG and augment RESULT accordingly. @@ -633,7 +695,7 @@ (define (parse-sub-command arg result) (let ((action (string->symbol arg))) (case action ((build vm vm-image disk-image reconfigure init - extension-graph dmd-graph) + extension-graph dmd-graph list-generations) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -676,6 +738,6 @@ (define (fail) parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (process-action command args opts)))) + (process-command command args opts)))) ;;; system.scm ends here -- cgit v1.2.3 From 3bb168b0997d2ba2ef15e8eef2890582c8a6df9c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 22:17:25 +0100 Subject: utils: Add 'switch-symlinks', moved from (guix ui). * guix/ui.scm (switch-symlinks): Move to... * guix/utils.scm: ... here. New procedure. * guix/scripts/pull.scm: Use it. --- guix/scripts/pull.scm | 1 + guix/ui.scm | 8 -------- guix/utils.scm | 8 ++++++++ 3 files changed, 9 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 56ee9acb18..a4824e4fd7 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -18,6 +18,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) + #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) diff --git a/guix/ui.scm b/guix/ui.scm index c45c50fa16..b7ed5e7d4d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -73,7 +73,6 @@ (define-module (guix ui) read/eval read/eval-package-expression location->string - switch-symlinks config-directory fill-paragraph texi->plain-text @@ -715,13 +714,6 @@ (define (location->string loc) (($ file line column) (format #f "~a:~a:~a" file line column)))) -(define (switch-symlinks link target) - "Atomically switch LINK, a symbolic link, to point to TARGET. Works -both when LINK already exists and when it does not." - (let ((pivot (string-append link ".new"))) - (symlink target pivot) - (rename-file pivot link))) - (define (config-directory) "Return the name of the configuration directory, after making sure that it exists. Honor the XDG specs, diff --git a/guix/utils.scm b/guix/utils.scm index f1317ac756..1542e86f7a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -74,6 +74,7 @@ (define-module (guix utils) arguments-from-environment-variable file-extension file-sans-extension + switch-symlinks call-with-temporary-output-file call-with-temporary-directory with-atomic-file-output @@ -557,6 +558,13 @@ (define (file-sans-extension file) (substring file 0 dot) file))) +(define (switch-symlinks link target) + "Atomically switch LINK, a symbolic link, to point to TARGET. Works +both when LINK already exists and when it does not." + (let ((pivot (string-append link ".new"))) + (symlink target pivot) + (rename-file pivot link))) + (define* (string-replace-substring str substr replacement #:optional (start 0) -- cgit v1.2.3 From 06d45f4566469364b4c1fe6d3c71ecf58f5d4838 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 23:01:06 +0100 Subject: profiles: Add generation manipulation procedures. * guix/scripts/package.scm (delete-generations): Use 'delete-generation*' instead of 'delete-generation'. (guix-package)[process-actions]: Use 'roll-back*' instead of 'roll-back' and 'switch-to-generation*' instead of 'switch-to-generation'. (link-to-empty-profile, switch-to-generation, switch-to-previous-generation, roll-back, delete-generation): Move to... * guix/profiles.scm: ... here. Adjust to not print messages and to return values that can be used by user interfaces. * guix/ui.scm (display-generation-change, roll-back*, switch-to-generation*, delete-generation*): New procedures. --- guix/profiles.scm | 80 +++++++++++++++++++++++++++++++++++++++++++++- guix/scripts/package.scm | 83 +++--------------------------------------------- guix/ui.scm | 24 ++++++++++++++ 3 files changed, 107 insertions(+), 80 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index fac322bbab..e8bd564efa 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -84,13 +84,17 @@ (define-module (guix profiles) packages->manifest %default-profile-hooks profile-derivation + generation-number generation-numbers profile-generations relative-generation previous-generation-number generation-time - generation-file-name)) + generation-file-name + switch-to-generation + roll-back + delete-generation)) ;;; Commentary: ;;; @@ -844,4 +848,78 @@ (define (generation-time profile number) (make-time time-utc 0 (stat:ctime (stat (generation-file-name profile number))))) +(define (link-to-empty-profile store generation) + "Link GENERATION, a string, to the empty profile. An error is raised if +that fails." + (let* ((drv (run-with-store store + (profile-derivation (manifest '())))) + (prof (derivation->output-path drv "out"))) + (build-derivations store (list drv)) + (switch-symlinks generation prof))) + +(define (switch-to-generation profile number) + "Atomically switch PROFILE to the generation NUMBER. Return the number of +the generation that was current before switching." + (let ((current (generation-number profile)) + (generation (generation-file-name profile number))) + (cond ((not (file-exists? profile)) + (raise (condition (&profile-not-found-error + (profile profile))))) + ((not (file-exists? generation)) + (raise (condition (&missing-generation-error + (profile profile) + (generation number))))) + (else + (switch-symlinks profile generation) + current)))) + +(define (switch-to-previous-generation profile) + "Atomically switch PROFILE to the previous generation. Return the former +generation number and the current one." + (let ((previous (previous-generation-number profile))) + (values (switch-to-generation profile previous) + previous))) + +(define (roll-back store profile) + "Roll back to the previous generation of PROFILE. Return the number of the +generation that was current before switching and the new generation number." + (let* ((number (generation-number profile)) + (previous-number (previous-generation-number profile number)) + (previous-generation (generation-file-name profile previous-number))) + (cond ((not (file-exists? profile)) ;invalid profile + (raise (condition (&profile-not-found-error + (profile profile))))) + ((zero? number) ;empty profile + (values number number)) + ((or (zero? previous-number) ;going to emptiness + (not (file-exists? previous-generation))) + (link-to-empty-profile store previous-generation) + (switch-to-previous-generation profile)) + (else ;anything else + (switch-to-previous-generation profile))))) + +(define (delete-generation store profile number) + "Delete generation with NUMBER from PROFILE. Return the file name of the +generation that has been deleted, or #f if nothing was done (for instance +because the NUMBER is zero.)" + (define (delete-and-return) + (let ((generation (generation-file-name profile number))) + (delete-file generation) + generation)) + + (let* ((current-number (generation-number profile)) + (previous-number (previous-generation-number profile number)) + (previous-generation (generation-file-name profile previous-number))) + (cond ((zero? number) #f) ;do not delete generation 0 + ((and (= number current-number) + (not (file-exists? previous-generation))) + (link-to-empty-profile store previous-generation) + (switch-to-previous-generation profile) + (delete-and-return)) + ((= number current-number) + (roll-back store profile) + (delete-and-return)) + (else + (delete-and-return))))) + ;;; profiles.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 49df3349e8..d8689490b7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -48,11 +48,7 @@ (define-module (guix scripts package) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) - #:export (switch-to-generation - switch-to-previous-generation - roll-back - delete-generation - delete-generations + #:export (delete-generations display-search-paths guix-package)) @@ -100,81 +96,10 @@ (define (user-friendly-profile profile) %user-profile-directory profile)) -(define (link-to-empty-profile store generation) - "Link GENERATION, a string, to the empty profile." - (let* ((drv (run-with-store store - (profile-derivation (manifest '())))) - (prof (derivation->output-path drv "out"))) - (when (not (build-derivations store (list drv))) - (leave (_ "failed to build the empty profile~%"))) - - (switch-symlinks generation prof))) - -(define (switch-to-generation profile number) - "Atomically switch PROFILE to the generation NUMBER." - (let ((current (generation-number profile)) - (generation (generation-file-name profile number))) - (cond ((not (file-exists? profile)) - (raise (condition (&profile-not-found-error - (profile profile))))) - ((not (file-exists? generation)) - (raise (condition (&missing-generation-error - (profile profile) - (generation number))))) - (else - (format #t (_ "switching from generation ~a to ~a~%") - current number) - (switch-symlinks profile generation))))) - -(define (switch-to-previous-generation profile) - "Atomically switch PROFILE to the previous generation." - (switch-to-generation profile - (previous-generation-number profile))) - -(define (roll-back store profile) - "Roll back to the previous generation of PROFILE." - (let* ((number (generation-number profile)) - (previous-number (previous-generation-number profile number)) - (previous-generation (generation-file-name profile previous-number))) - (cond ((not (file-exists? profile)) ; invalid profile - (raise (condition (&profile-not-found-error - (profile profile))))) - ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) - ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-generation))) - (link-to-empty-profile store previous-generation) - (switch-to-previous-generation profile)) - (else - (switch-to-previous-generation profile))))) ; anything else - -(define (delete-generation store profile number) - "Delete generation with NUMBER from PROFILE." - (define (display-and-delete) - (let ((generation (generation-file-name profile number))) - (format #t (_ "deleting ~a~%") generation) - (delete-file generation))) - - (let* ((current-number (generation-number profile)) - (previous-number (previous-generation-number profile number)) - (previous-generation (generation-file-name profile previous-number))) - (cond ((zero? number)) ; do not delete generation 0 - ((and (= number current-number) - (not (file-exists? previous-generation))) - (link-to-empty-profile store previous-generation) - (switch-to-previous-generation profile) - (display-and-delete)) - ((= number current-number) - (roll-back store profile) - (display-and-delete)) - (else - (display-and-delete))))) - (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. GENERATIONS is a list of generation numbers." - (for-each (cut delete-generation store profile <>) + (for-each (cut delete-generation* store profile <>) generations)) (define (delete-matching-generations store profile pattern) @@ -725,7 +650,7 @@ (define (build-and-use-profile manifest) ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) - (roll-back (%store) profile) + (roll-back* (%store) profile) (process-actions (alist-delete 'roll-back? opts))) ((and (assoc-ref opts 'switch-generation) (not dry-run?)) @@ -739,7 +664,7 @@ (define (build-and-use-profile manifest) (relative-generation profile number)) (else number))))) (if number - (switch-to-generation profile number) + (switch-to-generation* profile number) (leave (_ "cannot switch to generation '~a'~%") pattern))) (process-actions (alist-delete 'switch-generation opts))) diff --git a/guix/ui.scm b/guix/ui.scm index b7ed5e7d4d..72208e7de7 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -86,6 +86,9 @@ (define-module (guix ui) matching-generations display-generation display-profile-content + roll-back* + switch-to-generation* + delete-generation* run-guix-command run-guix program-name @@ -1035,6 +1038,27 @@ (define (display-profile-content profile number) (manifest-entries (profile-manifest (generation-file-name profile number)))))) +(define (display-generation-change previous current) + (format #t (_ "switched from generation ~a to ~a~%") previous current)) + +(define (roll-back* store profile) + "Like 'roll-back', but display what is happening." + (call-with-values + (lambda () + (roll-back store profile)) + display-generation-change)) + +(define (switch-to-generation* profile number) + "Like 'switch-generation', but display what is happening." + (let ((previous (switch-to-generation profile number))) + (display-generation-change previous number))) + +(define (delete-generation* store profile generation) + "Like 'delete-generation', but display what is going on." + (format #t (_ "deleting ~a~%") + (generation-file-name profile generation)) + (delete-generation store profile generation)) + (define* (package-specification->name+version+output spec #:optional (output "out")) "Parse package specification SPEC and return three value: the specified -- cgit v1.2.3 From 7e6b490d041935d0f77de3cee0493707435a34d6 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Mon, 26 Oct 2015 21:24:53 +0300 Subject: upstream: Add 'description' field to 'upstream-updater'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Suggested by Ludovic Courtès . * guix/upstream.scm (): Use 'define-record-type*'. [description]: New field. (lookup-updater): Adjust accordingly. * guix/gnu-maintenance.scm (%gnu-updater): Likewise. * guix/import/cran.scm (%cran-updater): Likewise. * guix/import/elpa.scm (%elpa-updater): Likewise. * po/guix/POTFILES.in: Add guix/scripts/import/cran.scm and guix/gnu-maintenance.scm. --- guix/gnu-maintenance.scm | 8 +++++--- guix/import/cran.scm | 8 +++++--- guix/import/elpa.scm | 8 +++++--- guix/upstream.scm | 15 +++++++++------ po/guix/POTFILES.in | 2 ++ 5 files changed, 26 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 5af1b884ce..e1455ccb98 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -413,8 +413,10 @@ (define (non-emacs-gnu-package? package) (gnu-package? package))) (define %gnu-updater - (upstream-updater 'gnu - non-emacs-gnu-package? - latest-release*)) + (upstream-updater + (name 'gnu) + (description "Updater for GNU packages") + (pred non-emacs-gnu-package?) + (latest latest-release*))) ;;; gnu-maintenance.scm ends here diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 6284c9eef3..4b53d5e2c2 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -236,8 +236,10 @@ (define (cran-package? package) (string-prefix? "r-" (package-name package))) (define %cran-updater - (upstream-updater 'cran - cran-package? - latest-release)) + (upstream-updater + (name 'cran) + (description "Updater for CRAN packages") + (pred cran-package?) + (latest latest-release))) ;;; cran.scm ends here diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 37fc2b80fe..8c10668293 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -272,8 +272,10 @@ (define (package-from-gnu.org? package) (define %elpa-updater ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org ;; because for other repositories, we typically grab the source elsewhere. - (upstream-updater 'elpa - package-from-gnu.org? - latest-release)) + (upstream-updater + (name 'elpa) + (description "Updater for ELPA packages") + (pred package-from-gnu.org?) + (latest latest-release))) ;;; elpa.scm ends here diff --git a/guix/upstream.scm b/guix/upstream.scm index 9300113ac6..219ae0568c 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2015 Alex Kost ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,6 +46,7 @@ (define-module (guix upstream) upstream-updater upstream-updater? upstream-updater-name + upstream-updater-description upstream-updater-predicate upstream-updater-latest @@ -109,18 +111,19 @@ (define (release>? r1 r2) ;;; Auto-update. ;;; -(define-record-type - (upstream-updater name pred latest) +(define-record-type* + upstream-updater make-upstream-updater upstream-updater? - (name upstream-updater-name) - (pred upstream-updater-predicate) - (latest upstream-updater-latest)) + (name upstream-updater-name) + (description upstream-updater-description) + (pred upstream-updater-predicate) + (latest upstream-updater-latest)) (define (lookup-updater package updaters) "Return an updater among UPDATERS that matches PACKAGE, or #f if none of them matches." (any (match-lambda - (($ _ pred latest) + (($ _ _ pred latest) (and (pred package) latest))) updaters)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 0c4e4f8443..41cf9ee0f4 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -12,6 +12,7 @@ guix/scripts/package.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm +guix/scripts/import/cran.scm guix/scripts/import/elpa.scm guix/scripts/pull.scm guix/scripts/substitute.scm @@ -23,6 +24,7 @@ guix/scripts/edit.scm guix/scripts/size.scm guix/scripts/graph.scm guix/scripts/challenge.scm +guix/gnu-maintenance.scm guix/upstream.scm guix/ui.scm guix/http-client.scm -- cgit v1.2.3 From 6ffa706b6d80265b2fd244484b42492a71a2ef31 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Thu, 22 Oct 2015 10:51:17 +0300 Subject: refresh: Add '--list-updaters' option. * guix/scripts/refresh.scm (list-updaters-and-exit): New procedure. (%options, show-help): Add '--list-updaters' option. * doc/guix.texi (Invoking guix refresh): Document it. --- doc/guix.texi | 4 ++++ guix/scripts/refresh.scm | 16 ++++++++++++++++ 2 files changed, 20 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 20bf28424e..1bb7125fa2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4305,6 +4305,10 @@ be used when passing @command{guix refresh} one or more package names: @table @code +@item --list-updaters +@itemx -L +List available updaters and exit (see @option{--type} above.) + @item --list-dependent @itemx -l List top-level dependent packages that would need to be rebuilt as a diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 6f7ca4a41b..a66b3f9ea8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2015 Alex Kost ;;; ;;; This file is part of GNU Guix. ;;; @@ -69,6 +70,9 @@ (define %options (option '(#\t "type") #t #f (lambda (opt name arg result) (alist-cons 'updater (string->symbol arg) result))) + (option '(#\L "list-updaters") #f #f + (lambda args + (list-updaters-and-exit))) (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) @@ -112,6 +116,8 @@ (define (show-help) (display (_ " -t, --type=UPDATER restrict to updates from UPDATER--e.g., 'gnu'")) (display (_ " + -L, --list-updaters list available updaters and exit")) + (display (_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) (newline) @@ -149,6 +155,16 @@ (define (lookup-updater name) (eq? name (upstream-updater-name updater))) %updaters)) +(define (list-updaters-and-exit) + "Display available updaters and exit." + (format #t (_ "Available updaters:~%")) + (for-each (lambda (updater) + (format #t "- ~a: ~a~%" + (upstream-updater-name updater) + (_ (upstream-updater-description updater)))) + %updaters) + (exit 0)) + (define* (update-package store package updaters #:key (key-download 'interactive)) "Update the source file that defines PACKAGE with the new version. -- cgit v1.2.3 From f151298fa00c9532d29cdc9eb4930fb2bfc23c06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Oct 2015 11:45:27 +0100 Subject: substitute: 'http-multiple-get' follows 'fold' style. * guix/scripts/substitute.scm (http-multiple-get): Add 'seed' parameter. Call PROC in 'fold' style. (fetch-narinfos)[handle-narinfo-response]: Adjust accordingly. Update 'http-multiple-get' call accordingly. --- guix/scripts/substitute.scm | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8967fa062e..0377bb6abe 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -474,12 +474,13 @@ (define (narinfo-request cache-url path) ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-url requests proc) +(define (http-multiple-get base-url proc seed requests) "Send all of REQUESTS to the server at BASE-URL. Call PROC for each -response, passing it the request object, the response, and a port from which -to read the response body. Return the list of results." +response, passing it the request object, the response, a port from which to +read the response body, and the previous result, starting with SEED, à la +'fold'. Return the final result." (let connect ((requests requests) - (result '())) + (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) (let ((p (open-socket-for-uri base-url))) @@ -497,7 +498,7 @@ (define (http-multiple-get base-url requests proc) ((head tail ...) (let* ((resp (read-response p)) (body (response-body-port resp)) - (result (cons (proc head resp body) result))) + (result (proc head resp body result))) ;; The server can choose to stop responding at any time, in which ;; case we have to try again. Check whether that is the case. ;; Note that even upon "Connection: close", we can read from BODY. @@ -536,7 +537,7 @@ (define update-progress! url (* 100. (/ done (length paths)))) (set! done (+ 1 done))))) - (define (handle-narinfo-response request response port) + (define (handle-narinfo-response request response port result) (let ((len (response-content-length response))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. @@ -545,7 +546,7 @@ (define (handle-narinfo-response request response port) (let ((narinfo (read-narinfo port url #:size len))) (cache-narinfo! url (narinfo-path narinfo) narinfo) (update-progress!) - narinfo)) + (cons narinfo result))) ((404) ; failure (let* ((path (uri-path (request-uri request))) (hash-part (string-drop-right path 8))) ; drop ".narinfo" @@ -555,13 +556,13 @@ (define (handle-narinfo-response request response port) (cache-narinfo! url (find (cut string-contains <> hash-part) paths) #f) - (update-progress!)) - #f) + (update-progress!) + result)) (else ; transient failure (if len (get-bytevector-n port len) (read-to-eof port)) - #f)))) + result)))) (define cache-info (download-cache-info url)) @@ -574,8 +575,9 @@ (define cache-info ((http) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) - (let ((result (http-multiple-get url requests - handle-narinfo-response))) + (let ((result (http-multiple-get url + handle-narinfo-response '() + requests))) (newline (current-error-port)) result))) ((file #f) -- cgit v1.2.3 From a89dde1ed89a53f33556ab12ec73bafe495a796c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Oct 2015 11:48:27 +0100 Subject: substitute: 'lookup-narinfos' returns exactly a list of narinfos. * guix/scripts/substitute.scm (lookup-narinfos): Filter out #f values from CACHED, such that the end result is exactly a list of narinfos, not interspersed with #f. * guix/scripts/challenge.scm (discrepancies): Assume REMOTE is a list of narinfos. --- guix/scripts/challenge.scm | 6 ++---- guix/scripts/substitute.scm | 4 +++- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 19a9b061b8..4a0c865b07 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -125,10 +125,8 @@ (define (select-reference item narinfos urls) servers)) ;; No 'assert-valid-narinfo' on purpose. (narinfos -> (fold (lambda (narinfo vhash) - (if narinfo - (vhash-cons (narinfo-path narinfo) narinfo - vhash) - vhash)) + (vhash-cons (narinfo-path narinfo) narinfo + vhash)) vlist-null remote))) (return (filter-map (lambda (item local) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 0377bb6abe..34fee5863f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -598,7 +598,9 @@ (define (lookup-narinfos cache paths) (let-values (((valid? value) (cached-narinfo cache path))) (if valid? - (values (cons value cached) missing) + (if value + (values (cons value cached) missing) + (values cached missing)) (values cached (cons path missing))))) '() '() -- cgit v1.2.3 From 55b2fc18772a512a2227757423e55dc6c7523113 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Oct 2015 10:11:43 +0100 Subject: substitute: Honor all the specified server URLs. * guix/scripts/substitute.scm (lookup-narinfos/diverse): New procedure. (lookup-narinfo): Use it. (process-query): Change #:cache-url to #:cache-urls. [valid?]: Remove 'narinfo?' check, which is no longer necessary. Use 'lookup-narinfos/diverse' instead of 'lookup-narinfos'. (process-substitution): Change #:cache-url to #:cache-urls. (%cache-url): Rename to... (%cache-urls): ... this. Turn into a list. (guix-substitute): Remove 'getaddrinfo' test with early exit. Adjust calls to 'process-query' and 'process-substitution'. * tests/substitute.scm: Change '%cache-url' to '%cache-urls'. --- guix/scripts/substitute.scm | 83 ++++++++++++++++++++++++--------------------- tests/substitute.scm | 4 +-- 2 files changed, 46 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 34fee5863f..964df9422c 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -72,6 +72,7 @@ (define-module (guix scripts substitute) assert-valid-narinfo lookup-narinfos + lookup-narinfos/diverse read-narinfo write-narinfo guix-substitute)) @@ -610,11 +611,32 @@ (define (lookup-narinfos cache paths) (let ((missing (fetch-narinfos cache missing))) (append cached (or missing '())))))) -(define (lookup-narinfo cache path) - "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was -found." - (match (lookup-narinfos cache (list path)) - ((answer) answer))) +(define (lookup-narinfos/diverse caches paths) + "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. +That is, when a cache lacks a narinfo, look it up in the next cache, and so +on. Return a list of narinfos for PATHS or a subset thereof." + (let loop ((caches caches) + (paths paths) + (result '())) + (match paths + (() ;we're done + result) + (_ + (match caches + ((cache rest ...) + (let* ((narinfos (lookup-narinfos cache paths)) + (hits (map narinfo-path narinfos)) + (missing (lset-difference string=? paths hits))) ;XXX: perf + (loop rest missing (append narinfos result)))) + (() ;that's it + result)))))) + +(define (lookup-narinfo caches path) + "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH +was found." + (match (lookup-narinfos/diverse caches (list path)) + ((answer) answer) + (_ #f))) (define (remove-expired-cached-narinfos directory) "Remove expired narinfo entries from DIRECTORY. The sole purpose of this @@ -756,34 +778,34 @@ (define (display-narinfo-data narinfo) (or (narinfo-size narinfo) 0))) (define* (process-query command - #:key cache-url acl) + #:key cache-urls acl) "Reply to COMMAND, a query as written by the daemon to this process's standard input. Use ACL as the access-control list against which to check authorized substitutes." (define (valid? obj) - (and (narinfo? obj) (valid-narinfo? obj acl))) + (valid-narinfo? obj acl)) (match (string-tokenize command) (("have" paths ..1) - ;; Return the subset of PATHS available in CACHE-URL. - (let ((substitutable (lookup-narinfos cache-url paths))) + ;; Return the subset of PATHS available in CACHE-URLS. + (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) (filter valid? substitutable)) (newline))) (("info" paths ..1) - ;; Reply info about PATHS if it's in CACHE-URL. - (let ((substitutable (lookup-narinfos cache-url paths))) + ;; Reply info about PATHS if it's in CACHE-URLS. + (let ((substitutable (lookup-narinfos/diverse cache-urls paths))) (for-each display-narinfo-data (filter valid? substitutable)) (newline))) (wtf (error "unknown `--query' command" wtf)))) (define* (process-substitution store-item destination - #:key cache-url acl) - "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to + #:key cache-urls acl) + "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." - (let* ((narinfo (lookup-narinfo cache-url store-item)) + (let* ((narinfo (lookup-narinfo cache-urls store-item)) (uri (narinfo-uri narinfo))) ;; Make sure it is signed and everything. (assert-valid-narinfo narinfo acl) @@ -880,21 +902,16 @@ (define-syntax-rule (or* a b) b first))) -(define %cache-url +(define %cache-urls (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client (find-daemon-option "substitute-urls")) ;admin string-tokenize) - ((url) - url) - ((head tail ..1) - ;; Currently we don't handle multiple substitute URLs. - (warning (_ "these substitute URLs will not be used:~{ ~a~}~%") - tail) - head) + ((urls ...) + urls) (#f ;; This can only happen when this script is not invoked by the ;; daemon. - "http://hydra.gnu.org"))) + '("http://hydra.gnu.org")))) (define (guix-substitute . args) "Implement the build daemon's substituter protocol." @@ -905,20 +922,8 @@ (define (guix-substitute . args) ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly ;; when we know we cannot substitute, but we must emit a newline on stdout ;; when everything is alright. - (let ((uri (string->uri %cache-url))) - (case (uri-scheme uri) - ((http) - ;; Exit gracefully if there's no network access. - (let ((host (uri-host uri))) - (catch 'getaddrinfo-error - (lambda () - (getaddrinfo host)) - (lambda (key error) - (warning (_ "failed to look up host '~a' (~a), \ -substituter disabled~%") - host (gai-strerror error)) - (exit 0))))) - (else #t))) + (when (null? %cache-urls) + (exit 0)) ;; Say hello (see above.) (newline) @@ -933,13 +938,13 @@ (define (guix-substitute . args) (or (eof-object? command) (begin (process-query command - #:cache-url %cache-url + #:cache-urls %cache-urls #:acl acl) (loop (read-line))))))) (("--substitute" store-path destination) ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. (process-substitution store-path destination - #:cache-url %cache-url + #:cache-urls %cache-urls #:acl (current-acl))) (("--version") (show-version-and-exit "guix substitute")) diff --git a/tests/substitute.scm b/tests/substitute.scm index 85698127fa..9d907e7abf 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -167,8 +167,8 @@ (define-syntax-rule (with-narinfo narinfo body ...) (call-with-narinfo narinfo (lambda () body ...))) ;; Transmit these options to 'guix substitute'. -(set! (@@ (guix scripts substitute) %cache-url) - (getenv "GUIX_BINARY_SUBSTITUTE_URL")) +(set! (@@ (guix scripts substitute) %cache-urls) + (list (getenv "GUIX_BINARY_SUBSTITUTE_URL"))) (test-equal "query narinfo without signature" "" ; not substitutable -- cgit v1.2.3 From 34a1783fc1498d7150210da22dd7804d288438b3 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 26 Oct 2015 18:09:28 -0400 Subject: scripts: build: Add --file option. * guix/scripts/build.scm (show-help): Add help text for --file option. (%options): Add --file option. (options/resolve-packages): Handle 'file' options. * tests/guix-build.sh: Add tests. * doc/guix.texi ("invoking guix build"): Add doc. --- doc/guix.texi | 13 +++++++++++++ guix/scripts/build.scm | 45 ++++++++++++++++++++++++++++----------------- tests/guix-build.sh | 27 +++++++++++++++++++++++++++ 3 files changed, 68 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 1bb7125fa2..9878b93ddb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3615,6 +3615,19 @@ The @var{options} may be zero or more of the following: @table @code +@item --file=@var{file} +@itemx -f @var{file} + +Build the package or derivation that the code within @var{file} +evaluates to. + +As an example, @var{file} might contain a package definition like this +(@pxref{Defining Packages}): + +@example +@verbatiminclude package-hello.scm +@end example + @item --expression=@var{expr} @itemx -e @var{expr} Build the package or derivation @var{expr} evaluates to. diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a357cf8aa4..ee7e5b958c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -290,6 +290,9 @@ (define (show-help) (display (_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " + -f, --file=FILE build the package or derivation that the code within + FILE evaluates to")) + (display (_ " -S, --source build the packages' source derivations")) (display (_ " --sources[=TYPE] build source derivations; TYPE may optionally be one @@ -359,6 +362,9 @@ (define %options (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\f "file") #t #f + (lambda (opt name arg result) + (alist-cons 'file arg result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -422,29 +428,34 @@ (define (options/resolve-packages store opts) (define system (or (assoc-ref opts 'system) (%current-system))) + (define (object->argument obj) + (match obj + ((? package? p) + `(argument . ,p)) + ((? procedure? proc) + (let ((drv (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + `(argument . ,drv))) + ((? gexp? gexp) + (let ((drv (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system))))) + `(argument . ,drv))))) + (map (match-lambda (('argument . (? string? spec)) (if (store-path? spec) `(argument . ,spec) `(argument . ,(specification->package spec)))) + (('file . file) + (object->argument (load* file (make-user-module '())))) (('expression . str) - (match (read/eval str) - ((? package? p) - `(argument . ,p)) - ((? procedure? proc) - (let ((drv (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - `(argument . ,drv))) - ((? gexp? gexp) - (let ((drv (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system))))) - `(argument . ,drv))))) + (object->argument (read/eval str))) (opt opt)) opts)) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index a72ce0911d..f7fb3c5b64 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -167,6 +167,33 @@ guix build -e "(begin guix build -e '#~(mkdir #$output)' -d guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv' +# Building from a package file. +cat > "$module_dir/package.scm"< "$module_dir/proc.scm"<derivation "test" + (gexp (mkdir (ungexp output))))) +EOF +guix build --file="$module_dir/proc.scm" --dry-run + +# Building from a gexp file. +cat > "$module_dir/gexp.scm"< Date: Wed, 28 Oct 2015 15:20:06 +0100 Subject: store: Use the daemon's substitute URLs by default. Partly fixes . * guix/store.scm (set-build-options): Change #:substitute-urls to default to #f. Send the 'substitute-urls' pair only if SUBSTITUTE-URLS is true. * guix/scripts/build.scm (set-build-options-from-command-line): Do not default to %DEFAULT-SUBSTITUTE-URLS for #:substitute-urls. * guix/scripts/size.scm (%default-options): Remove 'substitute-urls'. --- guix/scripts/build.scm | 5 +++-- guix/scripts/size.scm | 3 +-- guix/store.scm | 15 +++++++++------ 3 files changed, 13 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ee7e5b958c..644ffe8d6e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -185,8 +185,7 @@ (define (set-build-options-from-command-line store opts) #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) - #:substitute-urls (or (assoc-ref opts 'substitute-urls) - %default-substitute-urls) + #:substitute-urls (assoc-ref opts 'substitute-urls) #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) @@ -512,6 +511,8 @@ (define (guix-build . args) (urls (map (cut string-append <> "/log") (if (assoc-ref opts 'substitutes?) (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. %default-substitute-urls) '()))) (roots (filter-map (match-lambda diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 44ff92655b..e999cce1fd 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -252,8 +252,7 @@ (define %options (show-version-and-exit "guix size"))))) (define %default-options - `((system . ,(%current-system)) - (substitute-urls . ,%default-substitute-urls))) + `((system . ,(%current-system)))) ;;; diff --git a/guix/store.scm b/guix/store.scm index c4e3573711..8413d1f452 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -501,11 +501,11 @@ (define* (set-build-options server (build-cores (current-processor-count)) (use-substitutes? #t) - ;; Client-provided substitute URLs. For - ;; unprivileged clients, these are considered - ;; "untrusted"; for "trusted" users, they override - ;; the daemon's settings. - (substitute-urls %default-substitute-urls)) + ;; Client-provided substitute URLs. If it is #f, + ;; the daemon's settings are used. Otherwise, it + ;; overrides the daemons settings; see 'guix + ;; substitute'. + (substitute-urls #f)) ;; Must be called after `open-connection'. (define socket @@ -533,7 +533,10 @@ (define socket (let ((pairs `(,@(if timeout `(("build-timeout" . ,(number->string timeout))) '()) - ("substitute-urls" . ,(string-join substitute-urls))))) + ,@(if substitute-urls + `(("substitute-urls" + . ,(string-join substitute-urls))) + '())))) (send (string-pairs pairs)))) (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) -- cgit v1.2.3 From fd688c82bf4ee543dbb5f55bf3913668c4bf4483 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Oct 2015 15:53:17 +0100 Subject: ui: Add 'make-regexp*'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Jan Synáček . * guix/ui.scm (make-regexp*): New procedure. * guix/scripts/package.scm (options->installable, guix-package): Use it when processing user-provided regexps. --- guix/scripts/package.scm | 10 +++++----- guix/ui.scm | 11 +++++++++++ 2 files changed, 16 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d8689490b7..adbc4a1828 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -435,14 +435,14 @@ (define (package->manifest-entry* package output) (define upgrade-regexps (filter-map (match-lambda (('upgrade . regexp) - (make-regexp (or regexp ""))) + (make-regexp* (or regexp ""))) (_ #f)) opts)) (define do-not-upgrade-regexps (filter-map (match-lambda (('do-not-upgrade . regexp) - (make-regexp regexp)) + (make-regexp* regexp)) (_ #f)) opts)) @@ -736,7 +736,7 @@ (define (list-generation number) #t) (('list-installed regexp) - (let* ((regexp (and regexp (make-regexp regexp))) + (let* ((regexp (and regexp (make-regexp* regexp))) (manifest (profile-manifest profile)) (installed (manifest-entries manifest))) (leave-on-EPIPE @@ -752,7 +752,7 @@ (define (list-generation number) #t)) (('list-available regexp) - (let* ((regexp (and regexp (make-regexp regexp))) + (let* ((regexp (and regexp (make-regexp* regexp))) (available (fold-packages (lambda (p r) (let ((n (package-name p))) @@ -778,7 +778,7 @@ (define (list-generation number) #t)) (('search regexp) - (let ((regexp (make-regexp regexp regexp/icase))) + (let ((regexp (make-regexp* regexp regexp/icase))) (leave-on-EPIPE (for-each (cute package->recutils <> (current-output-port)) (find-packages-by-description regexp))) diff --git a/guix/ui.scm b/guix/ui.scm index 72208e7de7..312c2a01a1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -61,6 +61,7 @@ (define-module (guix ui) warn-about-load-error show-version-and-exit show-bug-report-information + make-regexp* string->number* size->number show-derivation-outputs @@ -350,6 +351,16 @@ (define (show-bug-report-information) (list (strerror (car errno)) target) (list errno))))))) +(define (make-regexp* regexp . flags) + "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error +nicely." + (catch 'regular-expression-syntax + (lambda () + (apply make-regexp regexp flags)) + (lambda (key proc message . rest) + (leave (_ "'~a' is not a valid regular expression: ~a~%") + regexp message)))) + (define (string->number* str) "Like `string->number', but error out with an error message on failure." (or (string->number str) -- cgit v1.2.3 From 7191adc5cf864d75debcc618937b7a6292491445 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Tue, 27 Oct 2015 21:13:05 +0300 Subject: refresh: Support comma-separated updater types. * guix/scripts/refresh.scm (%options): Handle comma-separated types for '--type' option. (guix-refresh): Adjust accordingly. (show-help): Likewise. * doc/guix.texi (Invoking guix refresh): Document it. --- doc/guix.texi | 6 +++--- guix/scripts/refresh.scm | 18 +++++++++++------- 2 files changed, 14 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 9878b93ddb..4fbe057614 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4276,8 +4276,8 @@ inconvenient. @item --type=@var{updater} @itemx -t @var{updater} -Select only packages handled by @var{updater}. Currently, @var{updater} -may be one of: +Select only packages handled by @var{updater} (may be a comma-separated +list of updaters). Currently, @var{updater} may be one of: @table @code @item gnu @@ -4292,7 +4292,7 @@ For instance, the following commands only checks for updates of Emacs packages hosted at @code{elpa.gnu.org} and updates of CRAN packages: @example -$ guix refresh -t elpa -t cran +$ guix refresh --type=elpa,cran gnu/packages/statistics.scm:819:13: r-testthat would be upgraded from 0.10.0 to 0.11.0 gnu/packages/emacs.scm:856:13: emacs-auctex would be upgraded from 11.88.6 to 11.88.9 @end example diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index a66b3f9ea8..04f6b76edc 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -69,10 +69,13 @@ (define %options arg))))) (option '(#\t "type") #t #f (lambda (opt name arg result) - (alist-cons 'updater (string->symbol arg) result))) + (let* ((not-comma (char-set-complement (char-set #\,))) + (names (map string->symbol + (string-tokenize arg not-comma)))) + (alist-cons 'updaters names result)))) (option '(#\L "list-updaters") #f #f (lambda args - (list-updaters-and-exit))) + (list-updaters-and-exit))) (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) @@ -114,7 +117,8 @@ (define (show-help) -s, --select=SUBSET select all the packages in SUBSET, one of `core' or `non-core'")) (display (_ " - -t, --type=UPDATER restrict to updates from UPDATER--e.g., 'gnu'")) + -t, --type=UPDATER,... restrict to updates from the specified updaters + (e.g., 'gnu')")) (display (_ " -L, --list-updaters list available updaters and exit")) (display (_ " @@ -209,15 +213,15 @@ (define (parse-options) (define (options->updaters opts) ;; Return the list of updaters to use. (match (filter-map (match-lambda - (('updater . name) - (lookup-updater name)) + (('updaters . names) + (map lookup-updater names)) (_ #f)) opts) (() ;; Use the default updaters. %updaters) - (lst - lst))) + (lists + (concatenate lists)))) (define (keep-newest package lst) ;; If a newer version of PACKAGE is already in LST, return LST; otherwise -- cgit v1.2.3 From cc90fbbf39e310a166e356f7019036eb30d4808a Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 25 Oct 2015 22:33:33 -0400 Subject: scripts: environment: Allow mixing regular and ad-hoc packages. This patch changes the --ad-hoc flag to be positional. That is, the packages that appear before --ad-hoc are interpreted as packages whose inputs should be in the environment; the packages that appear after are interpreted as packages to be directly added to the environment. * guix/scripts/environment.scm (tag-package-arg, compact): New procedures. (%options): Tweak the handlers for --load and --expression options. (options/resolve-packages): Preserve package mode tag. (parse-args): Tweak argument handler to use package tagging procedure. (guix-environment): Apply ad-hoc behavior on a per package basis. * tests/guix-environment.sh: Add test. * doc/guix.texi ("invoking guix environment"): Document new behavior of --ad-hoc. --- doc/guix.texi | 20 +++++++++++ guix/scripts/environment.scm | 85 ++++++++++++++++++++++++++------------------ tests/guix-environment.sh | 14 ++++++++ 3 files changed, 85 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 844f9fa75d..6b6e937c6d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4699,6 +4699,20 @@ NumPy: guix environment --ad-hoc python2-numpy python-2.7 -- python @end example +Furthermore, one might want the dependencies of a package and also some +additional packages that are not build-time or runtime dependencies, but +are useful when developing nonetheless. Because of this, the +@code{--ad-hoc} flag is positional. Packages appearing before +@code{--ad-hoc} are interpreted as packages whose dependencies will be +added to the environment. Packages appearing after are interpreted as +packages that will be added to the environment directly. For example, +the following command creates a Guix development environment that +additionally includes Git and strace: + +@example +guix environment guix --ad-hoc git strace +@end example + Sometimes it is desirable to isolate the environment as much as possible, for maximal purity and reproducibility. In particular, when using Guix on a host distro that is not GuixSD, it is desirable to @@ -4759,6 +4773,12 @@ Note that this example implicitly asks for the default output of specific output---e.g., @code{glib:bin} asks for the @code{bin} output of @code{glib} (@pxref{Packages with Multiple Outputs}). +This option may be composed with the default behavior of @command{guix +environment}. Packages appearing before @code{--ad-hoc} are interpreted +as packages whose dependencies will be added to the environment, the +default behavior. Packages appearing after are interpreted as packages +that will be added to the environment directly. + @item --pure Unset existing environment variables when building the new environment. This has the effect of creating an environment in which search paths diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d21a768dc..188838574f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -166,6 +166,16 @@ (define %default-options (max-silent-time . 3600) (verbosity . 0))) +(define (tag-package-arg opts arg) + "Return a two-element list with the form (TAG ARG) that tags ARG with either +'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." + ;; Normally, the transitive inputs to a package are added to an environment, + ;; but the ad-hoc? flag changes the meaning of a package argument such that + ;; the package itself is added to the environment instead. + (if (assoc-ref opts 'ad-hoc?) + `(ad-hoc-package ,arg) + `(package ,arg))) + (define %options ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f @@ -186,10 +196,14 @@ (define %options (alist-cons 'search-paths #t result))) (option '(#\l "load") #t #f (lambda (opt name arg result) - (alist-cons 'load arg result))) + (alist-cons 'load + (tag-package-arg result arg) + result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) - (alist-cons 'expression arg result))) + (alist-cons 'expression + (tag-package-arg result arg) + result))) (option '("ad-hoc") #f #f (lambda (opt name arg result) (alist-cons 'ad-hoc? #t result))) @@ -232,29 +246,34 @@ (define same-key? (cut eq? key <>)) (_ memo))) '() alist)) +(define (compact lst) + "Remove all #f elements from LST." + (filter identity lst)) + (define (options/resolve-packages opts) "Return OPTS with package specification strings replaced by actual packages." - (append-map (match-lambda - (('package . (? string? spec)) - (let-values (((package output) - (specification->package+output spec))) - `((package ,package ,output)))) - (('expression . str) - ;; Add all the outputs of the package STR evaluates to. - (match (read/eval str) - ((? package? package) + (compact + (append-map (match-lambda + (('package mode (? string? spec)) + (let-values (((package output) + (specification->package+output spec))) + (list (list mode package output)))) + (('expression mode str) + ;; Add all the outputs of the package STR evaluates to. + (match (read/eval str) + ((? package? package) + (map (lambda (output) + (list mode package output)) + (package-outputs package))))) + (('load mode file) + ;; Add all the outputs of the package defined in FILE. + (let ((package (load* file (make-user-module '())))) (map (lambda (output) - `(package ,package ,output)) - (package-outputs package))))) - (('load . file) - ;; Add all the outputs of the package defined in FILE. - (let ((package (load* file (make-user-module '())))) - (map (lambda (output) - `(package ,package ,output)) - (package-outputs package)))) - (opt (list opt))) - opts)) + (list mode package output)) + (package-outputs package)))) + (_ '(#f))) + opts))) (define (build-inputs inputs opts) "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION @@ -402,7 +421,7 @@ (define (environment-bash container? bootstrap? system) (define (parse-args args) "Parse the list of command line arguments ARGS." (define (handle-argument arg result) - (alist-cons 'package arg result)) + (alist-cons 'package (tag-package-arg result arg) result)) ;; The '--' token is used to separate the command to run from the rest of ;; the operands. @@ -420,22 +439,20 @@ (define (guix-environment . args) (pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (network? (assoc-ref opts 'network?)) - (ad-hoc? (assoc-ref opts 'ad-hoc?)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) (command (assoc-ref opts 'exec)) - (packages (pick-all (options/resolve-packages opts) 'package)) + (packages (options/resolve-packages opts)) (mappings (pick-all opts 'file-system-mapping)) - (inputs (if ad-hoc? - (append-map (match-lambda - ((package output) - (package+propagated-inputs package - output))) - packages) - (append-map (compose bag-transitive-inputs - package->bag - first) - packages))) + (inputs (delete-duplicates + (append-map (match-lambda + (('ad-hoc-package package output) + (package+propagated-inputs package + output)) + (('package package output) + (bag-transitive-inputs + (package->bag package)))) + packages))) (paths (delete-duplicates (cons $PATH (append-map (match-lambda diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index f91c78a801..49b3b1ccc3 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -97,4 +97,18 @@ then # Make sure the "debug" output is not listed. if grep -E "$make_boot0_debug" "$tmpdir/a"; then false; else true; fi + + # Compute the build environment for the initial GNU Make, but add in the + # bootstrap Guile as an ad-hoc addition. + guix environment -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ + --ad-hoc guile-bootstrap --no-substitutes --search-paths \ + --pure > "$tmpdir/a" + + # Make sure the bootstrap binaries are all listed where they belong. + cat $tmpdir/a + grep -E '^export PATH=.*-bootstrap-binaries-0/bin' "$tmpdir/a" + grep -E '^export PATH=.*-guile-bootstrap-2.0/bin' "$tmpdir/a" + grep -E '^export CPATH=.*-gcc-bootstrap-0/include' "$tmpdir/a" + grep -E '^export CPATH=.*-glibc-bootstrap-0/include' "$tmpdir/a" + grep -E '^export LIBRARY_PATH=.*-glibc-bootstrap-0/lib' "$tmpdir/a" fi -- cgit v1.2.3 From 1c8a81b1af81bdb2fd87efb38004900ad5a77d36 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 8 Jun 2015 09:04:38 -0400 Subject: scripts: system: Add 'container' action. * guix/scripts/system.scm (show-help): Display 'container' action. (system-derivation-for-action, guix-system): Add 'container' case. (perform-action): Skip GRUB config generation when building a container. * doc/guix.texi (Invoking guix system): Document it. --- doc/guix.texi | 21 +++++++++++++++++++++ gnu/system/linux-container.scm | 7 ++++++- guix/scripts/system.scm | 19 +++++++++++++------ 3 files changed, 40 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 236c5973cd..a23d8244ff 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7264,6 +7264,27 @@ using the following command: # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc @end example +@item container +Return a script to run the operating system declared in @var{file} +within a container. Containers are a set of lightweight isolation +mechanisms provided by the kernel Linux-libre. Containers are +substantially less resource-demanding than full virtual machines since +the kernel, shared objects, and other resources can be shared with the +host system; this also means they provide thinner isolation. + +Currently, the script must be run as root in order to support more than +a single user and group. The container shares its store with the host +system. + +As with the @code{vm} action (@pxref{guix system vm}), additional file +systems to be shared between the host and container can be specified +using the @option{--share} and @option{--expose} options: + +@example +guix system container my-config.scm \ + --expose=$HOME --share=$HOME/tmp=/exchange +@end example + @end table @var{options} can contain any of the common build options provided by diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index abe816f483..c2eb773931 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -108,7 +108,12 @@ (define script (setenv "TMPDIR" "/tmp") (setenv "GUIX_NEW_SYSTEM" #$os-drv) (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) - (primitive-load (string-append #$os-drv "/boot")))))) + (primitive-load (string-append #$os-drv "/boot"))) + ;; A range of 65536 uid/gids is used to cover 16 bits worth of + ;; users and groups, which is sufficient for most cases. + ;; + ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= + #:host-uids 65536))) (gexp->script "run-container" script #:modules '((ice-9 match) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d847c75444..499038ffa1 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -34,6 +34,7 @@ (define-module (guix scripts system) #:use-module (gnu build install) #:use-module (gnu system) #:use-module (gnu system file-systems) + #:use-module (gnu system linux-container) #:use-module (gnu system vm) #:use-module (gnu system grub) #:use-module (gnu services) @@ -406,6 +407,8 @@ (define* (system-derivation-for-action os action (case action ((build init reconfigure) (operating-system-derivation os)) + ((container) + (container-script os #:mappings mappings)) ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) @@ -438,10 +441,12 @@ (define println #:full-boot? full-boot? #:mappings mappings)) (grub (package->derivation grub)) - (grub.cfg (operating-system-grub.cfg os - (if (eq? 'init action) - '() - (previous-grub-entries)))) + (grub.cfg (if (eq? 'container action) + (return #f) + (operating-system-grub.cfg os + (if (eq? 'init action) + '() + (previous-grub-entries))))) (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) @@ -523,6 +528,8 @@ (define (show-help) list-generations list the system generations\n")) (display (_ "\ build build the operating system without installing anything\n")) + (display (_ "\ + container build a container that shares the host's store\n")) (display (_ "\ vm build a virtual machine image that shares the host's store\n")) (display (_ "\ @@ -694,7 +701,7 @@ (define (parse-sub-command arg result) (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image disk-image reconfigure init + ((build container vm vm-image disk-image reconfigure init extension-graph dmd-graph list-generations) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -723,7 +730,7 @@ (define (fail) (exit 1)) (case action - ((build vm vm-image disk-image reconfigure) + ((build container vm vm-image disk-image reconfigure) (unless (= count 1) (fail))) ((init) -- cgit v1.2.3 From c9c282cea04ec5a3ee7bd17e6ad8846600220feb Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 30 Oct 2015 21:02:51 -0400 Subject: scripts: environment: Allow lists of packages in expressions. * guix/scripts/environment.scm (options/resolve-packages): Match against lists of packages when evaluating expressions. * tests/guix-environment.sh: Add test. * doc/guix.texi ("invoking guix environment"): Add docs. --- doc/guix.texi | 15 ++++++++++++--- guix/scripts/environment.scm | 24 +++++++++++++++--------- tests/guix-environment.sh | 11 +++++++++++ 3 files changed, 38 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a164608b73..84f194b14b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4730,7 +4730,8 @@ The available options are summarized below. @table @code @item --expression=@var{expr} @itemx -e @var{expr} -Create an environment for the package that @var{expr} evaluates to. +Create an environment for the package or list of packages that +@var{expr} evaluates to. For example, running: @@ -4741,10 +4742,18 @@ guix environment -e '(@@ (gnu packages maths) petsc-openmpi)' starts a shell with the environment for this specific variant of the PETSc package. +Running: + +@example +guix environment --ad-hoc -e '(@ (gnu) %base-packages)' +@end example + +starts a shell with all the GuixSD base packages available. + @item --load=@var{file} @itemx -l @var{file} -Create an environment for the package that the code within @var{file} -evaluates to. +Create an environment for the package or list of packages that the code +within @var{file} evaluates to. As an example, @var{file} might contain a definition like this (@pxref{Defining Packages}): diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 188838574f..f9ab9a483f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -253,6 +253,18 @@ (define (compact lst) (define (options/resolve-packages opts) "Return OPTS with package specification strings replaced by actual packages." + (define (package->outputs package mode) + (map (lambda (output) + (list mode package output)) + (package-outputs package))) + + (define (packages->outputs packages mode) + (match packages + ((? package? package) + (package->outputs package mode)) + (((? package? packages) ...) + (append-map (cut package->outputs <> mode) packages)))) + (compact (append-map (match-lambda (('package mode (? string? spec)) @@ -261,17 +273,11 @@ (define (options/resolve-packages opts) (list (list mode package output)))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. - (match (read/eval str) - ((? package? package) - (map (lambda (output) - (list mode package output)) - (package-outputs package))))) + (packages->outputs (read/eval str) mode)) (('load mode file) ;; Add all the outputs of the package defined in FILE. - (let ((package (load* file (make-user-module '())))) - (map (lambda (output) - (list mode package output)) - (package-outputs package)))) + (let ((module (make-user-module '()))) + (packages->outputs (load* file module) mode))) (_ '(#f))) opts))) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 49b3b1ccc3..f7b0259e1b 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -111,4 +111,15 @@ then grep -E '^export CPATH=.*-gcc-bootstrap-0/include' "$tmpdir/a" grep -E '^export CPATH=.*-glibc-bootstrap-0/include' "$tmpdir/a" grep -E '^export LIBRARY_PATH=.*-glibc-bootstrap-0/lib' "$tmpdir/a" + + # Make sure a package list can be used with -e. + expr_list_test_code=" +(list (@@ (gnu packages commencement) gnu-make-boot0) + (@ (gnu packages bootstrap) %bootstrap-guile))" + + guix environment --ad-hoc --no-substitutes --search-paths --pure \ + -e "$expr_list_test_code" > "$tmpdir/a" + + grep -E '^export PATH=.*-make-boot0-4.1/bin' "$tmpdir/a" + grep -E '^export PATH=.*-guile-bootstrap-2.0/bin' "$tmpdir/a" fi -- cgit v1.2.3 From fbd213a83ffc80c432e0c62868e56c020729a49f Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Sat, 31 Oct 2015 22:59:45 +0300 Subject: guix system: Fix typo in --help message. * guix/scripts/system.scm (show-help): Align 'container' the same way as other actions. --- guix/scripts/system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 499038ffa1..7be734785a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -529,7 +529,7 @@ (define (show-help) (display (_ "\ build build the operating system without installing anything\n")) (display (_ "\ - container build a container that shares the host's store\n")) + container build a container that shares the host's store\n")) (display (_ "\ vm build a virtual machine image that shares the host's store\n")) (display (_ "\ -- cgit v1.2.3 From 32efa254a80672bdf5199b8e200764615a3cf68b Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 1 Jul 2015 20:32:07 -0400 Subject: scripts: Add 'container' subcommand. * guix/scripts/container.scm: New file. * guix/scripts/container/exec.scm: New file. * po/guix/POTFILES.in: Add them. * Makefile.am (MODULES): Add them. * doc/guix.texi (Invoking guix container): New section. --- Makefile.am | 2 + doc/guix.texi | 56 +++++++++++++++++++++++++++ guix/scripts/container.scm | 63 ++++++++++++++++++++++++++++++ guix/scripts/container/exec.scm | 86 +++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 2 + 5 files changed, 209 insertions(+) create mode 100644 guix/scripts/container.scm create mode 100644 guix/scripts/container/exec.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index b2ee3245b3..67d483bfb0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -128,6 +128,8 @@ MODULES = \ guix/scripts/edit.scm \ guix/scripts/size.scm \ guix/scripts/graph.scm \ + guix/scripts/container.scm \ + guix/scripts/container/exec.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/doc/guix.texi b/doc/guix.texi index 474a56e6db..431db5d75f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -144,6 +144,7 @@ Utilities * Invoking guix environment:: Setting up development environments. * Invoking guix publish:: Sharing substitutes. * Invoking guix challenge:: Challenging substitute servers. +* Invoking guix container:: Process isolation. GNU Distribution @@ -3583,6 +3584,7 @@ programming interface of Guix in a convenient way. * Invoking guix environment:: Setting up development environments. * Invoking guix publish:: Sharing substitutes. * Invoking guix challenge:: Challenging substitute servers. +* Invoking guix container:: Process isolation. @end menu @node Invoking guix build @@ -5036,6 +5038,60 @@ URLs to compare to. @end table +@node Invoking guix container +@section Invoking @command{guix container} +@cindex container + +@quotation Note +As of version @value{VERSION}, this tool is experimental. The interface +is subject to radical change in the future. +@end quotation + +The purpose of @command{guix container} is to manipulate processes +running within an isolated environment, commonly known as a +``container,'' typically created by the @command{guix environment} +(@pxref{Invoking guix environment}) and @command{guix system container} +(@pxref{Invoking guix system}) commands. + +The general syntax is: + +@example +guix container @var{action} @var{options}@dots{} +@end example + +@var{action} specifies the operation to perform with a container, and +@var{options} specifies the context-specific arguments for the action. + +The following actions are available: + +@table @code +@item exec +Execute a command within the context of a running container. + +The syntax is: + +@example +guix container exec @var{pid} @var{program} @var{arguments}@dots{} +@end example + +@var{pid} specifies the process ID of the running container. +@var{program} specifies an executable file name within the container's +root file system. @var{arguments} are the additional options that will +be passed to @var{program}. + +The following command launches an interactive login shell inside a +GuixSD container, started by @command{guix system container}, and whose +process ID is 9001: + +@example +guix container exec 9001 /run/current-system/profile/bin/bash --login +@end example + +Note that the @var{pid} cannot be the parent process of a container. It +must be the container's PID 1 or one of its child processes. + +@end table + @c ********************************************************************* @node GNU Distribution @chapter GNU Distribution diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm new file mode 100644 index 0000000000..cd9f345b68 --- /dev/null +++ b/guix/scripts/container.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson +;;; +;;; 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 scripts container) + #:use-module (ice-9 match) + #:use-module (guix ui) + #:export (guix-container)) + +(define (show-help) + (display (_ "Usage: guix container ACTION ARGS... +Build and manipulate Linux containers.\n")) + (newline) + (display (_ "The valid values for ACTION are:\n")) + (newline) + (display (_ "\ + exec execute a command inside of an existing container\n")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %actions '("exec")) + +(define (resolve-action name) + (let ((module (resolve-interface + `(guix scripts container ,(string->symbol name)))) + (proc (string->symbol (string-append "guix-container-" name)))) + (module-ref module proc))) + +(define (guix-container . args) + (with-error-handling + (match args + (() + (format (current-error-port) + (_ "guix container: missing action~%"))) + ((or ("-h") ("--help")) + (show-help) + (exit 0)) + (("--version") + (show-version-and-exit "guix container")) + ((action args ...) + (if (member action %actions) + (apply (resolve-action action) args) + (format (current-error-port) + (_ "guix container: invalid action~%"))))))) diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm new file mode 100644 index 0000000000..b842fd38aa --- /dev/null +++ b/guix/scripts/container/exec.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson +;;; +;;; 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 scripts container exec) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (gnu build linux-container) + #:export (guix-container-exec)) + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix container exec"))))) + +(define (show-help) + (display (_ "Usage: guix container exec PID COMMAND [ARGS...] +Execute COMMMAND within the container process PID.\n")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (partition-args args) + "Split ARGS into two lists; one containing the arguments for this program, +and the other containing arguments for the command to be executed." + (break (lambda (arg) + ;; Split after the pid argument. + (not (false-if-exception (string->number arg)))) + args)) + +(define (guix-container-exec . args) + (define (handle-argument arg result) + (if (assoc-ref result 'pid) + (leave (_ "~a: extraneous argument~%") arg) + (alist-cons 'pid (string->number* arg) result))) + + (with-error-handling + (let-values (((args command) (partition-args args))) + (let* ((opts (parse-command-line args %options '(()) + #:argument-handler + handle-argument)) + (pid (assoc-ref opts 'pid))) + + (unless pid + (leave (_ "no pid specified~%"))) + + (when (null? command) + (leave (_ "no command specified~%"))) + + (unless (file-exists? (string-append "/proc/" (number->string pid))) + (leave (_ "no such process ~d~%") pid)) + + (let ((result (container-excursion pid + (lambda () + (match command + ((program . program-args) + (apply execlp program program program-args))))))) + (unless (zero? result) + (leave (_ "exec failed with status ~d~%") result))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 41cf9ee0f4..bf65416638 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -25,6 +25,8 @@ guix/scripts/size.scm guix/scripts/graph.scm guix/scripts/challenge.scm guix/gnu-maintenance.scm +guix/scripts/container.scm +guix/scripts/container/exec.scm guix/upstream.scm guix/ui.scm guix/http-client.scm -- cgit v1.2.3 From 6407ce8ea1b67024e50273b7d6a1773a16a42322 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Wed, 28 Oct 2015 21:11:36 +0300 Subject: emacs: Add completions for '--type' option of 'refresh' popup. * guix/scripts/refresh.scm: Export '%updaters'. * emacs/guix-main.scm (refresh-updater-names): New procedure. * emacs/guix-base.el (guix-refresh-updater-names): New function. * emacs/guix-read.el (guix-read-refresh-updater-names, guix-read-refresh-updater-names-string): New functions. * emacs/guix-command.el (guix-command-improve-refresh-argument): Use 'guix-read-refresh-updater-names-string'. --- emacs/guix-base.el | 4 ++++ emacs/guix-command.el | 1 + emacs/guix-main.scm | 5 +++++ emacs/guix-read.el | 6 ++++++ guix/scripts/refresh.scm | 3 ++- 5 files changed, 18 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/emacs/guix-base.el b/emacs/guix-base.el index 2e99c545f0..14ea3d4458 100644 --- a/emacs/guix-base.el +++ b/emacs/guix-base.el @@ -186,6 +186,10 @@ For the meaning of location, see `guix-find-location'." "Return a list of names of available graph node types." (guix-eval-read (guix-make-guile-expression 'graph-type-names))) +(guix-memoized-defun guix-refresh-updater-names () + "Return a list of names of available refresh updater types." + (guix-eval-read (guix-make-guile-expression 'refresh-updater-names))) + (guix-memoized-defun guix-lint-checker-names () "Return a list of names of available lint checkers." (guix-eval-read (guix-make-guile-expression 'lint-checker-names))) diff --git a/emacs/guix-command.el b/emacs/guix-command.el index 36ce7bcb09..f8a6df7c6a 100644 --- a/emacs/guix-command.el +++ b/emacs/guix-command.el @@ -241,6 +241,7 @@ to be modified." (guix-command-define-argument-improver guix-command-improve-refresh-argument '(("--select" :fun guix-read-refresh-subset) + ("--type" :fun guix-read-refresh-updater-names-string) ("--key-server" :char ?S))) (guix-command-define-argument-improver diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm index e29a0a0acc..9eac5185b7 100644 --- a/emacs/guix-main.scm +++ b/emacs/guix-main.scm @@ -991,6 +991,11 @@ (define (graph-type-names) "Return a list of names of available graph node types." (map node-type-name %node-types)) +(define (refresh-updater-names) + "Return a list of names of available refresh updater types." + (map (@ (guix upstream) upstream-updater-name) + (@ (guix scripts refresh) %updaters))) + (define (lint-checker-names) "Return a list of names of available lint checkers." (map (lambda (checker) diff --git a/emacs/guix-read.el b/emacs/guix-read.el index 5a7201c3aa..e60af9c2f7 100644 --- a/emacs/guix-read.el +++ b/emacs/guix-read.el @@ -136,6 +136,12 @@ keywords are available: :single-reader guix-read-refresh-subset :single-prompt "Refresh subset: ") +(guix-define-readers + :completions-getter guix-refresh-updater-names + :multiple-reader guix-read-refresh-updater-names + :multiple-prompt "Refresh updater,s: " + :multiple-separator ",") + (guix-define-readers :completions-var guix-help-key-policies :single-reader guix-read-key-policy diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 04f6b76edc..0df4121d0a 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -42,7 +42,8 @@ (define-module (guix scripts refresh) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (rnrs io ports) - #:export (guix-refresh)) + #:export (guix-refresh + %updaters)) ;;; -- cgit v1.2.3 From 7241c2fae6a5c4c47432443fc3bff697f4617be3 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 1 Nov 2015 18:34:53 -0500 Subject: scripts: environment: Ignore user shell when spawning container. * guix/scripts/environment.scm (%default-options): Remove 'exec' association. (guix-environment): If the user didn't specify a command, use the default shell, or use /bin/sh when a container is requested. --- guix/scripts/environment.scm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index f9ab9a483f..45b54a9297 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -160,8 +160,7 @@ (define (show-help) (define %default-options ;; Default to opening a new shell. - `((exec . (,%default-shell)) - (system . ,(%current-system)) + `((system . ,(%current-system)) (substitutes? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -447,7 +446,14 @@ (define (guix-environment . args) (network? (assoc-ref opts 'network?)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) - (command (assoc-ref opts 'exec)) + (command (or (assoc-ref opts 'exec) + ;; Spawn a shell if the user didn't specify + ;; anything in particular. + (if container? + ;; The user's shell is likely not available + ;; within the container. + '("/bin/sh") + (list %default-shell)))) (packages (options/resolve-packages opts)) (mappings (pick-all opts 'file-system-mapping)) (inputs (delete-duplicates -- cgit v1.2.3 From d62e201cfd0f1e48c14586489d0e2b80ce943d4f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 Nov 2015 18:44:17 +0100 Subject: services: Add 'system-service-type'. * gnu/services.scm (system-derivation): New procedure. (system-service-type): New variable. (boot-script-entry): New procedure. (boot-service-type): Extend SYSTEM-SERVICE-TYPE. (etc-entry): New procedure. (etc-service-type): Extend SYSTEM-SERVICE-TYPE. (fold-services): Change default #:target-type to SYSTEM-SERVICE-TYPE. * gnu/system.scm (operating-system-directory-base-entries): New procedure. (essential-services): Use it. Add an instance of SYSTEM-SERVICE-TYPE. (operating-system-boot-script): Pass #:target-type to 'fold-services'. (operating-system-derivation): Rewrite in terms of 'fold-services'. * gnu/system/linux-container.scm (system-container): Remove. (container-script): Use 'operating-system-derivation'. * guix/scripts/system.scm (export-extension-graph): Replace BOOT-SERVICE-TYPE by SYSTEM-SERVICE-TYPE. * doc/images/service-graph.dot: Add 'system' node and edges. * doc/guix.texi (Service Composition): Mention SYSTEM-SERVICE-TYPE. (Service Reference): Document it. Update 'fold-services' documentation. --- doc/guix.texi | 26 +++++++++++++------- doc/images/service-graph.dot | 5 +++- gnu/services.scm | 51 +++++++++++++++++++++++++++++++++------ gnu/system.scm | 54 ++++++++++++++++++++++++------------------ gnu/system/linux-container.scm | 18 +++----------- guix/scripts/system.scm | 6 ++--- 6 files changed, 103 insertions(+), 57 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 74e0977db5..6ab98deef3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7589,8 +7589,11 @@ as arrows, a typical system might provide something like this: @image{images/service-graph,,5in,Typical service extension graph.} -At the bottom, we see the @dfn{boot service}, which produces the boot -script that is executed at boot time from the initial RAM disk. +@cindex system service +At the bottom, we see the @dfn{system service}, which produces the +directory containing everything to run and boot the system, as returned +by the @command{guix system build} command. @xref{Service Reference}, +to learn about the other service types shown here. @xref{system-extension-graph, the @command{guix system extension-graph} command}, for information on how to generate this representation for a particular operating system definition. @@ -7853,12 +7856,14 @@ Return true if @var{obj} is a service extension. At the core of the service abstraction lies the @code{fold-services} procedure, which is responsible for ``compiling'' a list of services -down to a single boot script. In essence, it propagates service -extensions down the service graph, updating each node parameters on the -way, until it reaches the root node. +down to a single directory that contains everything needed to boot and +run the system---the directory shown by the @command{guix system build} +command (@pxref{Invoking guix system}). In essence, it propagates +service extensions down the service graph, updating each node parameters +on the way, until it reaches the root node. @deffn {Scheme Procedure} fold-services @var{services} @ - [#:target-type @var{boot-service-type}] + [#:target-type @var{system-service-type}] Fold @var{services} by propagating their extensions down to the root of type @var{target-type}; return the root service adjusted accordingly. @end deffn @@ -7866,9 +7871,14 @@ type @var{target-type}; return the root service adjusted accordingly. Lastly, the @code{(gnu services)} module also defines several essential service types, some of which are listed below. +@defvr {Scheme Variable} system-service-type +This is the root of the service graph. It produces the system directory +as returned by the @command{guix system build} command. +@end defvr + @defvr {Scheme Variable} boot-service-type -The type of the ``boot service'', which is the root of the service -graph. +The type of the ``boot service'', which produces the @dfn{boot script}. +The boot script is what the initial RAM disk runs when booting. @end defvr @defvr {Scheme Variable} etc-service-type diff --git a/doc/images/service-graph.dot b/doc/images/service-graph.dot index 3397b878e9..04f231bb09 100644 --- a/doc/images/service-graph.dot +++ b/doc/images/service-graph.dot @@ -4,7 +4,8 @@ digraph "Service Type Dependencies" { etc [shape = box, fontname = Helvetica]; accounts [shape = box, fontname = Helvetica]; activation [shape = box, fontname = Helvetica]; - boot [shape = house, fontname = Helvetica]; + boot [shape = box, fontname = Helvetica]; + system [shape = house, fontname = Helvetica]; lshd -> dmd; lshd -> pam; udev -> dmd; @@ -32,4 +33,6 @@ digraph "Service Type Dependencies" { guix -> dmd; guix -> activation; guix -> accounts; + boot -> system; + etc -> system; } diff --git a/gnu/services.scm b/gnu/services.scm index ecf3532e52..8a66d453df 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -60,6 +60,7 @@ (define-module (gnu services) ambiguous-target-service-error-service ambiguous-target-service-error-target-type + system-service-type boot-service-type activation-service-type activation-service->script @@ -89,9 +90,10 @@ (define-module (gnu services) ;;; by providing one procedure to compose extensions, and one procedure to ;;; extend itself. ;;; -;;; A notable service type is BOOT-SERVICE-TYPE, which has a single instance, -;;; %BOOT-SERVICE. %BOOT-SERVICE constitutes the root of the service DAG. It -;;; produces the boot script that the initrd loads. +;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single +;;; instance, which is the root of the service DAG. Its value is the +;;; derivation that produces the 'system' directory as returned by +;;; 'operating-system-derivation'. ;;; ;;; The 'fold-services' procedure can be passed a list of procedures, which it ;;; "folds" by propagating extensions down the graph; it returns the root @@ -182,6 +184,25 @@ (define-syntax modify-services ;;; Core services. ;;; +(define (system-derivation mentries mextensions) + "Return as a monadic value the derivation of the 'system' directory +containing the given entries." + (mlet %store-monad ((entries mentries) + (extensions (sequence %store-monad mextensions))) + (lower-object + (file-union "system" + (append entries (concatenate extensions)))))) + +(define system-service-type + ;; This is the ultimate service type, the root of the service DAG. The + ;; service of this type is extended by monadic name/item pairs. These items + ;; end up in the "system directory" as returned by + ;; 'operating-system-derivation'. + (service-type (name 'system) + (extensions '()) + (compose identity) + (extend system-derivation))) + (define (compute-boot-script _ mexps) (mlet %store-monad ((gexps (sequence %store-monad mexps))) (gexp->file "boot" @@ -203,17 +224,25 @@ (define (compute-boot-script _ mexps) ;; Activate the system and spawn dmd. #$@gexps)))) +(define (boot-script-entry mboot) + "Return, as a monadic value, an entry for the boot script in the system +directory." + (mlet %store-monad ((boot mboot)) + (return `(("boot" ,boot))))) + (define boot-service-type ;; The service of this type is extended by being passed gexps as monadic ;; values. It aggregates them in a single script, as a monadic value, which ;; becomes its 'parameters'. It is the only service that extends nothing. (service-type (name 'boot) - (extensions '()) + (extensions + (list (service-extension system-service-type + boot-script-entry))) (compose append) (extend compute-boot-script))) (define %boot-service - ;; This is the ultimate service, the root of the service DAG. + ;; The service that produces the boot script. (service boot-service-type #t)) (define* (file-union name files) ;FIXME: Factorize. @@ -351,6 +380,12 @@ (define (etc-directory service) (define (files->etc-directory files) (file-union "etc" files)) +(define (etc-entry files) + "Return an entry for the /etc directory consisting of FILES in the system +directory." + (with-monad %store-monad + (return `(("etc" ,(files->etc-directory files)))))) + (define etc-service-type (service-type (name 'etc) (extensions @@ -359,7 +394,8 @@ (define etc-service-type (lambda (files) (let ((etc (files->etc-directory files))) - #~(activate-etc #$etc)))))) + #~(activate-etc #$etc)))) + (service-extension system-service-type etc-entry))) (compose concatenate) (extend append))) @@ -450,7 +486,8 @@ (define (add-edge extension edges) (lambda (node) (reverse (vhash-foldq* cons '() node edges))))) -(define* (fold-services services #:key (target-type boot-service-type)) +(define* (fold-services services + #:key (target-type system-service-type)) "Fold SERVICES by propagating their extensions down to the root of type TARGET-TYPE; return the root service adjusted accordingly." (define dependents diff --git a/gnu/system.scm b/gnu/system.scm index 8fed857b39..c26d27028b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -254,6 +254,24 @@ (define (swap-services os) "Return the list of swap services for OS." (map swap-service (operating-system-swap-devices os))) +(define* (operating-system-directory-base-entries os #:key container?) + "Return the basic entries of the 'system' directory of OS for use as the +value of the SYSTEM-SERVICE-TYPE service." + (mlet* %store-monad ((profile (operating-system-profile os)) + (locale (operating-system-locale-directory os))) + (if container? + (return `(("profile" ,profile) + ("locale" ,locale))) + (mlet %store-monad + ((kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os)) + (params (operating-system-parameters-file os))) + (return `(("kernel" ,kernel) + ("parameters" ,params) + ("initrd" ,initrd) + ("profile" ,profile) + ("locale" ,locale))))))) ;used by libc + (define* (essential-services os #:key container?) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level @@ -269,8 +287,11 @@ (define known-fs (swaps (swap-services os)) (procs (user-processes-service (map service-parameters other-fs))) - (host-name (host-name-service (operating-system-host-name os)))) - (cons* %boot-service + (host-name (host-name-service (operating-system-host-name os))) + (entries (operating-system-directory-base-entries + os #:container? container?))) + (cons* (service system-service-type entries) + %boot-service ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs ;; dmd comes last in the boot script (XXX). @@ -607,10 +628,17 @@ (define* (operating-system-boot-script os #:key container?) we're running in the final root. When CONTAINER? is true, skip all hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) - (boot (fold-services services))) + (boot (fold-services services #:target-type boot-service-type))) ;; BOOT is the script as a monadic value. (service-parameters boot))) +(define* (operating-system-derivation os #:key container?) + "Return a derivation that builds OS." + (let* ((services (operating-system-services os #:container? container?)) + (system (fold-services services))) + ;; SYSTEM contains the derivation as a monadic value. + (service-parameters system))) + (define (operating-system-root-file-system os) "Return the root file system of OS." (find (match-lambda @@ -693,24 +721,4 @@ (define (operating-system-parameters-file os) #$(operating-system-kernel-arguments os)) (initrd #$initrd))))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." - (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc -> (operating-system-etc-directory os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd (operating-system-initrd-file os)) - (locale (operating-system-locale-directory os)) - (params (operating-system-parameters-file os))) - (lower-object - (file-union "system" - `(("boot" ,#~#$boot) - ("kernel" ,#~#$kernel) - ("parameters" ,#~#$params) - ("initrd" ,initrd) - ("profile" ,#~#$profile) - ("locale" ,#~#$locale) ;used by libc - ("etc" ,#~#$etc)))))) - ;;; system.scm ends here diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index c2eb773931..4f38c5cb0a 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -47,20 +47,6 @@ (define (mapping->file-system mapping) (check? #f) (create-mount-point? #t))))) -(define (system-container os) - "Return a derivation that builds OS as a Linux container." - (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc -> (operating-system-etc-directory os)) - (boot (operating-system-boot-script os #:container? #t)) - (locale (operating-system-locale-directory os))) - (lower-object - (file-union "system-container" - `(("boot" ,#~#$boot) - ("profile" ,#~#$profile) - ("locale" ,#~#$locale) - ("etc" ,#~#$etc)))))) - (define (containerized-operating-system os mappings) "Return an operating system based on OS for use in a Linux container environment. MAPPINGS is a list of to realize in the @@ -95,7 +81,9 @@ (define* (container-script os #:key (mappings '())) (operating-system-file-systems os))) (specs (map file-system->spec file-systems))) - (mlet* %store-monad ((os-drv (system-container os))) + (mlet* %store-monad ((os-drv (operating-system-derivation + os + #:container? #t))) (define script #~(begin diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7be734785a..7a8a751df9 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -491,10 +491,10 @@ (define println (define (export-extension-graph os port) "Export the service extension graph of OS to PORT." (let* ((services (operating-system-services os)) - (boot (find (lambda (service) - (eq? (service-kind service) boot-service-type)) + (system (find (lambda (service) + (eq? (service-kind service) system-service-type)) services))) - (export-graph (list boot) (current-output-port) + (export-graph (list system) (current-output-port) #:node-type (service-node-type services) #:reverse-edges? #t))) -- cgit v1.2.3 From a70436183aeb6a861cc43e297b5a33b777dfe1b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 Nov 2015 22:44:17 +0100 Subject: guix system: Always build grub.cfg for 'init' and 'reconfigure'. Fixes . Reported by Germano Gabbianelli and Mark H Weaver . * guix/scripts/system.scm (perform-action): Always add GRUB.CFG to DRVS for 'init' and 'reconfigure'. Co-authored-by: Mark H Weaver --- guix/scripts/system.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7a8a751df9..0d54d453db 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -447,8 +447,14 @@ (define println (if (eq? 'init action) '() (previous-grub-entries))))) - (drvs -> (if (and grub? (memq action '(init reconfigure))) - (list sys grub grub.cfg) + + ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if + ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC + ;; root. See . + (drvs -> (if (memq action '(init reconfigure)) + (if grub? + (list sys grub.cfg grub) + (list sys grub.cfg)) (list sys))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) -- cgit v1.2.3 From 3195e19de2f4360bdde12fccb1821dc444c95807 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Nov 2015 00:59:28 +0100 Subject: import: gnu: Update to the (guix upstream) API. This is a followup to 0a7c5a0. * guix/import/gnu.scm (preferred-archive-type): Use 'upstream-source-archive-types' instead of 'gnu-release-archive-types'. (gnu-package->sexp): Use 'upstream-source-urls' et al. Update call to 'download-tarball'. (gnu->guix-package): Use instead of . * guix/upstream.scm (upstream-source-archive-types): Export. --- guix/import/gnu.scm | 30 ++++++++++++++++++++---------- guix/upstream.scm | 1 + 2 files changed, 21 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 7160fcf7ba..834f0ae5cf 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,11 +23,13 @@ (define-module (guix import gnu) #:use-module (guix store) #:use-module (guix hash) #:use-module (guix base32) + #:use-module (guix upstream) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (web uri) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (gnu->guix-package)) @@ -47,7 +49,7 @@ (define (qualified-url url) (define (preferred-archive-type release) "Return the preferred type of archive for downloading RELEASE." - (find (cute member <> (gnu-release-archive-types release)) + (find (cute member <> (upstream-source-archive-types release)) '("xz" "lz" "bz2" "tbz2" "gz" "tgz" "Z"))) (define* (gnu-package->sexp package release @@ -60,21 +62,29 @@ (define name (define url-base ;; XXX: We assume that RELEASE's directory starts with "/gnu". - (string-append "mirror:/" (gnu-release-directory release) + (string-append "mirror:/" + (match (upstream-source-urls release) + ((url rest ...) + (dirname (uri-path (string->uri url))))) "/" name "-")) (define archive-type (preferred-archive-type release)) + (define url + (find (cut string-suffix? archive-type <>) + (upstream-source-urls release))) + + (define sig-url + (find (cute string-suffix? (string-append archive-type ".sig") <>) + (upstream-source-signature-urls release))) + (let ((tarball (with-store store - (download-tarball store name - (gnu-release-directory release) - (gnu-release-version release) - #:archive-type archive-type + (download-tarball store url sig-url #:key-download key-download)))) `(package (name ,name) - (version ,(gnu-release-version release)) + (version ,(upstream-source-version release)) (source (origin (method url-fetch) (uri (string-append ,url-base version @@ -95,8 +105,8 @@ (define* (gnu->guix-package name KEY-DOWNLOAD as the OpenPGP key download policy (see 'download-tarball' for details.)" (match (latest-release name) - ((? gnu-release? release) - (let ((version (gnu-release-version release))) + ((? upstream-source? release) + (let ((version (upstream-source-version release))) (match (find-packages (regexp-quote name)) ((info . _) (gnu-package->sexp info release #:key-download key-download)) diff --git a/guix/upstream.scm b/guix/upstream.scm index 219ae0568c..12eed3f2b4 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -40,6 +40,7 @@ (define-module (guix upstream) upstream-source-version upstream-source-urls upstream-source-signature-urls + upstream-source-archive-types coalesce-sources -- cgit v1.2.3 From 00bfa7ea25b4612d730b057308b304d0131bee03 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 3 Nov 2015 09:02:10 -0500 Subject: scripts: environment: Display friendly container error messages. * guix/scripts/environment.scm (assert-container-features): New procedure. (guix-environment): Use it. --- guix/scripts/environment.scm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 45b54a9297..97410f4e09 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -437,6 +437,21 @@ (define (handle-argument arg result) opts (alist-cons 'exec command opts))))) +(define (assert-container-features) + "Check if containers can be created and exit with an informative error +message if any test fails." + (unless (user-namespace-supported?) + (report-error (_ "cannot create container: user namespaces unavailable\n")) + (leave (_ "is your kernel version < 3.10?\n"))) + + (unless (unprivileged-user-namespace-supported?) + (report-error (_ "cannot create container: unprivileged user cannot create user namespaces\n")) + (leave (_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n"))) + + (unless (setgroups-supported?) + (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) + (leave (_ "is your kernel version < 3.19?\n")))) + ;; Entry point. (define (guix-environment . args) (with-error-handling @@ -474,6 +489,9 @@ (define (guix-environment . args) '())) inputs)) eq?))) + + (when container? (assert-container-features)) + (with-store store (run-with-store store (mlet* %store-monad ((inputs (lower-inputs -- cgit v1.2.3 From 3009334e3b3c148d7a36c76952fbb32addfa2c07 Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Sat, 10 Oct 2015 22:50:34 +0200 Subject: guix: Add a "pypi-uri" helper method. * guix/download.scm (mirrors): New "pypi" mirror. * guix/build-system/python.scm (pypi-uri): New method. --- guix/build-system/python.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index aeb04c83a4..1a5d9df473 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -31,7 +31,8 @@ (define-module (guix build-system python) #:export (%python-build-system-modules package-with-python2 python-build - python-build-system)) + python-build-system + pypi-uri)) ;; Commentary: ;; @@ -40,6 +41,13 @@ (define-module (guix build-system python) ;; ;; Code: +(define (pypi-uri name version) + "Return a URI string for the Python package hosted on the Python Package +Index (PyPI) corresponding to NAME and VERSION." + (string-append "https://pypi.python.org/packages/source/" + (string-take name 1) "/" name "/" + name "-" version ".tar.gz")) + (define %python-build-system-modules ;; Build-side modules imported by default. `((guix build python-build-system) -- cgit v1.2.3 From d8bdd38201328b95d849dc95073f842db6eb3b8d Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Mon, 12 Oct 2015 01:03:25 +0200 Subject: import: pypi: Use "pypi-uri" instead of building the URL manually. * guix/import/pypi.scm (make-pypi-sexp): Use "pypi-uri". * tests/pypi.scm: Update the tests accordingly. --- guix/import/pypi.scm | 2 +- tests/pypi.scm | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index d04a68524d..647ef615e0 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -165,7 +165,7 @@ (define (make-pypi-sexp name version source-url home-page synopsis (version ,version) (source (origin (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) + (uri (pypi-uri ,name version)) (sha256 (base32 ,(guix-hash-url temp))))) diff --git a/tests/pypi.scm b/tests/pypi.scm index c772474b82..960b8cd32a 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -84,8 +84,7 @@ (define test-requirements ('version "1.0.0") ('source ('origin ('method 'url-fetch) - ('uri ('string-append "https://example.com/foo-" - 'version ".tar.gz")) + ('uri (pypi-uri "foo" version)) ('sha256 ('base32 (? string? hash))))) -- cgit v1.2.3 From bab020d7ca50e4153cf24832d119389a37fa8f63 Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Tue, 3 Nov 2015 22:38:49 +0100 Subject: import: pypi: add updater * guix/import/pypi.scm (guix-package->pypi-name, latest-release): New procedures. (%pypi-updater): New variable. * guix/scripts/refresh.scm (%updaters): Add %PYPI-UPDATER. * doc/guix.texi (Invoking guix refresh): Mention PyPI --- doc/guix.texi | 2 ++ guix/import/pypi.scm | 50 +++++++++++++++++++++++++++++++++++++++++++++++- guix/scripts/refresh.scm | 4 +++- 3 files changed, 54 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 996192c0ea..23f9c3c0a9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4291,6 +4291,8 @@ the updater for GNU packages; the updater for @uref{http://elpa.gnu.org/, ELPA} packages; @item cran the updater fro @uref{http://cran.r-project.org/, CRAN} packages. +@item pypi +the updater fro @uref{https://pypi.python.org, PyPI} packages. @end table For instance, the following commands only checks for updates of Emacs diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 647ef615e0..f1988a7186 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -30,12 +30,16 @@ (define-module (guix import pypi) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix import utils) + #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) #:use-module (guix packages) + #:use-module (guix upstream) #:use-module (guix licenses) #:use-module (guix build-system python) + #:use-module (gnu packages) #:use-module (gnu packages python) - #:export (pypi->guix-package)) + #:export (pypi->guix-package + %pypi-updater)) (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, @@ -60,6 +64,16 @@ (define (python->package-name name) (snake-case name) (string-append "python-" (snake-case name)))) +(define (guix-package->pypi-name package) + "Given a Python PACKAGE built from pypi.python.org, return the name of the +package on PyPI." + (let ((source-url (and=> (package-source package) origin-uri))) + ;; The URL has the form: + ;; 'https://pypi.python.org/packages/source/' + + ;; first letter of the package name + + ;; '/' + package name + '/' + ... + (substring source-url 42 (string-rindex source-url #\/)))) + (define (maybe-inputs package-inputs) "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a package definition." @@ -190,3 +204,37 @@ (define (pypi->guix-package package-name) (license (string->license (assoc-ref* package "info" "license")))) (make-pypi-sexp name version release home-page synopsis description license))))) + +(define (pypi-package? package) + "Return true if PACKAGE is a Python package from PyPI." + + (define (pypi-url? url) + (string-prefix? "https://pypi.python.org/" url)) + + (let ((source-url (and=> (package-source package) origin-uri)) + (fetch-method (and=> (package-source package) origin-method))) + (and (eq? fetch-method download:url-fetch) + (match source-url + ((? string?) + (pypi-url? source-url)) + ((source-url ...) + (any pypi-url? source-url)))))) + +(define (latest-release guix-package) + "Return an for the latest release of GUIX-PACKAGE." + (let* ((pypi-name (guix-package->pypi-name + (specification->package guix-package))) + (metadata (pypi-fetch pypi-name)) + (version (assoc-ref* metadata "info" "version")) + (url (assoc-ref (latest-source-release metadata) "url"))) + (upstream-source + (package guix-package) + (version version) + (urls (list url))))) + +(define %pypi-updater + (upstream-updater + (name 'pypi) + (description "Updater for PyPI packages") + (pred pypi-package?) + (latest latest-release))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 0df4121d0a..3984a0bde1 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -30,6 +30,7 @@ (define-module (guix scripts refresh) #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) + #:use-module (guix import pypi) #:use-module (guix gnupg) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) @@ -152,7 +153,8 @@ (define %updaters ;; List of "updaters" used by default. They are consulted in this order. (list %gnu-updater %elpa-updater - %cran-updater)) + %cran-updater + %pypi-updater)) (define (lookup-updater name) "Return the updater called NAME." -- cgit v1.2.3 From d431b232403fbf4d41617ba29664dcd3fff23f96 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 3 Nov 2015 18:05:43 -0500 Subject: scripts: container: Fix 'exec' command line parsing. * guix/scripts/container/exec.scm (partition-args): Reimplement such that all args up to and including the PID are returned as the first of the two values. --- guix/scripts/container/exec.scm | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index b842fd38aa..10e70568cc 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -50,10 +50,18 @@ (define (show-help) (define (partition-args args) "Split ARGS into two lists; one containing the arguments for this program, and the other containing arguments for the command to be executed." - (break (lambda (arg) - ;; Split after the pid argument. - (not (false-if-exception (string->number arg)))) - args)) + (define (number-string? str) + (false-if-exception (string->number str))) + + (let loop ((a '()) + (b args)) + (match b + (() + (values (reverse a) '())) + (((? number-string? head) . tail) + (values (reverse (cons head a)) tail)) + ((head . tail) + (loop (cons head a) tail))))) (define (guix-container-exec . args) (define (handle-argument arg result) -- cgit v1.2.3 From d1cb7e9562a1b645fcd374067b4f98577fea3723 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Nov 2015 23:54:06 +0100 Subject: import: pypi: Add missing copyright line. * guix/import/pypi.scm: Add missing copyright line for bab020d. --- guix/import/pypi.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index f1988a7186..f58efd9915 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson +;;; Copyright © 2015 Cyril Roelandt ;;; ;;; This file is part of GNU Guix. ;;; -- cgit v1.2.3 From 32728adb958560268b793b4a3e48d94111b5ed2d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Nov 2015 00:08:30 +0100 Subject: import: pypi: Make downloads silent. * guix/import/pypi.scm (pypi-fetch): Wrap body in 'call-with-output-file' and 'with-error-to-port'. --- guix/import/pypi.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index f58efd9915..7ca0cc991e 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -45,7 +45,14 @@ (define-module (guix import pypi) (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, or #f on failure." - (json-fetch (string-append "https://pypi.python.org/pypi/" name "/json"))) + ;; XXX: We want to silence the download progress report, which is especially + ;; annoying for 'guix refresh', but we have to use a file port. + (call-with-output-file "/dev/null" + (lambda (null) + (with-error-to-port null + (lambda () + (json-fetch (string-append "https://pypi.python.org/pypi/" + name "/json"))))))) (define (latest-source-release pypi-package) "Return the latest source release for PYPI-PACKAGE." -- cgit v1.2.3 From f856fcb558eb59f9bb0d4b0651bd7508370321f4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Nov 2015 00:09:49 +0100 Subject: build-system/python: 'package-with-python2' preserves source location. * guix/build-system/python.scm (package-with-explicit-python): Add 'location' field. --- guix/build-system/python.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 1a5d9df473..2532210a49 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -92,6 +92,7 @@ (define transform (if (eq? (package-build-system p) python-build-system) (package (inherit p) + (location (package-location p)) (name (let ((name (package-name p))) (string-append new-prefix (if (string-prefix? old-prefix name) -- cgit v1.2.3 From 5453de3dd88f28d5b3e7cff96df2c583e57bb23b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Nov 2015 23:54:12 +0100 Subject: import: hackage: Fix invalid use of 'leave'. Reported by Paul van der Walt in . * guix/scripts/import/hackage.scm (guix-import-hackage): Add missing argument in call to 'leave'. --- guix/scripts/import/hackage.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 8c4e640bf3..97d042be3e 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -134,9 +134,9 @@ (define (run-importer package-name opts error-fn) ((package-name) (run-importer package-name opts (lambda () - (leave - (_ "failed to download cabal file for package '~a'~%")) - package-name))) + (leave (_ "failed to download cabal file \ +for package '~a'~%") + package-name)))) (() (leave (_ "too few arguments~%"))) ((many ...) -- cgit v1.2.3 From 67c920fa5d9a77543e0e950fdf26e2f502b656d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 5 Nov 2015 12:01:26 +0100 Subject: edit: Lift helper procedure. * guix/scripts/edit.scm (package->location-specification): New procedure, with code formerly... (guix-edit): ... here. Use it. --- guix/scripts/edit.scm | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 30146af10b..fa10a16f31 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -59,6 +59,15 @@ (define (search-path* path file) file path)) absolute-file-name)) +(define (package->location-specification package) + "Return the location specification for PACKAGE for a typical editor command +line." + (let ((loc (package-location package))) + (list (string-append "+" + (number->string + (location-line loc))) + (search-path* %load-path (location-file loc))))) + (define (guix-edit . args) (with-error-handling @@ -71,10 +80,4 @@ (define (guix-edit . args) (package-full-name package)))) packages) (apply execlp (%editor) (%editor) - (append-map (lambda (package) - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) - packages))))) + (append-map package->location-specification packages))))) -- cgit v1.2.3 From 650f1615de325f332dbf3d993acc8a16648d795e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 5 Nov 2015 12:04:26 +0100 Subject: edit: Improve error reporting when $EDITOR is not found. Reported by Benno Evers at . * guix/scripts/edit.scm (guix-edit): Wrap 'execl' call in 'catch'. Provide more meaningful error message. --- guix/scripts/edit.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index fa10a16f31..0509148c4d 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -79,5 +79,12 @@ (define (guix-edit . args) (leave (_ "source location of package '~a' is unknown~%") (package-full-name package)))) packages) - (apply execlp (%editor) (%editor) - (append-map package->location-specification packages))))) + + (catch 'system-error + (lambda () + (apply execlp (%editor) (%editor) + (append-map package->location-specification packages))) + (lambda args + (let ((errno (system-error-errno args))) + (leave (_ "failed to launch '~a': ~a~%") + (%editor) (strerror errno)))))))) -- cgit v1.2.3 From b68d2dbf0850d52e393f902dd64371cde85515a8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 8 Nov 2015 21:57:42 +0100 Subject: refresh: Discard PyPI updater when Guile-JSON is missing. Reported by Sleep_Walker and Mathieu Lirzin . * guix/scripts/refresh.scm (maybe-updater, list-updaters): New macros. (%updaters): Use 'list-updaters' instead of 'list'. Make %PYPI-UPDATER conditional. --- guix/scripts/refresh.scm | 40 +++++++++++++++++++++++++++++++++++----- 1 file changed, 35 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 3984a0bde1..8c2ca81175 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -30,7 +30,6 @@ (define-module (guix scripts refresh) #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) - #:use-module (guix import pypi) #:use-module (guix gnupg) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) @@ -149,12 +148,43 @@ (define (show-help) ;;; Updates. ;;; +(define-syntax maybe-updater + ;; Helper macro for 'list-udpaters'. + (lambda (s) + (syntax-case s (=>) + ((_ ((module => updater) rest ...) (result ...)) + (let ((met? (false-if-exception + (resolve-interface (syntax->datum #'module))))) + (if met? + #'(maybe-updater (rest ...) + (result ... (@ module updater))) + #'(maybe-updater (rest ...) (result ...))))) + ((_ (updater rest ...) (result ...)) + #'(maybe-updater (rest ...) (result ... updater))) + ((_ () result) + #'result)))) + +(define-syntax-rule (list-updaters updaters ...) + "Expand to '(list UPDATERS ...)' but only the subset of UPDATERS that are +either unconditional, or have their requirement met. + +A conditional updater has this form: + + ((SOME MODULE) => UPDATER) + +meaning that UPDATER is added to the list if and only if (SOME MODULE) could +be resolved at macro expansion time. + +This is a way to discard at macro expansion time updaters that depend on +unavailable optional dependencies such as Guile-JSON." + (maybe-updater (updaters ...) (list))) + (define %updaters ;; List of "updaters" used by default. They are consulted in this order. - (list %gnu-updater - %elpa-updater - %cran-updater - %pypi-updater)) + (list-updaters %gnu-updater + %elpa-updater + %cran-updater + ((guix import pypi) => %pypi-updater))) (define (lookup-updater name) "Return the updater called NAME." -- cgit v1.2.3 From fc2d2339644b408574f0ead4436e751fa423a7e6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Nov 2015 22:00:53 +0100 Subject: guix package: '--search-paths' can report combined search paths. Partly fixes . * guix/scripts/package.scm (search-path-environment-variables): Change 'profile' to 'profiles'; expect it to be a list. (display-search-paths): Likewise. (%default-options): Remove 'profile' entry. (%options) <--profile>: Keep previous values associated with 'profile' in RESULT. (guix-package)[process-actions, process-query]: Handle the possible lack of 'profile' pair in OPTS. --- doc/guix.texi | 14 +++++++++++ guix/scripts/package.scm | 64 ++++++++++++++++++++++++++--------------------- tests/guix-package-net.sh | 12 ++++++++- 3 files changed, 60 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 896a8c8496..09a860a64f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1347,6 +1347,20 @@ meaning that the returned environment variable definitions will either be exact settings, or prefixes or suffixes of the current value of these variables. When omitted, @var{kind} defaults to @code{exact}. +This option can also be used to compute the @emph{combined} search paths +of several profiles. Consider this example: + +@example +$ guix package -p foo -i guile +$ guix package -p bar -i guile-json +$ guix package -p foo -p bar --search-paths +@end example + +The last command above reports about the @code{GUILE_LOAD_PATH} +variable, even though, taken individually, neither @file{foo} nor +@file{bar} would lead to that recommendation. + + @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index adbc4a1828..5a059f12ae 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -186,11 +186,11 @@ (define (upgradeable? name current-version current-path) ;;; Search paths. ;;; -(define* (search-path-environment-variables entries profile +(define* (search-path-environment-variables entries profiles #:optional (getenv getenv) #:key (kind 'exact)) "Return environment variable definitions that may be needed for the use of -ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the +ENTRIES, a list of manifest entries, in PROFILES. Use GETENV to determine the current settings and report only settings not already effective. KIND must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search path definition to be returned." @@ -205,15 +205,15 @@ (define* (search-path-environment-variables entries profile (environment-variable-definition variable value #:separator sep #:kind kind)))) - (evaluate-search-paths search-paths (list profile) + (evaluate-search-paths search-paths profiles getenv)))) -(define* (display-search-paths entries profile +(define* (display-search-paths entries profiles #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let* ((profile (user-friendly-profile profile)) - (settings (search-path-environment-variables entries profile + (let* ((profiles (map user-friendly-profile profiles)) + (settings (search-path-environment-variables entries profiles #:kind kind))) (unless (null? settings) (format #t (_ "The following environment variable definitions may be needed:~%")) @@ -226,8 +226,7 @@ (define* (display-search-paths entries profile (define %default-options ;; Alist of default option values. - `((profile . ,%current-profile) - (max-silent-time . 3600) + `((max-silent-time . 3600) (verbosity . 0) (substitutes? . #t))) @@ -386,7 +385,7 @@ (define %options (option '(#\p "profile") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'profile (canonicalize-profile arg) - (alist-delete 'profile result)) + result) #f))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result arg-handler) @@ -601,7 +600,7 @@ (define (process-actions opts) ;; Process any install/remove/upgrade action from OPTS. (define dry-run? (assoc-ref opts 'dry-run?)) - (define profile (assoc-ref opts 'profile)) + (define profile (or (assoc-ref opts 'profile) %current-profile)) (define (build-and-use-profile manifest) (let* ((bootstrap? (assoc-ref opts 'bootstrap?))) @@ -645,7 +644,7 @@ (define (build-and-use-profile manifest) "~a packages in profile~%" count) count) - (display-search-paths entries profile))))))))) + (display-search-paths entries (list profile)))))))))) ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) @@ -674,12 +673,12 @@ (define (build-and-use-profile manifest) (not dry-run?)) (for-each (match-lambda - (('delete-generations . pattern) - (delete-matching-generations (%store) profile pattern) + (('delete-generations . pattern) + (delete-matching-generations (%store) profile pattern) - (process-actions - (alist-delete 'delete-generations opts))) - (_ #f)) + (process-actions + (alist-delete 'delete-generations opts))) + (_ #f)) opts)) ((assoc-ref opts 'manifest) (let* ((file-name (assoc-ref opts 'manifest)) @@ -709,7 +708,14 @@ (define (build-and-use-profile manifest) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was ;; actually processed, #f otherwise. - (let ((profile (assoc-ref opts 'profile))) + (let* ((profiles (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst lst))) + (profile (match profiles + ((head tail ...) head)))) (match (assoc-ref opts 'query) (('list-generations pattern) (define (list-generation number) @@ -718,7 +724,7 @@ (define (list-generation number) (display-profile-content profile number) (newline))) - (cond ((not (file-exists? profile)) ; XXX: race condition + (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) ((string-null? pattern) @@ -741,11 +747,11 @@ (define (list-generation number) (installed (manifest-entries manifest))) (leave-on-EPIPE (for-each (match-lambda - (($ name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) + (($ name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) ;; Show most recently installed packages last. (reverse installed))) @@ -793,12 +799,12 @@ (define (list-generation number) #t)) (('search-paths kind) - (let* ((manifest (profile-manifest profile)) - (entries (manifest-entries manifest)) - (profile (user-friendly-profile profile)) - (settings (search-path-environment-variables entries profile - (const #f) - #:kind kind))) + (let* ((manifests (map profile-manifest profiles)) + (entries (append-map manifest-entries manifests)) + (profiles (map user-friendly-profile profiles)) + (settings (search-path-environment-variables entries profiles + (const #f) + #:kind kind))) (format #t "~{~a~%~}" settings) #t)) diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index 14222cfd25..35ef6ff1a0 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -46,9 +46,10 @@ fi profile="t-profile-$$" +profile_alt="t-profile-alt-$$" rm -f "$profile" -trap 'rm -f "$profile" "$profile-"[0-9]* ; rm -rf t-home-'"$$" EXIT +trap 'rm -f "$profile" "$profile_alt" "$profile-"[0-9]* ; rm -rf t-home-'"$$" EXIT guix package --bootstrap -p "$profile" -i guile-bootstrap @@ -156,6 +157,15 @@ guix package -p "$profile" --switch-generation=2 guix package -p "$profile" --delete-generations=3 test -z "`guix package -p "$profile" -l 3`" +# Search path of combined profiles. 'LIBRARY_PATH' should show up only in the +# combination, not in the individual profiles. +rm "$profile" +guix package --bootstrap -p "$profile" -i guile-bootstrap +guix package --bootstrap -p "$profile_alt" -i gcc-bootstrap +if guix package -p "$profile" --search-paths | grep LIBRARY_PATH +then false; fi +guix package -p "$profile" -p "$profile_alt" --search-paths \ + | grep "LIBRARY_PATH.*$profile/lib" # # Try with the default profile. -- cgit v1.2.3 From 2ab5fdc4b4b340ffabaeb582fa1b19e4836fc27e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Nov 2015 22:24:38 +0100 Subject: ui: 'guix help COMMAND' is like 'guix COMMAND --help'. * guix/ui.scm (run-guix): Add ("help" COMMAND) case. --- guix/ui.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 312c2a01a1..581fb941f5 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1191,6 +1191,9 @@ (define option? (cut string-prefix? "-" <>)) (format (current-error-port) (_ "guix: unrecognized option '~a'~%") o) (show-guix-usage)) + (("help" command) + (apply run-guix-command (string->symbol command) + '("--help"))) (("help" args ...) (show-guix-help)) ((command args ...) -- cgit v1.2.3 From 14649b8cdb5708ff99626bbfae194457c465311e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Nov 2015 22:09:27 +0100 Subject: refresh: Avoid non-literal format string. Reported by Mathieu Lirzin . * guix/scripts/refresh.scm (guix-refresh): Rewrite 'list-dependent?' report to avoid nested 'N_' calls. --- guix/scripts/refresh.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 8c2ca81175..3161aacfe2 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -322,21 +322,25 @@ (define core-package? (package-covering-dependents packages))) (total-dependents (length (package-transitive-dependents packages)))) - (if (= total-dependents 0) - (format (current-output-port) - (N_ "No dependents other than itself: ~{~a~}~%" - "No dependents other than themselves: ~{~a~^ ~}~%" - (length packages)) - (map package-full-name packages)) - (format (current-output-port) - (N_ (N_ "A single dependent package: ~2*~{~a~}~%" - "Building the following package would ensure ~d \ -dependent packages are rebuilt; ~*~{~a~^ ~}~%" - total-dependents) - "Building the following ~d packages would ensure ~d \ + (cond ((= total-dependents 0) + (format (current-output-port) + (N_ "No dependents other than itself: ~{~a~}~%" + "No dependents other than themselves: ~{~a~^ ~}~%" + (length packages)) + (map package-full-name packages))) + + ((= total-dependents 1) + (format (current-output-port) + (_ "A single dependent package: ~{~a~}~%") + rebuilds)) + (else + (format (current-output-port) + (N_ "Building the following package would ensure ~d \ +dependent packages are rebuilt: ~*~{~a~^ ~}~%" + "Building the following ~d packages would ensure ~d \ dependent packages are rebuilt: ~{~a~^ ~}~%" (length rebuilds)) - (length rebuilds) total-dependents rebuilds)))) + (length rebuilds) total-dependents rebuilds))))) (update? (let ((store (open-connection))) (parameterize ((%openpgp-key-server -- cgit v1.2.3 From 6237b9fa39c6ab3283c50b96520b990c8612abc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Nov 2015 22:59:35 +0100 Subject: edit: Honor $VISUAL. Suggested by Andreas Enge . * guix/scripts/edit.scm (%editor): Honor 'VISUAL' before 'EDITOR'. (show-help): Adjust accordingly. * doc/guix.texi (Invoking guix edit): Likewise. --- doc/guix.texi | 5 +++-- guix/scripts/edit.scm | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 09a860a64f..3b6955c6f5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3929,8 +3929,9 @@ guix edit gcc-4.8 vim @end example @noindent -launches the program specified in the @code{EDITOR} environment variable -to edit the recipe of GCC@tie{}4.8.4 and that of Vim. +launches the program specified in the @code{VISUAL} or in the +@code{EDITOR} environment variable to edit the recipe of GCC@tie{}4.8.4 +and that of Vim. If you are using Emacs, note that the Emacs user interface provides similar functionality in the ``package info'' and ``package list'' diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 0509148c4d..73a5bb78d2 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -38,7 +38,7 @@ (define %options (define (show-help) (display (_ "Usage: guix edit PACKAGE... -Start $EDITOR to edit the definitions of PACKAGE...\n")) +Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (newline) (display (_ " -h, --help display this help and exit")) @@ -48,7 +48,8 @@ (define (show-help) (show-bug-report-information)) (define %editor - (make-parameter (or (getenv "EDITOR") "emacsclient"))) + (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") + "emacsclient"))) (define (search-path* path file) "Like 'search-path' but exit if FILE is not found." -- cgit v1.2.3 From 3a96d7c3dd864e4312df723ea54c2f710f55380c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Nov 2015 23:05:43 +0100 Subject: guix gc: Error out when extra arguments are passed. Fixes . Reported by Petter Berntsen . * guix/scripts/gc.scm (guix-gc)[assert-no-extra-arguments]: New procedure. Use it for actions 'collect-garbage', 'optimize', and 'verify'. * tests/guix-gc.sh: Add tests. --- guix/scripts/gc.scm | 7 +++++++ tests/guix-gc.sh | 8 +++++++- 2 files changed, 14 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 89a68d51d0..fe1bb93f7f 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -182,6 +182,10 @@ (define (store-directory file) (('argument . arg) arg) (_ #f)) opts))) + (define (assert-no-extra-arguments) + (unless (null? paths) + (leave (_ "extraneous arguments: ~{~a ~}~%") paths))) + (define (list-relatives relatives) (for-each (compose (lambda (path) (for-each (cut simple-format #t "~a~%" <>) @@ -192,6 +196,7 @@ (define (list-relatives relatives) (case (assoc-ref opts 'action) ((collect-garbage) + (assert-no-extra-arguments) (let ((min-freed (assoc-ref opts 'min-freed))) (if min-freed (collect-garbage store min-freed) @@ -205,8 +210,10 @@ (define (list-relatives relatives) ((list-referrers) (list-relatives referrers)) ((optimize) + (assert-no-extra-arguments) (optimize-store store)) ((verify) + (assert-no-extra-arguments) (let ((options (assoc-ref opts 'verify-options))) (exit (verify-store store diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index c1eb66cef5..a100f186f5 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013 Ludovic Courtès +# Copyright © 2013, 2015 Ludovic Courtès # # This file is part of GNU Guix. # @@ -25,6 +25,12 @@ guix gc --version trap "rm -f guix-gc-root" EXIT rm -f guix-gc-root +# For some operations, passing extra arguments is an error. +for option in "" "-C 500M" "--verify" "--optimize" +do + if guix gc $option whatever; then false; else true; fi +done + # Check the references of a .drv. drv="`guix build guile-bootstrap -d`" out="`guix build guile-bootstrap`" -- cgit v1.2.3 From 279ec1df202698d94c7992162621f6f7c00a7695 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Nov 2015 23:08:43 +0100 Subject: ftp-client: Restrict to TCP connections. * guix/ftp-client.scm (ftp-open): Force SOCK_STREAM as the socket type to avoid calling 'connect' on a datagram socket. --- guix/ftp-client.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 37feb895a5..e98708ac4d 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -95,7 +95,7 @@ (define addresses (let loop ((addresses addresses)) (let* ((ai (car addresses)) - (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (s (socket (addrinfo:fam ai) SOCK_STREAM ;TCP only (addrinfo:protocol ai)))) (catch 'system-error -- cgit v1.2.3 From 4856700698cc0a2c1a5992a82c56d5b26024ab06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Nov 2015 23:10:31 +0100 Subject: ftp-client: Add timeout parameter to 'ftp-open'. * guix/ftp-client.scm (catch-EINPROGRESS): New macro. (connect*): New procedure. (ftp-open): Add #:timeout parameter. Use 'connect*' instead of 'connect' and pass it TIMEOUT. --- guix/ftp-client.scm | 49 ++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index e98708ac4d..9ea878a145 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -30,6 +30,7 @@ (define-module (guix ftp-client) #:export (ftp-connection? ftp-connection-addrinfo + connect* ftp-open ftp-close ftp-chdir @@ -82,9 +83,51 @@ (define (%ftp-login user pass port) ((331) (%ftp-command (string-append "PASS " pass) 230 port)) (else (throw 'ftp-error port command code message)))))) -(define* (ftp-open host #:optional (port 21)) +(define-syntax-rule (catch-EINPROGRESS body ...) + (catch 'system-error + (lambda () + body ...) + (lambda args + (unless (= (system-error-errno args) EINPROGRESS) + (apply throw args))))) + +;; XXX: For lack of a better place. +(define* (connect* s sockaddr #:optional timeout) + "When TIMEOUT is omitted or #f, this procedure is equivalent to 'connect'. +When TIMEOUT is a number, it is the (possibly inexact) maximum number of +seconds to wait for the connection to succeed." + (define (raise-error errno) + (throw 'system-error 'connect* "~A" + (list (strerror errno)) + (list errno))) + + (if timeout + (let ((flags (fcntl s F_GETFL))) + (fcntl s F_SETFL (logior flags O_NONBLOCK)) + (catch-EINPROGRESS (connect s sockaddr)) + (match (select '() (list s) (list s) timeout) + ((() () ()) + ;; Time is up! + (raise-error ETIMEDOUT)) + ((() (write) ()) + ;; Check for ECONNREFUSED and the likes. + (fcntl s F_SETFL flags) + (let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) + (unless (zero? errno) + (raise-error errno)))) + ((() () (except)) + ;; Seems like this cannot really happen, but who knows. + (let ((errno (getsockopt s SOL_SOCKET SO_ERROR))) + (raise-error errno))))) + (connect s sockaddr))) + +(define* (ftp-open host #:optional (port 21) #:key timeout) "Open an FTP connection to HOST on PORT (a service-identifying string, -or a TCP port number), and return it." +or a TCP port number), and return it. + +When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the +maximum duration in seconds to wait for the connection to complete; passed +TIMEOUT, an ETIMEDOUT error is raised." ;; Use 21 as the default PORT instead of "ftp", to avoid depending on ;; libc's NSS, which is not available during bootstrap. @@ -100,7 +143,7 @@ (define addresses (catch 'system-error (lambda () - (connect s (addrinfo:addr ai)) + (connect* s (addrinfo:addr ai) timeout) (setvbuf s _IOLBF) (let-values (((code message) (%ftp-listen s))) (if (eqv? code 220) -- cgit v1.2.3 From 60fd51222f9d7ec90bdad37bca921f40f7f5b104 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Nov 2015 22:37:32 +0100 Subject: download: Add timeout parameter for connections. * guix/build/download.scm (ensure-uri): New procedure. (current-http-proxy): New variable. (open-socket-for-uri): Copy from Guile commit aaea5b2, but add #:timeout parameter and use 'connect*' instead of 'connect'. (open-connection-for-uri): Add #:timeout parameter and pass it to 'open-socket-for-uri'. --- guix/build/download.scm | 82 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 61 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 240e79ee8d..17e8f8cb9e 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -20,6 +20,7 @@ (define-module (guix build download) #:use-module (web uri) + #:use-module (web http) #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) #:use-module (guix ftp-client) @@ -277,26 +278,65 @@ (define (log level str) (add-weak-reference record port) record))) -(define (open-socket-for-uri uri) - "Return an open port for URI. This variant works around - which affects Guile's 'open-socket-for-uri' up to -2.0.11 included." - (define rmem-max - ;; The maximum size for a receive buffer on Linux, see socket(7). - "/proc/sys/net/core/rmem_max") - - (define buffer-size - (if (file-exists? rmem-max) - (call-with-input-file rmem-max read) - 126976)) ;the default for Linux, per 'rmem_default' - - (let ((s ((@ (web client) open-socket-for-uri) uri))) - ;; Work around by restoring a decent - ;; buffer size. - (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) - s)) - -(define (open-connection-for-uri uri) +(define (ensure-uri uri-or-string) ;XXX: copied from (web http) + (cond + ((string? uri-or-string) (string->uri uri-or-string)) + ((uri? uri-or-string) uri-or-string) + (else (error "Invalid URI" uri-or-string)))) + +(define current-http-proxy + ;; XXX: Add a dummy definition for Guile < 2.0.10; this is used in + ;; 'open-socket-for-uri'. + (or (and=> (module-variable (resolve-interface '(web client)) + 'current-http-proxy) + variable-ref) + (const #f))) + +(define* (open-socket-for-uri uri-or-string #:key timeout) + "Return an open input/output port for a connection to URI. When TIMEOUT is +not #f, it must be a (possibly inexact) number denoting the maximum duration +in seconds to wait for the connection to complete; passed TIMEOUT, an +ETIMEDOUT error is raised." + ;; Includes a fix for which affects Guile's + ;; 'open-socket-for-uri' up to 2.0.11 included, and uses 'connect*' instead + ;; of 'connect'. + + (define http-proxy (current-http-proxy)) + (define uri (ensure-uri (or http-proxy uri-or-string))) + (define addresses + (let ((port (uri-port uri))) + (delete-duplicates + (getaddrinfo (uri-host uri) + (cond (port => number->string) + (else (symbol->string (uri-scheme uri)))) + (if port + AI_NUMERICSERV + 0)) + (lambda (ai1 ai2) + (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) + + (let loop ((addresses addresses)) + (let* ((ai (car addresses)) + (s (with-fluids ((%default-port-encoding #f)) + ;; Restrict ourselves to TCP. + (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) + (catch 'system-error + (lambda () + (connect* s (addrinfo:addr ai) timeout) + + ;; Buffer input and output on this port. + (setvbuf s _IOFBF) + ;; If we're using a proxy, make a note of that. + (when http-proxy (set-http-proxy-port?! s #t)) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? (cdr addresses)) + (apply throw args) + (loop (cdr addresses)))))))) + +(define* (open-connection-for-uri uri #:key timeout) "Like 'open-socket-for-uri', but also handle HTTPS connections." (define https? (eq? 'https (uri-scheme uri))) @@ -319,7 +359,7 @@ (define https? (thunk)) (thunk))))))) (with-https-proxy - (let ((s (open-socket-for-uri uri))) + (let ((s (open-socket-for-uri uri #:timeout timeout))) ;; Buffer input and output on this port. (setvbuf s _IOFBF %http-receive-buffer-size) -- cgit v1.2.3 From 1b9aefa394a57dabe38e0658a3b612e962d3fc5e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Nov 2015 23:15:18 +0100 Subject: download: Always use AI_ADDRCONFIG when resolving host names. * guix/build/download.scm (open-socket-for-uri): Always pass AI_ADDRCONFIG to 'getaddrinfo' as recommended in the fine Guile manual. * guix/ftp-client.scm (ftp-open): Ditto. --- guix/build/download.scm | 10 +++++----- guix/ftp-client.scm | 4 +++- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 17e8f8cb9e..8843804c40 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -298,8 +298,8 @@ (define* (open-socket-for-uri uri-or-string #:key timeout) in seconds to wait for the connection to complete; passed TIMEOUT, an ETIMEDOUT error is raised." ;; Includes a fix for which affects Guile's - ;; 'open-socket-for-uri' up to 2.0.11 included, and uses 'connect*' instead - ;; of 'connect'. + ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead + ;; of 'connect', and uses AI_ADDRCONFIG. (define http-proxy (current-http-proxy)) (define uri (ensure-uri (or http-proxy uri-or-string))) @@ -309,9 +309,9 @@ (define addresses (getaddrinfo (uri-host uri) (cond (port => number->string) (else (symbol->string (uri-scheme uri)))) - (if port - AI_NUMERICSERV - 0)) + (if (number? port) + (logior AI_ADDRCONFIG AI_NUMERICSERV) + AI_ADDRCONFIG)) (lambda (ai1 ai2) (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 9ea878a145..f02d460061 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -134,7 +134,9 @@ (define* (ftp-open host #:optional (port 21) #:key timeout) (define addresses (getaddrinfo host (if (number? port) (number->string port) port) - (if (number? port) AI_NUMERICSERV 0))) + (if (number? port) + (logior AI_ADDRCONFIG AI_NUMERICSERV) + AI_ADDRCONFIG))) (let loop ((addresses addresses)) (let* ((ai (car addresses)) -- cgit v1.2.3 From bd7e1ffae6c91680e3328974f94c3ead8d2f378d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Nov 2015 23:17:12 +0100 Subject: lint: Have connections time out after 3 seconds. * guix/scripts/lint.scm (probe-uri): Add #:timeout parameter. Pass it to 'open-connection-for-uri' and 'ftp-open'. (validate-uri): Pass #:timeout 3 to 'probe-uri'. --- guix/scripts/lint.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b1707ade44..a7618ee286 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -266,10 +266,13 @@ (define (check-start-with-package-name synopsis) (check-start-with-package-name synopsis) (check-synopsis-length synopsis)))) -(define (probe-uri uri) +(define* (probe-uri uri #:key timeout) "Probe URI, a URI object, and return two values: a symbol denoting the probing status, such as 'http-response' when we managed to get an HTTP -response from URI, and additional details, such as the actual HTTP response." +response from URI, and additional details, such as the actual HTTP response. + +TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait +for connections to complete; when TIMEOUT is #f, wait as long as needed." (define headers '((User-Agent . "GNU Guile") (Accept . "*/*"))) @@ -280,7 +283,7 @@ (define headers ((or 'http 'https) (catch #t (lambda () - (let ((port (open-connection-for-uri uri)) + (let ((port (open-connection-for-uri uri #:timeout timeout)) (request (build-request uri #:headers headers))) (define response (dynamic-wind @@ -313,7 +316,7 @@ (define response ('ftp (catch #t (lambda () - (let ((conn (ftp-open (uri-host uri) 21))) + (let ((conn (ftp-open (uri-host uri) 21 #:timeout timeout))) (define response (dynamic-wind (const #f) @@ -338,7 +341,7 @@ (define (validate-uri uri package field) "Return #t if the given URI can be reached, otherwise return #f and emit a warning for PACKAGE mentionning the FIELD." (let-values (((status argument) - (probe-uri uri))) + (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) (or (= 200 (response-code argument)) -- cgit v1.2.3 From 9c88f655e6533e2f84ebf7ee546596c85031441d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Nov 2015 14:16:22 +0100 Subject: graft: Graft files in a deterministic order. * guix/build/graft.scm (rewrite-directory)[rewrite-leaf]: Change to take a single parameter. Add call to 'lstat'. Factorize result of 'destination'. Use 'find-files' instead of 'file-system-fold'. --- guix/build/graft.scm | 60 +++++++++++++++++++++++----------------------------- 1 file changed, 26 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 55f0f9410d..d29e671c67 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +21,6 @@ (define-module (guix build graft) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match) - #:use-module (ice-9 ftw) #:export (replace-store-references rewrite-directory)) @@ -93,38 +92,31 @@ (define prefix-len (define (destination file) (string-append output (string-drop file prefix-len))) - (define (rewrite-leaf file stat result) - (case (stat:type stat) - ((symlink) - (let ((target (readlink file))) - (symlink (call-with-output-string - (lambda (output) - (replace-store-references (open-input-string target) - output mapping - store))) - (destination file)))) - ((regular) - (with-fluids ((%default-port-encoding #f)) - (call-with-input-file file - (lambda (input) - (call-with-output-file (destination file) - (lambda (output) - (replace-store-references input output mapping - store) - (chmod output (stat:perms stat)))))))) - (else - (error "unsupported file type" stat)))) + (define (rewrite-leaf file) + (let ((stat (lstat file)) + (dest (destination file))) + (mkdir-p (dirname dest)) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink (call-with-output-string + (lambda (output) + (replace-store-references (open-input-string target) + output mapping + store))) + dest))) + ((regular) + (with-fluids ((%default-port-encoding #f)) + (call-with-input-file file + (lambda (input) + (call-with-output-file dest + (lambda (output) + (replace-store-references input output mapping + store) + (chmod output (stat:perms stat)))))))) + (else + (error "unsupported file type" stat))))) - (file-system-fold (const #t) - rewrite-leaf - (lambda (directory stat result) ;down - (mkdir (destination directory))) - (const #t) ;up - (const #f) ;skip - (lambda (file stat errno result) ;error - (error "read error" file stat errno)) - #f - directory - lstat)) + (for-each rewrite-leaf (find-files directory))) ;;; graft.scm ends here -- cgit v1.2.3 From 333c376c4586d16b215b994240ad4a5ddaa74d03 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Nov 2015 14:22:13 +0100 Subject: graft: Graft files in parallel. * guix/build/graft.scm (rewrite-directory): Use 'n-par-for-each' instead of 'for-each'. --- guix/build/graft.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index d29e671c67..0a9cd3260c 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -21,6 +21,7 @@ (define-module (guix build graft) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:export (replace-store-references rewrite-directory)) @@ -117,6 +118,7 @@ (define (rewrite-leaf file) (else (error "unsupported file type" stat))))) - (for-each rewrite-leaf (find-files directory))) + (n-par-for-each (parallel-job-count) + rewrite-leaf (find-files directory))) ;;; graft.scm ends here -- cgit v1.2.3 From b7f4677999f9ad9f457088b69e1dc86e9664ec76 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 17 Nov 2015 09:38:01 +0100 Subject: ftp-client: Restrict to TCP/IP connections. Fixes . Regression introduced in 279ec1d. Reported by Chris Marusich . * guix/ftp-client.scm (ftp-open): Restrict sockets to SOCK_STREAM/IPPROTO_IP. --- guix/ftp-client.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index f02d460061..e76f08afd4 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -140,8 +140,9 @@ (define addresses (let loop ((addresses addresses)) (let* ((ai (car addresses)) - (s (socket (addrinfo:fam ai) SOCK_STREAM ;TCP only - (addrinfo:protocol ai)))) + (s (socket (addrinfo:fam ai) + ;; TCP/IP only + SOCK_STREAM IPPROTO_IP))) (catch 'system-error (lambda () -- cgit v1.2.3 From 8fb583714f78d1b283523ef7edbb6e098946182f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Nov 2015 13:12:02 +0100 Subject: Add (guix graph). * guix/scripts/graph.scm (, , emit-prologue) (emit-epilogue, emit-node, emit-edge, %graphviz-backend, export-graph): Move to... * guix/graph.scm: ... here. New file. * guix/scripts/system.scm, tests/graph.scm: Use it. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/graph.scm | 132 ++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/graph.scm | 100 +----------------------------------- guix/scripts/system.scm | 1 + tests/graph.scm | 1 + 5 files changed, 136 insertions(+), 99 deletions(-) create mode 100644 guix/graph.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 67d483bfb0..43be2ec89e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -50,6 +50,7 @@ MODULES = \ guix/gnu-maintenance.scm \ guix/upstream.scm \ guix/licenses.scm \ + guix/graph.scm \ guix/build-system.scm \ guix/build-system/cmake.scm \ guix/build-system/emacs.scm \ diff --git a/guix/graph.scm b/guix/graph.scm new file mode 100644 index 0000000000..05325ba0a6 --- /dev/null +++ b/guix/graph.scm @@ -0,0 +1,132 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix graph) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix sets) + #:use-module (srfi srfi-9) + #:use-module (ice-9 match) + #:export (node-type + node-type? + node-type-identifier + node-type-label + node-type-edges + node-type-convert + node-type-name + node-type-description + + %graphviz-backend + graph-backend? + graph-backend + + export-graph)) + +;;; Commentary: +;;; +;;; This module provides an abstract way to represent graphs and to manipulate +;;; them. It comes with several such representations for packages, +;;; derivations, and store items. It also provides a generic interface for +;;; exporting graphs in an external format, including a Graphviz +;;; implementation thereof. +;;; +;;; Code: + + +;;; +;;; Node types. +;;; + +(define-record-type* node-type make-node-type + node-type? + (identifier node-type-identifier) ;node -> M identifier + (label node-type-label) ;node -> string + (edges node-type-edges) ;node -> M list of nodes + (convert node-type-convert ;package -> M list of nodes + (default (lift1 list %store-monad))) + (name node-type-name) ;string + (description node-type-description)) ;string + + +;;; +;;; Graphviz export. +;;; + +(define-record-type + (graph-backend prologue epilogue node edge) + graph-backend? + (prologue graph-backend-prologue) + (epilogue graph-backend-epilogue) + (node graph-backend-node) + (edge graph-backend-edge)) + +(define (emit-prologue name port) + (format port "digraph \"Guix ~a\" {\n" + name)) +(define (emit-epilogue port) + (display "\n}\n" port)) +(define (emit-node id label port) + (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%" + id label)) +(define (emit-edge id1 id2 port) + (format port " \"~a\" -> \"~a\" [color = red];~%" + id1 id2)) + +(define %graphviz-backend + (graph-backend emit-prologue emit-epilogue + emit-node emit-edge)) + +(define* (export-graph sinks port + #:key + reverse-edges? node-type + (backend %graphviz-backend)) + "Write to PORT the representation of the DAG with the given SINKS, using the +given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is +true, draw reverse arrows." + (match backend + (($ emit-prologue emit-epilogue emit-node emit-edge) + (emit-prologue (node-type-name node-type) port) + + (match node-type + (($ node-identifier node-label node-edges) + (let loop ((nodes sinks) + (visited (set))) + (match nodes + (() + (with-monad %store-monad + (emit-epilogue port) + (store-return #t))) + ((head . tail) + (mlet %store-monad ((id (node-identifier head))) + (if (set-contains? visited id) + (loop tail visited) + (mlet* %store-monad ((dependencies (node-edges head)) + (ids (mapm %store-monad + node-identifier + dependencies))) + (emit-node id (node-label head) port) + (for-each (lambda (dependency dependency-id) + (if reverse-edges? + (emit-edge dependency-id id port) + (emit-edge id dependency-id port))) + dependencies ids) + (loop (append dependencies tail) + (set-insert id visited))))))))))))) + +;;; graph.scm ends here diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 734a47719a..f607ebee31 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -18,6 +18,7 @@ (define-module (guix scripts graph) #:use-module (guix ui) + #:use-module (guix graph) #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) @@ -28,9 +29,7 @@ (define-module (guix scripts graph) #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) - #:use-module (guix records) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) @@ -41,38 +40,8 @@ (define-module (guix scripts graph) %reference-node-type %node-types - node-type - node-type? - node-type-identifier - node-type-label - node-type-edges - node-type-convert - node-type-name - node-type-description - - %graphviz-backend - graph-backend? - graph-backend - - export-graph - guix-graph)) - -;;; -;;; Node types. -;;; - -(define-record-type* node-type make-node-type - node-type? - (identifier node-type-identifier) ;node -> M identifier - (label node-type-label) ;node -> string - (edges node-type-edges) ;node -> M list of nodes - (convert node-type-convert ;package -> M list of nodes - (default (lift1 list %store-monad))) - (name node-type-name) ;string - (description node-type-description)) ;string - ;;; ;;; Package DAG. @@ -291,73 +260,6 @@ (define (list-node-types) (node-type-description type))) %node-types)) - -;;; -;;; Graphviz export. -;;; - -(define-record-type - (graph-backend prologue epilogue node edge) - graph-backend? - (prologue graph-backend-prologue) - (epilogue graph-backend-epilogue) - (node graph-backend-node) - (edge graph-backend-edge)) - -(define (emit-prologue name port) - (format port "digraph \"Guix ~a\" {\n" - name)) -(define (emit-epilogue port) - (display "\n}\n" port)) -(define (emit-node id label port) - (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%" - id label)) -(define (emit-edge id1 id2 port) - (format port " \"~a\" -> \"~a\" [color = red];~%" - id1 id2)) - -(define %graphviz-backend - (graph-backend emit-prologue emit-epilogue - emit-node emit-edge)) - -(define* (export-graph sinks port - #:key - reverse-edges? - (node-type %package-node-type) - (backend %graphviz-backend)) - "Write to PORT the representation of the DAG with the given SINKS, using the -given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is -true, draw reverse arrows." - (match backend - (($ emit-prologue emit-epilogue emit-node emit-edge) - (emit-prologue (node-type-name node-type) port) - - (match node-type - (($ node-identifier node-label node-edges) - (let loop ((nodes sinks) - (visited (set))) - (match nodes - (() - (with-monad %store-monad - (emit-epilogue port) - (store-return #t))) - ((head . tail) - (mlet %store-monad ((id (node-identifier head))) - (if (set-contains? visited id) - (loop tail visited) - (mlet* %store-monad ((dependencies (node-edges head)) - (ids (mapm %store-monad - node-identifier - dependencies))) - (emit-node id (node-label head) port) - (for-each (lambda (dependency dependency-id) - (if reverse-edges? - (emit-edge dependency-id id port) - (emit-edge id dependency-id port))) - dependencies ids) - (loop (append dependencies tail) - (set-insert id visited))))))))))))) - ;;; ;;; Command-line options. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 0d54d453db..1407dc73fa 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -29,6 +29,7 @@ (define-module (guix scripts system) #:use-module (guix profiles) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix build utils) #:use-module (gnu build install) diff --git a/tests/graph.scm b/tests/graph.scm index f454b06351..ed5849f4da 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -18,6 +18,7 @@ (define-module (test-graph) #:use-module (guix tests) + #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix packages) #:use-module (guix derivations) -- cgit v1.2.3 From 923d846c4dfe0f51357d3329697f54c779148dde Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Nov 2015 14:48:34 +0100 Subject: graph: Add procedures to query a node's edges. * guix/graph.scm (%node-edges, node-edges, node-back-edges) (node-transitive-edges): New procedures. * tests/graph.scm ("node-edges") ("node-transitive-edges + node-back-edges"): New tests. --- guix/graph.scm | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/graph.scm | 38 +++++++++++++++++++++++++++++++++++++- 2 files changed, 92 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/graph.scm b/guix/graph.scm index 05325ba0a6..a39208e7f9 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -21,8 +21,11 @@ (define-module (guix graph) #:use-module (guix monads) #:use-module (guix records) #:use-module (guix sets) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (node-type node-type? node-type-identifier @@ -32,6 +35,10 @@ (define-module (guix graph) node-type-name node-type-description + node-edges + node-back-edges + node-transitive-edges + %graphviz-backend graph-backend? graph-backend @@ -63,6 +70,54 @@ (define-record-type* node-type make-node-type (name node-type-name) ;string (description node-type-description)) ;string +(define (%node-edges type nodes cons-edge) + (with-monad %store-monad + (match type + (($ identifier label node-edges) + (define (add-edge node edges) + (>>= (node-edges node) + (lambda (nodes) + (return (fold (cut cons-edge node <> <>) + edges nodes))))) + + (mlet %store-monad ((edges (foldm %store-monad + add-edge vlist-null nodes))) + (return (lambda (node) + (reverse (vhash-foldq* cons '() node edges))))))))) + +(define (node-edges type nodes) + "Return, as a monadic value, a one-argument procedure that, given a node of TYPE, +returns its edges. NODES is taken to be the sinks of the global graph." + (%node-edges type nodes + (lambda (source target edges) + (vhash-consq source target edges)))) + +(define (node-back-edges type nodes) + "Return, as a monadic value, a one-argument procedure that, given a node of TYPE, +returns its back edges. NODES is taken to be the sinks of the global graph." + (%node-edges type nodes + (lambda (source target edges) + (vhash-consq target source edges)))) + +(define (node-transitive-edges nodes node-edges) + "Return the list of nodes directly or indirectly connected to NODES +according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument +procedure that, given a node, returns its list of direct dependents; it is +typically returned by 'node-edges' or 'node-back-edges'." + (let loop ((nodes (append-map node-edges nodes)) + (result '()) + (visited (setq))) + (match nodes + (() + result) + ((head . tail) + (if (set-contains? visited head) + (loop tail result visited) + (let ((edges (node-edges head))) + (loop (append edges tail) + (cons head result) + (set-insert head visited)))))))) + ;;; ;;; Graphviz export. diff --git a/tests/graph.scm b/tests/graph.scm index ed5849f4da..9c9e3666b7 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -25,8 +25,12 @@ (define-module (test-graph) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix build-system gnu) + #:use-module (guix build-system trivial) #:use-module (guix gexp) + #:use-module (guix utils) #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages guile) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -111,7 +115,7 @@ (define (edge->tuple source target) ".drv"))) implicit))))))) -(test-assert "bag DAG" +(test-assert "bag DAG" ;a big town in Iraq (let-values (((backend nodes+edges) (make-recording-backend))) (let ((p (dummy-package "p"))) (run-with-store %store @@ -188,6 +192,38 @@ (define (edge->tuple source target) (list out txt)) (equal? edges `((,out ,txt))))))))))) +(test-assert "node-edges" + (run-with-store %store + (let ((packages (fold-packages cons '()))) + (mlet %store-monad ((edges (node-edges %package-node-type packages))) + (return (and (null? (edges grep)) + (lset= eq? + (edges guile-2.0) + (match (package-direct-inputs guile-2.0) + (((labels packages _ ...) ...) + packages))))))))) + +(test-assert "node-transitive-edges + node-back-edges" + (run-with-store %store + (let ((packages (fold-packages cons '())) + (bootstrap? (lambda (package) + (string-contains + (location-file (package-location package)) + "bootstrap.scm"))) + (trivial? (lambda (package) + (eq? (package-build-system package) + trivial-build-system)))) + (mlet %store-monad ((edges (node-back-edges %bag-node-type packages))) + (let* ((glibc (canonical-package glibc)) + (dependents (node-transitive-edges (list glibc) edges)) + (diff (lset-difference eq? packages dependents))) + ;; All the packages depend on libc, except bootstrap packages and + ;; some that use TRIVIAL-BUILD-SYSTEM. + (return (null? (remove (lambda (package) + (or (trivial? package) + (bootstrap? package))) + diff)))))))) + (test-end "graph") -- cgit v1.2.3 From a51cbecb44d0bf87647576ec75d857138e14b0a8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Nov 2015 16:14:34 +0100 Subject: refresh: Rewrite '--list-dependent' in terms of (guix graph). * guix/scripts/refresh.scm (all-packages, list-dependents): New procedures. (guix-refresh): Use it. --- guix/scripts/refresh.scm | 71 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 48 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 3161aacfe2..c9eff7ba67 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -27,6 +27,9 @@ (define-module (guix scripts refresh) #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix graph) + #:use-module (guix scripts graph) + #:use-module (guix monads) #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) @@ -228,6 +231,50 @@ (define* (update-package store package updaters downloaded and authenticated; not updating~%") (package-name package) version))))) + +;;; +;;; Dependents. +;;; + +(define (all-packages) + "Return the list of all the distro's packages." + (fold-packages cons '())) + +(define (list-dependents packages) + "List all the things that would need to be rebuilt if PACKAGES are changed." + (with-store store + (run-with-store store + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (mlet %store-monad ((edges (node-back-edges %bag-node-type + (all-packages)))) + (let* ((dependents (node-transitive-edges packages edges)) + (covering (filter (lambda (node) + (null? (edges node))) + dependents))) + (match dependents + (() + (format (current-output-port) + (N_ "No dependents other than itself: ~{~a~}~%" + "No dependents other than themselves: ~{~a~^ ~}~%" + (length packages)) + (map package-full-name packages))) + + ((x) + (format (current-output-port) + (_ "A single dependent package: ~a~%") + (package-full-name x))) + (lst + (format (current-output-port) + (N_ "Building the following package would ensure ~d \ +dependent packages are rebuilt: ~*~{~a~^ ~}~%" + "Building the following ~d packages would ensure ~d \ +dependent packages are rebuilt: ~{~a~^ ~}~%" + (length covering)) + (length covering) (length dependents) + (map package-full-name covering)))) + (return #t)))))) + ;;; ;;; Entry point. @@ -318,29 +365,7 @@ (define core-package? (with-error-handling (cond (list-dependent? - (let* ((rebuilds (map package-full-name - (package-covering-dependents packages))) - (total-dependents - (length (package-transitive-dependents packages)))) - (cond ((= total-dependents 0) - (format (current-output-port) - (N_ "No dependents other than itself: ~{~a~}~%" - "No dependents other than themselves: ~{~a~^ ~}~%" - (length packages)) - (map package-full-name packages))) - - ((= total-dependents 1) - (format (current-output-port) - (_ "A single dependent package: ~{~a~}~%") - rebuilds)) - (else - (format (current-output-port) - (N_ "Building the following package would ensure ~d \ -dependent packages are rebuilt: ~*~{~a~^ ~}~%" - "Building the following ~d packages would ensure ~d \ -dependent packages are rebuilt: ~{~a~^ ~}~%" - (length rebuilds)) - (length rebuilds) total-dependents rebuilds))))) + (list-dependents packages)) (update? (let ((store (open-connection))) (parameterize ((%openpgp-key-server -- cgit v1.2.3 From 82e64fc14eec9f01f5fee12782046496ebed9c72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Nov 2015 22:24:45 +0100 Subject: environment: Correctly handle abnormal exits. Fixes . * guix/scripts/environment.scm (status->exit-code): New procedure. (exit/status, primitive-exit/status): Use it. * tests/guix-environment-container.sh: Add test. --- guix/scripts/environment.scm | 11 +++++++++-- tests/guix-environment-container.sh | 7 +++++++ 2 files changed, 16 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 97410f4e09..fae261733e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -317,8 +317,15 @@ (define (input->requisites input) (map input->requisites inputs)))) (return (delete-duplicates (concatenate reqs))))) -(define exit/status (compose exit status:exit-val)) -(define primitive-exit/status (compose primitive-exit status:exit-val)) +(define (status->exit-code status) + "Compute the exit code made from STATUS, a value as returned by 'waitpid', +and suitable for 'exit'." + ;; See . + (or (status:exit-val status) + (logior #x80 (status:term-sig status)))) + +(define exit/status (compose exit status->exit-code)) +(define primitive-exit/status (compose primitive-exit status->exit-code)) (define (launch-environment command inputs paths pure?) "Run COMMAND in a new environment containing INPUTS, using the native search diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 5670d01117..703ab31d27 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -81,3 +81,10 @@ grep $(guix build guile-bootstrap) $tmpdir/mounts grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash rm $tmpdir/mounts + +if guix environment --bootstrap --container \ + --ad-hoc bootstrap-binaries -- kill -SEGV 2 +then false; +else + test $? -gt 127 +fi -- cgit v1.2.3 From d6d33984df8df4f061eadaac1d71119c97c0db9f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Nov 2015 14:16:36 +0100 Subject: ftp-client: Fix off-by-one when trying addresses in 'ftp-open'. * guix/ftp-client.scm (ftp-open): Change to use 'match' instead of car/cdr, and fix off-by-one (was '(null? addresses)' instead of '(null? (cdr addresses))'.) --- guix/ftp-client.scm | 51 ++++++++++++++++++++++++++------------------------- 1 file changed, 26 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index e76f08afd4..a6a54a4d9c 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -139,31 +139,32 @@ (define addresses AI_ADDRCONFIG))) (let loop ((addresses addresses)) - (let* ((ai (car addresses)) - (s (socket (addrinfo:fam ai) - ;; TCP/IP only - SOCK_STREAM IPPROTO_IP))) - - (catch 'system-error - (lambda () - (connect* s (addrinfo:addr ai) timeout) - (setvbuf s _IOLBF) - (let-values (((code message) (%ftp-listen s))) - (if (eqv? code 220) - (begin - ;;(%ftp-command "OPTS UTF8 ON" 200 s) - (%ftp-login "anonymous" "guix@example.com" s) - (%make-ftp-connection s ai)) - (begin - (close s) - (throw 'ftp-error s "log-in" code message))))) - - (lambda args - ;; Connection failed, so try one of the other addresses. - (close s) - (if (null? addresses) - (apply throw args) - (loop (cdr addresses)))))))) + (match addresses + ((ai rest ...) + (let ((s (socket (addrinfo:fam ai) + ;; TCP/IP only + SOCK_STREAM IPPROTO_IP))) + + (catch 'system-error + (lambda () + (connect* s (addrinfo:addr ai) timeout) + (setvbuf s _IOLBF) + (let-values (((code message) (%ftp-listen s))) + (if (eqv? code 220) + (begin + ;;(%ftp-command "OPTS UTF8 ON" 200 s) + (%ftp-login "anonymous" "guix@example.com" s) + (%make-ftp-connection s ai)) + (begin + (close s) + (throw 'ftp-error s "log-in" code message))))) + + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? rest) + (apply throw args) + (loop rest))))))))) (define (ftp-close conn) (close (ftp-connection-socket conn))) -- cgit v1.2.3 From 862d2479f686abaa4d1881ad6eafb689bec157e8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Nov 2015 14:35:28 +0100 Subject: ftp-client: Default port for 'ftp-open' is now "ftp". * guix/ftp-client.scm (ftp-open): Change default #:port to "ftp". * guix/scripts/lint.scm (probe-uri): Remove 'port' parameter to 'ftp-open'. --- guix/ftp-client.scm | 9 ++++++--- guix/scripts/lint.scm | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index a6a54a4d9c..22d4c7dde2 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -121,15 +121,18 @@ (define (raise-error errno) (raise-error errno))))) (connect s sockaddr))) -(define* (ftp-open host #:optional (port 21) #:key timeout) +(define* (ftp-open host #:optional (port "ftp") #:key timeout) "Open an FTP connection to HOST on PORT (a service-identifying string, or a TCP port number), and return it. When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the maximum duration in seconds to wait for the connection to complete; passed TIMEOUT, an ETIMEDOUT error is raised." - ;; Use 21 as the default PORT instead of "ftp", to avoid depending on - ;; libc's NSS, which is not available during bootstrap. + ;; Using "ftp" for PORT instead of 21 allows 'getaddrinfo' to return only + ;; TCP/IP addresses (otherwise it would return SOCK_DGRAM and SOCK_RAW + ;; addresses as well.) With our bootstrap Guile, which includes a + ;; statically-linked NSS, resolving "ftp" works well, as long as + ;; /etc/services is available. (define addresses (getaddrinfo host diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index a7618ee286..034f0f95ee 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -316,7 +316,7 @@ (define response ('ftp (catch #t (lambda () - (let ((conn (ftp-open (uri-host uri) 21 #:timeout timeout))) + (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) (define response (dynamic-wind (const #f) -- cgit v1.2.3 From 71ae18ee52757eb60be50bb2e50bab5e84d0f097 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Nov 2015 17:32:02 +0100 Subject: guix download: Gracefully handle missing arguments. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Jan Synáček . * guix/scripts/download.scm (guix-download): Call 'leave' when OPTS does not contain an 'argument' key. --- guix/scripts/download.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 533970ffbb..b81295e5d9 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -102,7 +102,8 @@ (define (parse-options) (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) - (arg (assq-ref opts 'argument)) + (arg (or (assq-ref opts 'argument) + (leave (_ "no download URI was specified~%")))) (uri (or (string->uri arg) (leave (_ "~a: failed to parse URI~%") arg))) -- cgit v1.2.3 From 86cdfc451bad61faa66f100208c95f3275050957 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Nov 2015 17:37:29 +0100 Subject: guix download: Fail when more than one URL is passed. * guix/scripts/download.scm (guix-download)[parse-option]: Call 'leave' when passed an extra argument. * tests/guix-download.sh: Add test. --- guix/scripts/download.scm | 3 +++ tests/guix-download.sh | 6 +++++- 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index b81295e5d9..6ebc14f573 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -96,6 +96,9 @@ (define (parse-options) (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) (lambda (arg result) + (when (assq 'argument result) + (leave (_ "~A: extraneous argument~%") arg)) + (alist-cons 'argument arg result)) %default-options)) diff --git a/tests/guix-download.sh b/tests/guix-download.sh index 7af6f181f6..6283772c48 100644 --- a/tests/guix-download.sh +++ b/tests/guix-download.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012 Ludovic Courtès +# Copyright © 2012, 2015 Ludovic Courtès # # This file is part of GNU Guix. # @@ -34,3 +34,7 @@ then false; else true; fi # This one should succeed. guix download "file://$abs_top_srcdir/README" + +# This one should fail. +if guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" +then false; else true; fi -- cgit v1.2.3 From 2d7fc7daf14e6e965a4d33baa7b9d52873f37691 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Nov 2015 17:47:22 +0100 Subject: refresh: Add '--expression'. * guix/scripts/refresh.scm (%options, show-help): Add --expression. (guix-refresh): Honor it. * doc/guix.texi (Invoking guix refresh): Document it. --- doc/guix.texi | 13 +++++++++++++ guix/scripts/refresh.scm | 7 +++++++ 2 files changed, 20 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 233c371fdb..03363c170c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4277,6 +4277,19 @@ The following options are supported: @table @code +@item --expression=@var{expr} +@itemx -e @var{expr} +Consider the package @var{expr} evaluates to. + +This is useful to precisely refer to a package, as in this example: + +@example +guix refresh -l -e '(@@@@ (gnu packages commencement) glibc-final)' +@end example + +This command lists the dependents of the ``final'' libc (essentially all +the packages.) + @item --update @itemx -u Update distribution source files (package recipes) in place. This is diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index c9eff7ba67..8e8a34bd0f 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -80,6 +80,9 @@ (define %options (option '(#\L "list-updaters") #f #f (lambda args (list-updaters-and-exit))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) @@ -115,6 +118,8 @@ (define (show-help) When PACKAGE... is given, update only the specified packages. Otherwise update all the packages of the distribution, or the subset thereof specified with `--select'.\n")) + (display (_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) (display (_ " -u, --update update source files in place")) (display (_ " @@ -348,6 +353,8 @@ (define core-package? ;; Take either the specified version or the ;; latest one. (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) (_ #f)) opts) (() ; default to all packages -- cgit v1.2.3 From 38b92daa81d6c5eca77ae0cc3d454da46a64b48a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Nov 2015 23:31:53 +0100 Subject: graph: Add '%bag-with-origins-node-type'. * guix/scripts/graph.scm (bag-node-edges): Remove 'filter' call. Add case for 'origin'. (%bag-node-type)[edges]: Add filtering here. (%bag-with-origins-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("bag DAG, including origins"): New test. * tests/guix-graph.sh: Add 'bag-with-origins'. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 3 +++ guix/scripts/graph.scm | 48 ++++++++++++++++++++++++++++++++++++------------ tests/graph.scm | 26 ++++++++++++++++++++++++++ tests/guix-graph.sh | 2 +- 4 files changed, 66 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a56bda9c79..5eb6720934 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4631,6 +4631,9 @@ here, for conciseness. Similar to @code{bag-emerged}, but this time including all the bootstrap dependencies. +@item bag-with-origins +Similar to @code{bag}, but also showing origins and their dependencies. + @item derivations This is the most detailed representation: It shows the DAG of derivations (@pxref{Derivations}) and plain store items. Compared to diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index f607ebee31..9255f0018a 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -30,11 +30,13 @@ (define-module (guix scripts graph) #:use-module (gnu packages) #:use-module (guix sets) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type %bag-node-type + %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type %reference-node-type @@ -104,17 +106,23 @@ (define (bag-node-identifier thing) low)))))) (define (bag-node-edges thing) - "Return the list of dependencies of THING, a package or origin, etc." - (if (package? thing) - (match (bag-direct-inputs (package->bag thing)) - (((labels things . outputs) ...) - (filter-map (match-lambda - ((? package? p) p) - ;; XXX: Here we choose to filter out origins, files, - ;; etc. Replace "#f" with "x" to reinstate them. - (x #f)) - things))) - '())) + "Return the list of dependencies of THING, a package or origin. +Dependencies may include packages, origin, and file names." + (cond ((package? thing) + (match (bag-direct-inputs (package->bag thing)) + (((labels things . outputs) ...) + things))) + ((origin? thing) + (cons (origin-patch-guile thing) + (if (or (pair? (origin-patches thing)) + (origin-snippet thing)) + (match (origin-patch-inputs thing) + (#f '()) + (((labels dependencies _ ...) ...) + (delete-duplicates dependencies eq?))) + '()))) + (else + '()))) (define %bag-node-type ;; Type for the traversal of package nodes via the "bag" representation, @@ -124,7 +132,22 @@ (define %bag-node-type (description "the DAG of packages, including implicit inputs") (identifier bag-node-identifier) (label node-full-name) - (edges (lift1 bag-node-edges %store-monad)))) + (edges (lift1 (compose (cut filter package? <>) bag-node-edges) + %store-monad)))) + +(define %bag-with-origins-node-type + (node-type + (name "bag-with-origins") + (description "the DAG of packages and origins, including implicit inputs") + (identifier bag-node-identifier) + (label node-full-name) + (edges (lift1 (lambda (thing) + (filter (match-lambda + ((? package?) #t) + ((? origin?) #t) + (_ #f)) + (bag-node-edges thing))) + %store-monad)))) (define standard-package-set (memoize @@ -239,6 +262,7 @@ (define %node-types ;; List of all the node types. (list %package-node-type %bag-node-type + %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type %reference-node-type)) diff --git a/tests/graph.scm b/tests/graph.scm index 9c9e3666b7..ad8aea0ada 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -134,6 +134,32 @@ (define (edge->tuple source target) (((labels packages) ...) (map package-full-name packages)))))))) +(test-assert "bag DAG, including origins" + (let-values (((backend nodes+edges) (make-recording-backend))) + (let* ((m (lambda* (uri hash-type hash name #:key system) + (text-file "foo-1.2.3.tar.gz" "This is a fake!"))) + (o (origin (method m) (uri "the-uri") (sha256 #vu8(0 1 2)))) + (p (dummy-package "p" (source o)))) + (run-with-store %store + (export-graph (list p) 'port + #:node-type %bag-with-origins-node-type + #:backend backend)) + ;; We should see O among the nodes, with an edge coming from P. + (let-values (((nodes edges) (nodes+edges))) + (run-with-store %store + (mlet %store-monad ((o* (lower-object o)) + (p* (lower-object p))) + (return + (and (find (match-lambda + ((file "the-uri") #t) + (_ #f)) + nodes) + (find (match-lambda + ((source target) + (and (string=? source (derivation-file-name p*)) + (string=? target o*)))) + edges))))))))) + (test-assert "derivation DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (run-with-store %store diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh index e0cbebb753..4d5a755bc1 100644 --- a/tests/guix-graph.sh +++ b/tests/guix-graph.sh @@ -24,7 +24,7 @@ guix graph --version for package in guile-bootstrap coreutils python do - for graph in package bag-emerged bag + for graph in package bag-emerged bag bag-with-origins do guix graph -t "$graph" "$package" | grep "$package" done -- cgit v1.2.3 From cc3de1da418e1718ab4ff85144a56f573460fbd6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Nov 2015 18:12:03 +0100 Subject: guix package: Reduce startup time by ~50%. As measured with: time sh -c 'for i in `seq 1 10` ; do guix package --search-paths ; done' On my machine, when running: strace -o ,,s guix package --search-paths the number returned by: grep -E '^(open|l?stat).*\.go' ,,s | wc -l drops from 1610 to 837. * guix/scripts/package.scm: Remove two unnecessary #:use-module forms. Autoload (gnu packages ...) modules. --- guix/scripts/package.scm | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5a059f12ae..b1bce7020c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -32,22 +32,20 @@ (define-module (guix scripts package) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module ((guix build utils) - #:select (directory-exists? mkdir-p search-path-as-list)) + #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) - #:use-module (gnu packages base) - #:use-module (gnu packages guile) - #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:autoload (gnu packages base) (canonical-package) + #:autoload (gnu packages guile) (guile-2.0) + #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:export (delete-generations display-search-paths guix-package)) -- cgit v1.2.3 From 851b6f6283b68fbf711c91e253fd5a3433280946 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Nov 2015 10:48:55 +0100 Subject: gexp: Build text derivations locally. * guix/gexp.scm (gexp->file): Pass #:substitutable? #f. (text-file*): Likewise, and #:local-build? #t. --- guix/gexp.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 27bccc6206..14ced747b2 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -980,7 +980,8 @@ (define (gexp->file name exp) (call-with-output-file (ungexp output) (lambda (port) (write '(ungexp exp) port)))) - #:local-build? #t)) + #:local-build? #t + #:substitutable? #f)) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing @@ -992,7 +993,9 @@ (define builder (lambda (port) (display (string-append (ungexp-splicing text)) port))))) - (gexp->derivation name builder)) + (gexp->derivation name builder + #:local-build? #t + #:substitutable? #f)) (define* (mixed-text-file name #:rest text) "Return an object representing store file NAME containing TEXT. TEXT is a -- cgit v1.2.3 From 7716f55c8356da945261646b4d04864b6d8636aa Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Wed, 11 Nov 2015 10:39:38 +0100 Subject: import: hackage: Add recognition of 'true' and 'false' symbols. * guix/import/cabal.scm (is-true, is-false, lex-true, lex-false): New procedures. (lex-word): Use them. (make-cabal-parser): Add TRUE and FALSE tokens. (eval): Add entries for 'true and 'false symbols. --- guix/import/cabal.scm | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 45d644a2c7..8d84e09077 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -138,7 +138,7 @@ (define (make-cabal-parser) "Generate a parser for Cabal files." (lalr-parser ;; --- token definitions - (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION + (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY) (left: OR) (left: PROPERTY AND) @@ -206,6 +206,8 @@ (define (make-cabal-parser) (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ()) (IF tests open exprs close) : `(if ,$2 ,$4 ())) (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) + (TRUE) : 'true + (FALSE) : 'false (TEST OPAREN ID RELATION VERSION CPAREN) : `(,$1 ,(string-append $3 " " $4 " " $5)) (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN) @@ -350,6 +352,10 @@ (define is-else (make-rx-matcher "^else" regexp/icase)) (define (is-if s) (string-ci=? s "if")) +(define (is-true s) (string-ci=? s "true")) + +(define (is-false s) (string-ci=? s "false")) + (define (is-and s) (string=? s "&&")) (define (is-or s) (string=? s "||")) @@ -424,6 +430,10 @@ (define (lex-else loc) (make-lexical-token 'ELSE loc #f)) (define (lex-if loc) (make-lexical-token 'IF loc #f)) +(define (lex-true loc) (make-lexical-token 'TRUE loc #t)) + +(define (lex-false loc) (make-lexical-token 'FALSE loc #f)) + (define (lex-and loc) (make-lexical-token 'AND loc #f)) (define (lex-or loc) (make-lexical-token 'OR loc #f)) @@ -489,6 +499,8 @@ (define (lex-word port loc) (let* ((w (read-delimited " ()\t\n" port 'peek))) (cond ((is-if w) (lex-if loc)) ((is-test w port) (lex-test w loc)) + ((is-true w) (lex-true loc)) + ((is-false w) (lex-false loc)) ((is-and w) (lex-and loc)) ((is-or w) (lex-or loc)) ((is-id w) (lex-id w loc)) @@ -714,6 +726,8 @@ (define (eval sexp) (('os name) (os name)) (('arch name) (arch name)) (('impl name) (impl name)) + ('true #t) + ('false #f) (('not name) (not (eval name))) ;; 'and' and 'or' aren't functions, thus we can't use apply (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args))) -- cgit v1.2.3 From 9be54eb1b1dab6a3e3ea11734f720a5ef703d76b Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Wed, 11 Nov 2015 11:22:42 +0100 Subject: import: hackage: Imporve parsing of tests. * guix/import/cabal.scm (lex-word): Add support for tests with no spaces. (impl): Rewrite. --- guix/import/cabal.scm | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 8d84e09077..ed6394ef6d 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -30,6 +30,7 @@ (define-module (guix import cabal) #:use-module (srfi srfi-9 gnu) #:use-module (system base lalr) #:use-module (rnrs enums) + #:use-module (guix utils) #:export (read-cabal eval-cabal @@ -496,7 +497,7 @@ (define (lex-single-char port loc) (define (lex-word port loc) "Process tokens which can be recognized by reading the next word form PORT. LOC is the current port location." - (let* ((w (read-delimited " ()\t\n" port 'peek))) + (let* ((w (read-delimited " <>=()\t\n" port 'peek))) (cond ((is-if w) (lex-if loc)) ((is-test w port) (lex-test w loc)) ((is-true w) (lex-true loc)) @@ -696,11 +697,18 @@ (define (impl haskell) ((spec-name spec-op spec-ver) (comp-spec-name+op+version haskell))) (if (and spec-ver comp-ver) - (eval-string - (string-append "(string" spec-op " \"" comp-name "\"" - " \"" spec-name "-" spec-ver "\")")) + (cond + ((not (string= spec-name comp-name)) #f) + ((string= spec-op "==") (string= spec-ver comp-ver)) + ((string= spec-op ">=") (version>=? comp-ver spec-ver)) + ((string= spec-op ">") (version>? comp-ver spec-ver)) + ((string= spec-op "<=") (not (version>? comp-ver spec-ver))) + ((string= spec-op "<") (not (version>=? comp-ver spec-ver))) + (else + (raise (condition + (&message (message "Failed to evaluate 'impl' test.")))))) (string-match spec-name comp-name)))) - + (define (cabal-flags) (make-cabal-section cabal-sexp 'flag)) -- cgit v1.2.3 From 876fd23ab6dd03c6d7d5d6b2494fbc0e1c5874ce Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Wed, 11 Nov 2015 15:31:46 +0100 Subject: import: hackage: Make it resilient to missing final newline. * guix/import/cabal.scm (peek-next-line-indent): Check for missing final newline. --- guix/import/cabal.scm | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index ed6394ef6d..63de74af00 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -227,19 +227,24 @@ (define (peek-next-line-indent port) "This function can be called when the next character on PORT is #\newline and returns the indentation of the line starting after the #\newline character. Discard (and consume) empty and comment lines." - (let ((initial-newline (string (read-char port)))) - (let loop ((char (peek-char port)) - (word "")) - (cond ((eqv? char #\newline) (read-char port) - (loop (peek-char port) "")) - ((or (eqv? char #\space) (eqv? char #\tab)) - (let ((c (read-char port))) - (loop (peek-char port) (string-append word (string c))))) - ((comment-line port char) (loop (peek-char port) "")) - (else - (let ((len (string-length word))) - (unread-string (string-append initial-newline word) port) - len)))))) + (if (eof-object? (peek-char port)) + ;; If the file is missing the #\newline on the last line, add it and act + ;; as if it were there. This is needed for proper operation of + ;; indentation based block recognition (based on ‘port-column’). + (begin (unread-char #\newline port) (read-char port) 0) + (let ((initial-newline (string (read-char port)))) + (let loop ((char (peek-char port)) + (word "")) + (cond ((eqv? char #\newline) (read-char port) + (loop (peek-char port) "")) + ((or (eqv? char #\space) (eqv? char #\tab)) + (let ((c (read-char port))) + (loop (peek-char port) (string-append word (string c))))) + ((comment-line port char) (loop (peek-char port) "")) + (else + (let ((len (string-length word))) + (unread-string (string-append initial-newline word) port) + len))))))) (define* (read-value port value min-indent #:optional (separator " ")) "The next character on PORT must be #\newline. Append to VALUE the -- cgit v1.2.3 From 94abc84887ddbb56c0428a4ad783318845fcb281 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Wed, 11 Nov 2015 16:20:45 +0100 Subject: import: hackage: Make parsing of tests and fields more flexible. * guix/import/cabal.scm (is-test): Allow spaces between keyword and parentheses. (is-id): Add argument 'port'. Allow spaces between keyword and column. (lex-word): Adjust call to 'is-id'. --- guix/import/cabal.scm | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 63de74af00..c20e074e18 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -333,7 +333,7 @@ (define* (make-rx-matcher pat #:optional (flag #f)) (make-regexp pat)))) (cut regexp-exec rx <>))) -(define is-property (make-rx-matcher "([a-z0-9-]+):[ \t]*(\\w?.*)$" +(define is-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?.*)$" regexp/icase)) (define is-flag (make-rx-matcher "^flag +([a-z0-9_-]+)" @@ -366,17 +366,24 @@ (define (is-and s) (string=? s "&&")) (define (is-or s) (string=? s "||")) -(define (is-id s) +(define (is-id s port) (let ((cabal-reserved-words '("if" "else" "library" "flag" "executable" "test-suite" - "source-repository" "benchmark"))) + "source-repository" "benchmark")) + (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) + (c (peek-char port))) + (unread-string spaces port) (and (every (cut string-ci<> s <>) cabal-reserved-words) - (not (char=? (last (string->list s)) #\:))))) + (and (not (char=? (last (string->list s)) #\:)) + (not (char=? #\: c)))))) (define (is-test s port) (let ((tests-rx (make-regexp "os|arch|flag|impl")) + (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) - (and (regexp-exec tests-rx s) (char=? #\( c)))) + (if (and (regexp-exec tests-rx s) (char=? #\( c)) + #t + (begin (unread-string spaces port) #f)))) ;; Lexers for individual tokens. @@ -509,7 +516,7 @@ (define (lex-word port loc) ((is-false w) (lex-false loc)) ((is-and w) (lex-and loc)) ((is-or w) (lex-or loc)) - ((is-id w) (lex-id w loc)) + ((is-id w port) (lex-id w loc)) (else (unread-string w port) #f)))) (define (lex-line port loc) -- cgit v1.2.3 From c8be6f0d4a4ad72b1c0673c4cf11a65cd1079d8c Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sat, 14 Nov 2015 15:00:36 +0100 Subject: utils: Add 'canonical-newline-port'. * guix/utils.scm (canonical-newline-port): New procedure. * tests/utils.scm ("canonical-newline-port"): New test. --- guix/utils.scm | 34 ++++++++++++++++++++++++++++++++-- tests/utils.scm | 6 ++++++ 2 files changed, 38 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 1542e86f7a..7b589e68a8 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -29,7 +29,8 @@ (define-module (guix utils) #:use-module (srfi srfi-39) #:use-module (srfi srfi-60) #:use-module (rnrs bytevectors) - #:use-module ((rnrs io ports) #:select (put-bytevector)) + #:use-module (rnrs io ports) + #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module ((guix build utils) #:select (dump-port package-name->name+version)) #:use-module ((guix build syscalls) #:select (errno mkdtemp!)) @@ -90,7 +91,8 @@ (define-module (guix utils) decompressed-port call-with-decompressed-port compressed-output-port - call-with-compressed-output-port)) + call-with-compressed-output-port + canonical-newline-port)) ;;; @@ -746,6 +748,34 @@ (define (absolute target) (if success? (loop (absolute target) (+ depth 1)) file)))))) + +(define (canonical-newline-port port) + "Return an input port that wraps PORT such that all newlines consist + of a single carriage return." + (define (get-position) + (if (port-has-port-position? port) (port-position port) #f)) + (define (set-position! position) + (if (port-has-set-port-position!? port) + (set-port-position! position port) + #f)) + (define (close) (close-port port)) + (define (read! bv start n) + (let loop ((count 0) + (byte (get-u8 port))) + (cond ((eof-object? byte) count) + ((= count (- n 1)) + (bytevector-u8-set! bv (+ start count) byte) + n) + ;; XXX: consume all LFs even if not followed by CR. + ((eqv? byte (char->integer #\return)) (loop count (get-u8 port))) + (else + (bytevector-u8-set! bv (+ start count) byte) + (loop (+ count 1) (get-u8 port)))))) + (make-custom-binary-input-port "canonical-newline-port" + read! + get-position + set-position! + close)) ;;; ;;; Source location. diff --git a/tests/utils.scm b/tests/utils.scm index b65d6d20ba..04a859fc9d 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -318,6 +318,12 @@ (define temp-file (string-append (%store-prefix) "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24"))) +(test-equal "canonical-newline-port" + "This is a journey\nInto the sound\nA journey ...\n" + (let ((port (open-string-input-port + "This is a journey\r\nInto the sound\r\nA journey ...\n"))) + (get-string-all (canonical-newline-port port)))) + (test-end) (false-if-exception (delete-file temp-file)) -- cgit v1.2.3 From 96018e21e7a84c343c1a019fa5c6ef3c15fb24d6 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sat, 14 Nov 2015 15:15:00 +0100 Subject: import: hackage: Handle CRLF end of line style. * guix/import/hackage.scm (hackage-fetch, hackage->guix-package): Use 'canonical-newline-port'. --- guix/import/hackage.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 3baa514aa1..8725ffa0df 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -22,7 +22,8 @@ (define-module (guix import hackage) #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) #:use-module ((guix download) #:select (download-to-store)) - #:use-module ((guix utils) #:select (package-name->name+version)) + #:use-module ((guix utils) #:select (package-name->name+version + canonical-newline-port)) #:use-module (guix import utils) #:use-module (guix import cabal) #:use-module (guix store) @@ -84,7 +85,8 @@ (define (hackage-fetch name-version) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch url temp) - (call-with-input-file temp read-cabal)))))) + (call-with-input-file temp + (compose read-cabal canonical-newline-port))))))) (define string->license ;; List of valid values from @@ -216,7 +218,7 @@ (define* (hackage->guix-package package-name #:key keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" respectively." (let ((cabal-meta (if port - (read-cabal port) + (read-cabal (canonical-newline-port port)) (hackage-fetch package-name)))) (and=> cabal-meta (compose (cut hackage-module->sexp <> #:include-test-dependencies? -- cgit v1.2.3 From d8c66da7c1566f0fb9156ebfe0f4108282fd4a10 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Wed, 25 Nov 2015 14:47:16 +0100 Subject: import: hackage: Assume current 'ghc' package version. * guix/scripts/import/hackage.scm (%default-options): Do it. (ghc-default-version): New variable. --- guix/scripts/import/hackage.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 97d042be3e..4e84278a78 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -19,6 +19,7 @@ (define-module (guix scripts import hackage) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix packages) #:use-module (guix scripts) #:use-module (guix import hackage) #:use-module (guix scripts import) @@ -34,10 +35,13 @@ (define-module (guix scripts import hackage) ;;; Command-line options. ;;; +(define ghc-default-version + (string-append "ghc-" (package-version (@ (gnu packages haskell) ghc)))) + (define %default-options - '((include-test-dependencies? . #t) + `((include-test-dependencies? . #t) (read-from-stdin? . #f) - ('cabal-environment . '()))) + (cabal-environment . ,`(("impl" . ,ghc-default-version))))) (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME -- cgit v1.2.3 From 8a5063f7774c225626224697b5548f2e953c6af4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Nov 2015 23:20:44 +0100 Subject: http-client: 'http-fetch' and 'http-fetch/cached' support HTTPS. * guix/http-client.scm (http-fetch): Use 'open-connection-for-uri', to support HTTPS. --- guix/http-client.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index bee8cdc834..aa873a4353 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -35,7 +35,8 @@ (define-module (guix http-client) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) - #:select (open-socket-for-uri resolve-uri-reference)) + #:select (open-socket-for-uri + open-connection-for-uri resolve-uri-reference)) #:re-export (open-socket-for-uri) #:export (&http-get-error http-get-error? @@ -207,7 +208,7 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t)) Raise an '&http-get-error' condition if downloading fails." (let loop ((uri uri)) - (let ((port (or port (open-socket-for-uri uri)))) + (let ((port (or port (open-connection-for-uri uri)))) (unless buffered? (setvbuf port _IONBF)) (let*-values (((resp data) -- cgit v1.2.3 From 0eef7551303e3fc855809d84eed8421d2a075cfa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 26 Nov 2015 21:52:25 +0100 Subject: Add (guix cve). * guix/cve.scm, tests/cve-sample.xml, tests/cve.scm: New files. * Makefile.am (MODULES): Add guix/cve.scm. (SCM_TESTS): Add tests/cve.scm. (EXTRA_DIST): Add tests/cve-sample.scm. --- Makefile.am | 3 + guix/cve.scm | 177 +++++++++++++++ tests/cve-sample.xml | 616 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/cve.scm | 69 ++++++ 4 files changed, 865 insertions(+) create mode 100644 guix/cve.scm create mode 100644 tests/cve-sample.xml create mode 100644 tests/cve.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 43be2ec89e..245070b033 100644 --- a/Makefile.am +++ b/Makefile.am @@ -51,6 +51,7 @@ MODULES = \ guix/upstream.scm \ guix/licenses.scm \ guix/graph.scm \ + guix/cve.scm \ guix/build-system.scm \ guix/build-system/cmake.scm \ guix/build-system/emacs.scm \ @@ -224,6 +225,7 @@ SCM_TESTS = \ tests/size.scm \ tests/graph.scm \ tests/challenge.scm \ + tests/cve.scm \ tests/file-systems.scm \ tests/services.scm \ tests/containers.scm @@ -312,6 +314,7 @@ EXTRA_DIST = \ tests/test.drv \ tests/signing-key.pub \ tests/signing-key.sec \ + tests/cve-sample.xml \ build-aux/config.rpath \ bootstrap \ release.nix \ diff --git a/guix/cve.scm b/guix/cve.scm new file mode 100644 index 0000000000..a7b0bde6dc --- /dev/null +++ b/guix/cve.scm @@ -0,0 +1,177 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix cve) + #:use-module (guix utils) + #:use-module (guix http-client) + #:use-module (sxml ssax) + #:use-module (web uri) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:export (vulnerability? + vulnerability-id + vulnerability-packages + + xml->vulnerabilities + current-vulnerabilities + vulnerabilities->lookup-proc)) + +;;; Commentary: +;;; +;;; This modules provides the tools to fetch, parse, and digest part of the +;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST +;;; at . +;;; +;;; Code: + +(define-record-type + (vulnerability id packages) + vulnerability? + (id vulnerability-id) + (packages vulnerability-packages)) + +(define %cve-feed-uri + (string->uri + "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-Modified.xml.gz")) + +(define %ttl + ;; According to , feeds are + ;; updated "approximately every two hours." + (* 3600 3)) + +(define (call-with-cve-port proc) + "Pass PROC an input port from which to read the CVE stream." + (let ((port (http-fetch/cached %cve-feed-uri #:ttl %ttl))) + (dynamic-wind + (const #t) + (lambda () + (call-with-decompressed-port 'gzip port + proc)) + (lambda () + (close-port port))))) + +(define %cpe-package-rx + ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION". + (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)")) + +(define (cpe->package-name cpe) + "Converts the Common Platform Enumeration (CPE) string CPE to a package +name, in a very naive way. Return #f if CPE does not look like an application +CPE string." + (and=> (regexp-exec %cpe-package-rx (string-trim-both cpe)) + (lambda (matches) + (cons (match:substring matches 2) + (match:substring matches 3))))) + +(define %parse-vulnerability-feed + ;; Parse the XML vulnerability feed from + ;; and return a list of + ;; vulnerability objects. + (ssax:make-parser NEW-LEVEL-SEED + (lambda (elem-gi attributes namespaces expected-content + seed) + (match elem-gi + ((name-space . 'entry) + (cons (assoc-ref attributes 'id) seed)) + ((name-space . 'vulnerable-software-list) + (cons '() seed)) + ((name-space . 'product) + (cons 'product seed)) + (x seed))) + + FINISH-ELEMENT + (lambda (elem-gi attributes namespaces parent-seed + seed) + (match elem-gi + ((name-space . 'entry) + (match seed + (((? string? id) . rest) + ;; Some entries have no vulnerable-software-list. + rest) + ((products id . rest) + (match (filter-map cpe->package-name products) + (() + ;; No application among PRODUCTS. + rest) + (packages + (cons (vulnerability id (reverse packages)) + rest)))))) + (x + seed))) + + CHAR-DATA-HANDLER + (lambda (str _ seed) + (match seed + (('product software-list . rest) + ;; Add STR to the vulnerable software list this + ;; tag is part of. + (cons (cons str software-list) rest)) + (x x))))) + +(define (xml->vulnerabilities port) + "Read from PORT an XML feed of vulnerabilities and return a list of +vulnerability objects." + (reverse (%parse-vulnerability-feed port '()))) + +(define (current-vulnerabilities) + "Return the current list of Common Vulnerabilities and Exposures (CVE) as +published by the US NIST." + (call-with-cve-port + (lambda (port) + ;; XXX: The SSAX "error port" is used to send pointless warnings such as + ;; "warning: Skipping PI". Turn that off. + (parameterize ((current-ssax-error-port (%make-void-port "w"))) + (xml->vulnerabilities port))))) + +(define (vulnerabilities->lookup-proc vulnerabilities) + "Return a lookup procedure built from VULNERABILITIES that takes a package +name and optionally a version number. When the version is omitted, the lookup +procedure returns a list of version/vulnerability pairs; otherwise, it returns +a list of vulnerabilities affection the given package version." + (define table + ;; Map package names to lists of version/vulnerability pairs. + (fold (lambda (vuln table) + (match vuln + (($ id packages) + (fold (lambda (package table) + (match package + ((name . version) + (vhash-cons name (cons version vuln) + table)))) + table + packages)))) + vlist-null + vulnerabilities)) + + (lambda* (package #:optional version) + (vhash-fold* (if version + (lambda (pair result) + (match pair + ((v . vuln) + (if (string=? v version) + (cons vuln result) + result)))) + cons) + '() + package table))) + +;;; cve.scm ends here diff --git a/tests/cve-sample.xml b/tests/cve-sample.xml new file mode 100644 index 0000000000..ce158490f1 --- /dev/null +++ b/tests/cve-sample.xml @@ -0,0 +1,616 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + cpe:/o:microsoft:windows_2000::sp2:professional + cpe:/o:linux:linux_kernel:2.4.4 + cpe:/o:microsoft:windows_2000_terminal_services::sp1 + cpe:/o:microsoft:windows_2000::sp1:advanced_server + cpe:/o:linux:linux_kernel:2.4.19 + cpe:/o:microsoft:windows_2000::sp2:advanced_server + cpe:/o:microsoft:windows_2000_terminal_services + cpe:/o:microsoft:windows_2000:::advanced_server + cpe:/o:linux:linux_kernel:2.4.20 + cpe:/o:netbsd:netbsd:1.5.1 + cpe:/o:microsoft:windows_2000_terminal_services::sp2 + cpe:/o:netbsd:netbsd:1.5.3 + cpe:/o:netbsd:netbsd:1.5.2 + cpe:/o:linux:linux_kernel:2.4.6 + cpe:/o:linux:linux_kernel:2.4.9 + cpe:/o:microsoft:windows_2000:::datacenter_server + cpe:/o:netbsd:netbsd:1.6 + cpe:/o:netbsd:netbsd:1.5 + cpe:/o:linux:linux_kernel:2.4.7 + cpe:/o:linux:linux_kernel:2.4.8 + cpe:/o:microsoft:windows_2000::sp1:datacenter_server + cpe:/o:microsoft:windows_2000::sp2:datacenter_server + cpe:/o:freebsd:freebsd:4.3 + cpe:/o:linux:linux_kernel:2.4.10 + cpe:/o:microsoft:windows_2000::sp1:server + cpe:/o:freebsd:freebsd:4.5 + cpe:/o:linux:linux_kernel:2.4.12 + cpe:/o:freebsd:freebsd:4.2 + cpe:/o:freebsd:freebsd:4.7 + cpe:/o:freebsd:freebsd:4.4 + cpe:/o:freebsd:freebsd:4.6 + cpe:/o:microsoft:windows_2000::sp2:server + cpe:/o:linux:linux_kernel:2.4.18 + cpe:/o:linux:linux_kernel:2.4.1 + cpe:/o:linux:linux_kernel:2.4.15 + cpe:/o:microsoft:windows_2000:::server + cpe:/o:linux:linux_kernel:2.4.17 + cpe:/o:linux:linux_kernel:2.4.14 + cpe:/o:linux:linux_kernel:2.4.2 + cpe:/o:microsoft:windows_2000:::professional + cpe:/o:linux:linux_kernel:2.4.11 + cpe:/o:linux:linux_kernel:2.4.5 + cpe:/o:linux:linux_kernel:2.4.16 + cpe:/o:microsoft:windows_2000::sp1:professional + cpe:/o:linux:linux_kernel:2.4.13 + cpe:/o:linux:linux_kernel:2.4.3 + + CVE-2003-0001 + 2003-01-17T00:00:00.000-05:00 + 2015-11-24T13:05:47.073-05:00 + + + 5.0 + NETWORK + LOW + NONE + PARTIAL + NONE + NONE + http://nvd.nist.gov + 2015-11-24T12:23:33.593-05:00 + + + + + + CERT-VN + VU#412115 + + + BUGTRAQ + 20150402 NEW : VMSA-2015-0003 VMware product updates address critical information disclosure issue in JRE + + + BUGTRAQ + 20030117 Re: More information regarding Etherleak + + + BUGTRAQ + 20030106 Etherleak: Ethernet frame padding information leakage (A010603-1) + + + REDHAT + RHSA-2003:088 + + + REDHAT + RHSA-2003:025 + + + OSVDB + 9962 + + + CONFIRM + http://www.oracle.com/technetwork/topics/security/cpujan2015-1972971.html + + + MISC + http://www.atstake.com/research/advisories/2003/atstake_etherleak_report.pdf + + + ATSTAKE + A010603-1 + + + FULLDISC + 20150402 NEW : VMSA-2015-0003 VMware product updates address critical information disclosure issue in JRE + + + MISC + http://packetstormsecurity.com/files/131271/VMware-Security-Advisory-2015-0003.html + + + BUGTRAQ + 20030110 More information regarding Etherleak + + + VULNWATCH + 20030110 More information regarding Etherleak + + + + + Multiple ethernet Network Interface Card (NIC) device drivers do not pad frames with null bytes, which allows remote attackers to obtain information from previous packets or kernel memory by using malformed packets, as demonstrated by Etherleak. + + + + + + + + + cpe:/a:tcp:tcp + + CVE-2004-0230 + 2004-08-18T00:00:00.000-04:00 + 2015-11-24T13:06:40.597-05:00 + + + 5.0 + NETWORK + LOW + NONE + NONE + NONE + PARTIAL + http://nvd.nist.gov + 2015-11-24T12:17:30.930-05:00 + + + + + + + + + CERT + TA04-111A + + + CERT-VN + VU#415294 + + + CONFIRM + https://kc.mcafee.com/corporate/index?page=content&id=SB10053 + + + XF + tcp-rst-dos(15886) + + + VUPEN + ADV-2006-3983 + + + MISC + http://www.uniras.gov.uk/vuls/2004/236929/index.htm + + + BID + 10183 + + + BUGTRAQ + 20150402 NEW : VMSA-2015-0003 VMware product updates address critical information disclosure issue in JRE + + + HP + SSRT061264 + + + OSVDB + 4030 + + + CONFIRM + http://www.oracle.com/technetwork/topics/security/cpujan2015-1972971.html + + + MS + MS06-064 + + + MS + MS05-019 + + + CISCO + 20040420 TCP Vulnerabilities in Multiple IOS-Based Cisco Products + + + FULLDISC + 20150402 NEW : VMSA-2015-0003 VMware product updates address critical information disclosure issue in JRE + + + MISC + http://packetstormsecurity.com/files/131271/VMware-Security-Advisory-2015-0003.html + + + HP + SSRT4696 + + + BUGTRAQ + 20040425 Perl code exploting TCP not checking RST ACK. + + + CONFIRM + http://kb.juniper.net/JSA10638 + + + SGI + 20040403-01-A + + + SCO + SCOSA-2005.14 + + + SCO + SCOSA-2005.9 + + + SCO + SCOSA-2005.3 + + + NETBSD + NetBSD-SA2004-006 + + + + + + + + + + + + + + + + + TCP, when using a large Window Size, makes it easier for remote attackers to guess sequence numbers and cause a denial of service (connection loss) to persistent TCP connections by repeatedly injecting a TCP RST packet, especially in protocols that use long-lived connections, such as BGP. + + + + + + + + + + cpe:/a:vastal:phpvid:1.1 + cpe:/a:vastal:phpvid:1.2 + + CVE-2008-2335 + 2008-05-19T09:20:00.000-04:00 + 2015-11-24T11:45:25.057-05:00 + + + 4.3 + NETWORK + MEDIUM + NONE + NONE + PARTIAL + NONE + http://nvd.nist.gov + 2015-11-24T10:50:05.737-05:00 + + + + + XF + phpvid-query-xss(42450) + + + VUPEN + ADV-2008-2552 + + + BID + 29238 + + + MILW0RM + 6422 + + + EXPLOIT-DB + 27519 + + + MISC + http://tetraph.com/security/xss-vulnerability/vastal-i-tech-phpvid-1-2-3-multiple-xss-cross-site-scripting-security-vulnerabilities/ + + + FULLDISC + 20150310 Vastal I-tech phpVID 1.2.3 Multiple XSS (Cross-site Scripting) Security Vulnerabilities + + + MISC + http://packetstormsecurity.com/files/130755/Vastal-I-tech-phpVID-1.2.3-Cross-Site-Scripting.html + + + MISC + http://packetstormsecurity.com/files/122746/PHP-VID-XSS-SQL-Injection-CRLF-Injection.html + + + OSVDB + 45171 + + + MISC + http://holisticinfosec.org/content/view/65/45/ + + Cross-site scripting (XSS) vulnerability in search_results.php in Vastal I-Tech phpVID 1.1 and 1.2 allows remote attackers to inject arbitrary web script or HTML via the query parameter. NOTE: some of these details are obtained from third party information. NOTE: it was later reported that 1.2.3 is also affected. + + + + + + + + + + + + + + cpe:/a:redhat:enterprise_virtualization:3.5 + cpe:/a:jasper_project:jasper:1.900.1 + + CVE-2008-3522 + 2008-10-02T14:18:05.790-04:00 + 2015-11-24T11:46:04.933-05:00 + + + 10.0 + NETWORK + LOW + NONE + COMPLETE + COMPLETE + COMPLETE + http://nvd.nist.gov + 2015-11-24T10:05:46.467-05:00 + + + ALLOWS_ADMIN_ACCESS + + + XF + jasper-jasstreamprintf-bo(45623) + + + UBUNTU + USN-742-1 + + + BID + 31470 + + + MANDRIVA + MDVSA-2009:164 + + + MANDRIVA + MDVSA-2009:144 + + + MANDRIVA + MDVSA-2009:142 + + + GENTOO + GLSA-200812-18 + + + REDHAT + RHSA-2015:0698 + + + MISC + http://bugs.gentoo.org/show_bug.cgi?id=222819 + + + MISC + http://bugs.gentoo.org/attachment.cgi?id=163282&action=view + + Buffer overflow in the jas_stream_printf function in libjasper/base/jas_stream.c in JasPer 1.900.1 might allow context-dependent attackers to have an unknown impact via vectors related to the mif_hdr_put function and use of vsprintf. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + cpe:/o:canonical:ubuntu_linux:10.04::~~lts~~~ + cpe:/o:canonical:ubuntu_linux:8.04:-:lts + cpe:/o:canonical:ubuntu_linux:10.10 + cpe:/a:sun:openoffice.org:2.1.0 + cpe:/a:sun:openoffice.org:2.3.0 + cpe:/a:sun:openoffice.org:2.2.1 + + + CVE-2009-3301 + 2010-02-16T14:30:00.533-05:00 + 2015-11-17T10:59:44.723-05:00 + + + 9.3 + NETWORK + MEDIUM + NONE + COMPLETE + COMPLETE + COMPLETE + http://nvd.nist.gov + 2015-11-17T10:02:50.097-05:00 + + + + + + CERT + TA10-287A + + + CONFIRM + https://bugzilla.redhat.com/show_bug.cgi?id=533038 + + + XF + openoffice-word-sprmtdeftable-bo(56240) + + + VUPEN + ADV-2010-2905 + + + VUPEN + ADV-2010-0635 + + + VUPEN + ADV-2010-0366 + + + UBUNTU + USN-903-1 + + + BID + 38218 + + + REDHAT + RHSA-2010:0101 + + + CONFIRM + http://www.oracle.com/technetwork/topics/security/cpuoct2010-175626.html + + + CONFIRM + http://www.openoffice.org/security/cves/CVE-2009-3301-3302.html + + + CONFIRM + http://www.openoffice.org/security/bulletin.html + + + MANDRIVA + MDVSA-2010:221 + + + GENTOO + GLSA-201408-19 + + + DEBIAN + DSA-1995 + + + SECTRACK + 1023591 + + + SUSE + SUSE-SA:2010:017 + + + + + Integer underflow in filter/ww8/ww8par2.cxx in OpenOffice.org (OOo) before 3.2 allows remote attackers to cause a denial of service (application crash) or possibly execute arbitrary code via a crafted sprmTDefTable table property modifier in a Word document. + + + CVE-2015-8330 + 2015-11-24T15:59:25.897-05:00 + 2015-11-24T15:59:26.930-05:00 + + MISC + https://www.onapsis.com/blog/analyzing-sap-security-notes-november-2015 + + + MISC + http://erpscan.com/advisories/erpscan-15-032-sap-pco-agent-dos-vulnerability/ + + The PCo agent in SAP Plant Connectivity (PCo) allows remote attackers to cause a denial of service (memory corruption and agent crash) via crafted xMII requests, aka SAP Security Note 2238619. + + diff --git a/tests/cve.scm b/tests/cve.scm new file mode 100644 index 0000000000..26bc560e52 --- /dev/null +++ b/tests/cve.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-cve) + #:use-module (guix cve) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define %sample + (search-path %load-path "tests/cve-sample.xml")) + +(define (vulnerability id packages) + (make-struct (@@ (guix cve) ) 0 id packages)) + +(define %expected-vulnerabilities + ;; What we should get when reading %SAMPLE. + (list + ;; CVE-2003-0001 has no "/a" in its product list so it is omitted. + ;; CVE-2004-0230 lists "tcp" as an application, but lacks a version number. + (vulnerability "CVE-2008-2335" '(("phpvid" . "1.1") ("phpvid" . "1.2"))) + (vulnerability "CVE-2008-3522" '(("enterprise_virtualization" . "3.5") + ("jasper" . "1.900.1"))) + (vulnerability "CVE-2009-3301" '(("openoffice.org" . "2.1.0") + ("openoffice.org" . "2.3.0") + ("openoffice.org" . "2.2.1"))) + ;; CVE-2015-8330 has no software list. + )) + + +(test-begin "cve") + +(test-equal "xml->vulnerabilities" + %expected-vulnerabilities + (call-with-input-file %sample xml->vulnerabilities)) + +(test-equal "" + (list `(("1.1" . ,(first %expected-vulnerabilities)) + ("1.2" . ,(first %expected-vulnerabilities))) + '() + '() + (list (second %expected-vulnerabilities)) + (list (third %expected-vulnerabilities))) + (let* ((vulns (call-with-input-file %sample xml->vulnerabilities)) + (lookup (vulnerabilities->lookup-proc vulns))) + (list (lookup "phpvid") + (lookup "jasper" "2.0") + (lookup "foobar") + (lookup "jasper" "1.900.1") + (lookup "openoffice.org" "2.3.0")))) + +(test-end "cve") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 5432734b00ae14c3a93af358fc7bbf80e3db5ee8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 26 Nov 2015 22:59:06 +0100 Subject: lint: Add "cve" checker. Fixes . * guix/scripts/lint.scm (package-name->cpe-name, package-vulnerabilities) (check-vulnerabilities): New procedures. * guix/scripts/lint.scm (%checkers): Add "cve" checker. * tests/lint.scm ("cve", "cve: one vulnerability"): New tests. * doc/guix.texi (Invoking guix lint): Mention it. --- doc/guix.texi | 6 ++++++ guix/scripts/lint.scm | 35 +++++++++++++++++++++++++++++++++++ tests/lint.scm | 17 +++++++++++++++++ 3 files changed, 58 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 058b3598dc..8ecb7ccc17 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4452,6 +4452,12 @@ invalid. Check that the source file name is meaningful, e.g. is not just a version number or ``git-checkout'', and should not have a @code{file-name} declared (@pxref{origin Reference}). +@item cve +Report known vulnerabilities found in the Common Vulnerabilities and +Exposures (CVE) database +@uref{https://nvd.nist.gov/download.cfm#CVE_FEED, published by the US +NIST}. + @item formatting Warn about obvious source code formatting issues: trailing white space, use of tabulations, etc. diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 034f0f95ee..1da4790f2d 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -32,6 +32,7 @@ (define-module (guix scripts lint) #:use-module (guix scripts) #:use-module (guix gnu-maintenance) #:use-module (guix monads) + #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -61,6 +62,7 @@ (define-module (guix scripts lint) check-source check-source-file-name check-license + check-vulnerabilities check-formatting run-checkers @@ -571,6 +573,34 @@ (define (check-license package) (emit-warning package (_ "invalid license field") 'license)))) +(define (package-name->cpe-name name) + "Do a basic conversion of NAME, a Guix package name, to the corresponding +Common Platform Enumeration (CPE) name." + (match name + ("icecat" "firefox") ;or "firefox_esr" + ;; TODO: Add more. + (_ name))) + +(define package-vulnerabilities + (let ((lookup (delay (vulnerabilities->lookup-proc + (current-vulnerabilities))))) + (lambda (package) + "Return a list of vulnerabilities affecting PACKAGE." + ((force lookup) + (package-name->cpe-name (package-name package)) + (package-version package))))) + +(define (check-vulnerabilities package) + "Check for known vulnerabilities for PACKAGE." + (match (package-vulnerabilities package) + (() + #t) + ((vulnerabilities ...) + (emit-warning package + (format #f (_ "probably vulnerable to ~a") + (string-join (map vulnerability-id vulnerabilities) + ", ")))))) + ;;; ;;; Source code formatting. @@ -708,6 +738,11 @@ (define %checkers (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)) + (lint-checker + (name 'cve) + (description "Check the Common Vulnerabilities and Exposures\ + (CVE) database") + (check check-vulnerabilities)) (lint-checker (name 'formatting) (description "Look for formatting issues in the source") diff --git a/tests/lint.scm b/tests/lint.scm index 3f149562d4..50316ade9a 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -512,6 +512,23 @@ (define-syntax-rule (with-warnings body ...) (check-source pkg)))) "not reachable: 404"))) +(test-assert "cve" + (mock ((guix scripts lint) package-vulnerabilities (const '())) + (string-null? + (with-warnings (check-vulnerabilities (dummy-package "x")))))) + +(test-assert "cve: one vulnerability" + (mock ((guix scripts lint) package-vulnerabilities + (lambda (package) + (list (make-struct (@@ (guix cve) ) 0 + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) + (string-contains + (with-warnings + (check-vulnerabilities (dummy-package "pi" (version "3.14")))) + "vulnerable to CVE-2015-1234"))) + (test-assert "formatting: lonely parentheses" (string-contains (with-warnings -- cgit v1.2.3 From ae4427e3f39a32094ced6206ae4bcd12683f9127 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Nov 2015 00:02:23 +0100 Subject: substitute: Warn upon store prefix mismatches. Suggested by Hynek Urban . * guix/scripts/substitute.scm (fetch-narinfos): Move body to... [do-fetch]: ... here. New procedure. Emit a warning when CACHE-INFO's prefix does not match. --- guix/scripts/substitute.scm | 48 +++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 964df9422c..01cc3f129e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -565,31 +565,37 @@ (define (handle-narinfo-response request response port result) (read-to-eof port)) result)))) + (define (do-fetch uri) + (case (and=> uri uri-scheme) + ((http) + (let ((requests (map (cut narinfo-request url <>) paths))) + (update-progress!) + (let ((result (http-multiple-get url + handle-narinfo-response '() + requests))) + (newline (current-error-port)) + result))) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))) + (define cache-info (download-cache-info url)) (and cache-info - (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (let ((uri (string->uri url))) - (case (and=> uri uri-scheme) - ((http) - (let ((requests (map (cut narinfo-request url <>) paths))) - (update-progress!) - (let ((result (http-multiple-get url - handle-narinfo-response '() - requests))) - (newline (current-error-port)) - result))) - ((file #f) - (let* ((base (string-append (uri-path uri) "/")) - (files (map (compose (cut string-append base <> ".narinfo") - store-path-hash-part) - paths))) - (filter-map (cut narinfo-from-file <> url) files))) - (else - (leave (_ "~s: unsupported server URI scheme~%") - (if uri (uri-scheme uri) url))))))) + (if (string=? (cache-info-store-directory cache-info) + (%store-prefix)) + (do-fetch (string->uri url)) + (begin + (warning (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + #f)))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no -- cgit v1.2.3 From 4e70fe4d0efbb29d47e3d83d36d6c15f92baebb0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Nov 2015 16:15:31 +0100 Subject: lint: Do not report already-patched vulnerabilities. * guix/scripts/lint.scm (patch-file-name): New procedure. (check-vulnerabilities): Use it to filter out patched vulnerabilities. * tests/lint.scm ("cve: one patched vulnerability"): New test. --- guix/scripts/lint.scm | 27 +++++++++++++++++++++++---- tests/lint.scm | 17 +++++++++++++++++ 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1da4790f2d..338c7e827d 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -573,6 +573,15 @@ (define (check-license package) (emit-warning package (_ "invalid license field") 'license)))) +(define (patch-file-name patch) + "Return the basename of PATCH's file name, or #f if the file name could not +be determined." + (match patch + ((? string?) + (basename patch)) + ((? origin?) + (and=> (origin-actual-file-name patch) basename)))) + (define (package-name->cpe-name name) "Do a basic conversion of NAME, a Guix package name, to the corresponding Common Platform Enumeration (CPE) name." @@ -596,10 +605,20 @@ (define (check-vulnerabilities package) (() #t) ((vulnerabilities ...) - (emit-warning package - (format #f (_ "probably vulnerable to ~a") - (string-join (map vulnerability-id vulnerabilities) - ", ")))))) + (let* ((patches (filter-map patch-file-name + (or (and=> (package-source package) + origin-patches) + '()))) + (unpatched (remove (lambda (vuln) + (find (cute string-contains + <> (vulnerability-id vuln)) + patches)) + vulnerabilities))) + (unless (null? unpatched) + (emit-warning package + (format #f (_ "probably vulnerable to ~a") + (string-join (map vulnerability-id unpatched) + ", ")))))))) ;;; diff --git a/tests/lint.scm b/tests/lint.scm index 50316ade9a..df82593a9e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -529,6 +529,23 @@ (define-syntax-rule (with-warnings body ...) (check-vulnerabilities (dummy-package "pi" (version "3.14")))) "vulnerable to CVE-2015-1234"))) +(test-assert "cve: one patched vulnerability" + (mock ((guix scripts lint) package-vulnerabilities + (lambda (package) + (list (make-struct (@@ (guix cve) ) 0 + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) + (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package "pi" + (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))) + (test-assert "formatting: lonely parentheses" (string-contains (with-warnings -- cgit v1.2.3 From 471cdfdb193357de7d76600ce6a5dcdbdbba1320 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Nov 2015 21:53:51 +0100 Subject: environment: Set build options early on. This fixes a bug whereby some options, such as #:substitute-urls, would be passed to the daemon too late to have an effect. * guix/scripts/environment.scm (build-inputs): Remove call to 'set-build-options-from-command-line*'. (guix-environment): Add call to 'set-build-options-from-command-line' as early as possible. --- guix/scripts/environment.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index fae261733e..2cc5f366a7 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -294,7 +294,6 @@ (define (build-inputs inputs opts) (if dry-run? (return #f) (mbegin %store-monad - (set-build-options-from-command-line* opts) (built-derivations derivations) (return derivations)))))))) @@ -500,6 +499,7 @@ (define (guix-environment . args) (when container? (assert-container-features)) (with-store store + (set-build-options-from-command-line store opts) (run-with-store store (mlet* %store-monad ((inputs (lower-inputs (map (match-lambda -- cgit v1.2.3 From 841cb43c6b4b7cb6ce328962368c583bc5fdc114 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Nov 2015 17:42:01 +0100 Subject: guix build: Factorize build log query. * guix/scripts/build.scm (show-build-log): New procedure. (guix-build): New variable 'items'. Use it and 'show-build-log'. --- guix/scripts/build.scm | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 644ffe8d6e..b415403473 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -494,6 +494,15 @@ (define new-sources ((head tail ...) (loop tail sources (cons head result)))))) +(define (show-build-log store file urls) + "Show the build log for FILE, falling back to remote logs from URLS if +needed." + (let ((log (or (log-file store file) + (log-url store file #:base-urls urls)))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") file)))) + ;;; ;;; Entry point. @@ -515,9 +524,14 @@ (define (guix-build . args) ;; daemon's substitute URLs. %default-substitute-urls) '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) + (('gc-root . root) root) + (_ #f)) opts))) (set-build-options-from-command-line store opts) @@ -527,22 +541,10 @@ (define (guix-build . args) #:dry-run? (assoc-ref opts 'dry-run?))) (cond ((assoc-ref opts 'log-file?) - (for-each (lambda (file) - (let ((log (or (log-file store file) - (log-url store file - #:base-urls urls)))) - (if log - (format #t "~a~%" log) - (leave (_ "no build log for '~a'~%") - file)))) + (for-each (cut show-build-log store <> urls) (delete-duplicates (append (map derivation-file-name drv) - (filter-map (match-lambda - (('argument - . (? store-path? file)) - file) - (_ #f)) - opts))))) + items)))) ((assoc-ref opts 'derivations-only?) (format #t "~{~a~%~}" (map derivation-file-name drv)) (for-each (cut register-root store <> <>) -- cgit v1.2.3 From 25d188ce12e4e192e4167d03728a8ff69fe0bb35 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Nov 2015 17:46:11 +0100 Subject: http-client: 'http-fetch' converts strings to URIs. * guix/http-client.scm (http-fetch): Use 'string->uri' if URI is a string. Fixes a regression introduced in 8a5063f. --- guix/http-client.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index aa873a4353..eb2c3f4d5f 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -207,7 +207,9 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t)) unbuffered port, suitable for use in `filtered-port'. Raise an '&http-get-error' condition if downloading fails." - (let loop ((uri uri)) + (let loop ((uri (if (string? uri) + (string->uri uri) + uri))) (let ((port (or port (open-connection-for-uri uri)))) (unless buffered? (setvbuf port _IONBF)) -- cgit v1.2.3 From 26059753aea72d0a2bc51204bad9fe416e7c6536 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Nov 2015 22:49:19 +0100 Subject: refresh: Check updater availability at run time. This is a followup to b68d2db, which added a check for updaters at macro-expansion time. The problem is that, when running 'guix pull', Guile-JSON is found, so the PyPi updater (say) is added to %UPDATERS, but then at run time Guile-JSON might be missing. Reported by orbea on #guix. * guix/scripts/refresh.scm (maybe-updater): Rewrite as 'syntax-rules'. Produce code that checks conditions at run time. (list-updaters): Update docstring. --- guix/scripts/refresh.scm | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 8e8a34bd0f..a94bb22a91 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -157,20 +157,21 @@ (define (show-help) ;;; (define-syntax maybe-updater - ;; Helper macro for 'list-udpaters'. - (lambda (s) - (syntax-case s (=>) - ((_ ((module => updater) rest ...) (result ...)) - (let ((met? (false-if-exception - (resolve-interface (syntax->datum #'module))))) - (if met? - #'(maybe-updater (rest ...) - (result ... (@ module updater))) - #'(maybe-updater (rest ...) (result ...))))) - ((_ (updater rest ...) (result ...)) - #'(maybe-updater (rest ...) (result ... updater))) - ((_ () result) - #'result)))) + ;; Helper macro for 'list-updaters'. + (syntax-rules (=>) + ((_ ((module => updater) rest ...) result) + (maybe-updater (rest ...) + (let ((iface (false-if-exception + (resolve-interface 'module))) + (tail result)) + (if iface + (cons (module-ref iface 'updater) tail) + tail)))) + ((_ (updater rest ...) result) + (maybe-updater (rest ...) + (cons updater result))) + ((_ () result) + (reverse result)))) (define-syntax-rule (list-updaters updaters ...) "Expand to '(list UPDATERS ...)' but only the subset of UPDATERS that are @@ -181,11 +182,11 @@ (define-syntax-rule (list-updaters updaters ...) ((SOME MODULE) => UPDATER) meaning that UPDATER is added to the list if and only if (SOME MODULE) could -be resolved at macro expansion time. +be resolved at run time. This is a way to discard at macro expansion time updaters that depend on unavailable optional dependencies such as Guile-JSON." - (maybe-updater (updaters ...) (list))) + (maybe-updater (updaters ...) '())) (define %updaters ;; List of "updaters" used by default. They are consulted in this order. -- cgit v1.2.3 From dedc8320701b3f5d23ccc213c1c0381e00b33785 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Nov 2015 00:08:35 +0100 Subject: gnu: python-2: Honor 'SOURCE_DATE_EPOCH'. * gnu/packages/patches/python-2.7-source-date-epoch.patch: New file. * gnu/packages/python.scm (python-2)[source]: Use it. [arguments]: Set SOURCE_DATE_EPOCH in 'patch-lib-shells' phase. * guix/build/python-build-system.scm (set-SOURCE-DATE-EPOCH): New procedure. (%standard-phases): Add it. * gnu-system.am (dist_patch_DATA): Add patch. --- gnu-system.am | 1 + .../patches/python-2.7-source-date-epoch.patch | 33 ++++++++++++++++++++++ gnu/packages/python.scm | 9 +++++- guix/build/python-build-system.scm | 7 +++++ 4 files changed, 49 insertions(+), 1 deletion(-) create mode 100644 gnu/packages/patches/python-2.7-source-date-epoch.patch (limited to 'guix') diff --git a/gnu-system.am b/gnu-system.am index 1fdbd00731..c7a17a42e9 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -670,6 +670,7 @@ dist_patch_DATA = \ gnu/packages/patches/pybugz-stty.patch \ gnu/packages/patches/pyqt-configure.patch \ gnu/packages/patches/python-2.7-search-paths.patch \ + gnu/packages/patches/python-2.7-source-date-epoch.patch \ gnu/packages/patches/python-3-search-paths.patch \ gnu/packages/patches/python-disable-ssl-test.patch \ gnu/packages/patches/python-fix-tests.patch \ diff --git a/gnu/packages/patches/python-2.7-source-date-epoch.patch b/gnu/packages/patches/python-2.7-source-date-epoch.patch new file mode 100644 index 0000000000..be1f8e010e --- /dev/null +++ b/gnu/packages/patches/python-2.7-source-date-epoch.patch @@ -0,0 +1,33 @@ +Honor the 'SOURCE_DATE_EPOCH' environment variable to allow for +determinitic builds. + +--- a/Lib/py_compile.py ++++ b/Lib/py_compile.py +@@ -105,7 +105,10 @@ def compile(file, cfile=None, dfile=None, doraise=False): + """ + with open(file, 'U') as f: + try: +- timestamp = long(os.fstat(f.fileno()).st_mtime) ++ if 'SOURCE_DATE_EPOCH' in os.environ: ++ timestamp = long(os.environ['SOURCE_DATE_EPOCH']) ++ else: ++ timestamp = long(os.fstat(f.fileno()).st_mtime) + except AttributeError: + timestamp = long(os.stat(file).st_mtime) + codestring = f.read() +diff --git a/Python/import.c b/Python/import.c +index e47ce63..7eecf9c 100644 +--- a/Python/import.c ++++ b/Python/import.c +@@ -945,6 +945,11 @@ write_compiled_module(PyCodeObject *co, char *cpathname, struct stat *srcstat, t + /* Now write the true mtime (as a 32-bit field) */ + fseek(fp, 4L, 0); + assert(mtime <= 0xFFFFFFFF); ++ if (Py_GETENV("SOURCE_DATE_EPOCH") != NULL) { ++ const char *epoch = Py_GETENV("SOURCE_DATE_EPOCH"); ++ mtime = atoi(epoch); ++ } ++ + PyMarshal_WriteLongToFile((long)mtime, fp, Py_MARSHAL_VERSION); + fflush(fp); + fclose(fp); diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 001d00e9be..07725c727a 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -92,7 +92,9 @@ (define-public python-2 (sha256 (base32 "1h7zbrf9pkj29hlm18b10548ch9757f75m64l47sy75rh43p7lqw")) - (patches (list (search-patch "python-2.7-search-paths.patch"))))) + (patches (map search-patch + '("python-2.7-search-paths.patch" + "python-2.7-source-date-epoch.patch"))))) (build-system gnu-build-system) (arguments `(#:tests? #f @@ -158,6 +160,11 @@ (define-public python-2 "Lib/distutils/tests/test_spawn.py" "Lib/test/test_subprocess.py")) (("/bin/sh") (which "sh"))) + + ;; Use zero as the timestamp in .pyc files so that builds are + ;; deterministic. TODO: Remove it when this variable is set in + ;; gnu-build-system.scm. + (setenv "SOURCE_DATE_EPOCH" "0") #t)) (add-before 'check 'pre-check diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 1ae42c00b4..6775cc4396 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -136,11 +136,18 @@ (define* (ensure-no-mtimes-pre-1980 #:rest _) #t)) #t)) +(define* (set-SOURCE-DATE-EPOCH #:rest _) + "Set the 'SOURCE_DATE_EPOCH' environment variable." + ;; Use zero as the timestamp in .pyc files so that builds are deterministic. + ;; TODO: Remove it when this variable is set in GNU:%STANDARD-PHASES. + (setenv "SOURCE_DATE_EPOCH" "0")) + (define %standard-phases ;; 'configure' and 'build' phases are not needed. Everything is done during ;; 'install'. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) + (add-after 'unpack 'set-SOURCE-DATE-EPOCH set-SOURCE-DATE-EPOCH) (delete 'configure) (replace 'install install) (replace 'check check) -- cgit v1.2.3 From a665996f58764a0c6e805016915225f911294989 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Nov 2015 16:52:17 +0100 Subject: gnu: python: Set SOURCE_DATE_EPOCH to 1 instead of 0. * gnu/packages/python.scm (python-2)[arguments]: Set SOURCE_DATE_EPOCH to 1 to match what the daemon does. * guix/build/python-build-system.scm (set-SOURCE-DATE-EPOCH): Likewise. --- gnu/packages/python.scm | 2 +- guix/build/python-build-system.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 07725c727a..7f7fa388a1 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -164,7 +164,7 @@ (define-public python-2 ;; Use zero as the timestamp in .pyc files so that builds are ;; deterministic. TODO: Remove it when this variable is set in ;; gnu-build-system.scm. - (setenv "SOURCE_DATE_EPOCH" "0") + (setenv "SOURCE_DATE_EPOCH" "1") #t)) (add-before 'check 'pre-check diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 6775cc4396..8025b7fec6 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -140,7 +140,7 @@ (define* (set-SOURCE-DATE-EPOCH #:rest _) "Set the 'SOURCE_DATE_EPOCH' environment variable." ;; Use zero as the timestamp in .pyc files so that builds are deterministic. ;; TODO: Remove it when this variable is set in GNU:%STANDARD-PHASES. - (setenv "SOURCE_DATE_EPOCH" "0")) + (setenv "SOURCE_DATE_EPOCH" "1")) (define %standard-phases ;; 'configure' and 'build' phases are not needed. Everything is done during -- cgit v1.2.3 From 0993f9426742bdd7d866bd3afe3bce3658bbe401 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 09:54:07 +0100 Subject: guix package: Remove unnecessary use of (%store). * guix/scripts/package.scm (delete-matching-generations): Use STORE instead of (%store). --- guix/scripts/package.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b1bce7020c..750d2afe47 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -110,7 +110,7 @@ (define (delete-matching-generations store profile pattern) (raise (condition (&profile-not-found-error (profile profile))))) ((string-null? pattern) - (delete-generations (%store) profile + (delete-generations store profile (delv current (profile-generations profile)))) ;; Do not delete the zeroth generation. ((equal? 0 (string->number pattern)) @@ -131,7 +131,7 @@ (define (delete-matching-generations store profile pattern) (let ((numbers (delv current numbers))) (when (null-list? numbers) (leave (_ "no matching generation~%"))) - (delete-generations (%store) profile numbers)))) + (delete-generations store profile numbers)))) (else (leave (_ "invalid syntax: ~a~%") pattern))))) -- cgit v1.2.3 From 2cc10077f31912cc112e81d4d46e79b1c79b1261 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 09:56:28 +0100 Subject: guix package: Move a couple of procedures out of sight. * guix/scripts/package.scm (ensure-default-profile, process-query): New procedures, moved from... (guix-package): ... here. --- guix/scripts/package.scm | 305 +++++++++++++++++++++++------------------------ 1 file changed, 152 insertions(+), 153 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 750d2afe47..cdb3b3acb6 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -94,6 +94,53 @@ (define (user-friendly-profile profile) %user-profile-directory profile)) +(define (ensure-default-profile) + "Ensure the default profile symlink and directory exist and are writable." + + (define (rtfm) + (format (current-error-port) + (_ "Try \"info '(guix) Invoking guix package'\" for \ +more information.~%")) + (exit 1)) + + ;; Create ~/.guix-profile if it doesn't exist yet. + (when (and %user-profile-directory + %current-profile + (not (false-if-exception + (lstat %user-profile-directory)))) + (symlink %current-profile %user-profile-directory)) + + (let ((s (stat %profile-directory #f))) + ;; Attempt to create /…/profiles/per-user/$USER if needed. + (unless (and s (eq? 'directory (stat:type s))) + (catch 'system-error + (lambda () + (mkdir-p %profile-directory)) + (lambda args + ;; Often, we cannot create %PROFILE-DIRECTORY because its + ;; parent directory is root-owned and we're running + ;; unprivileged. + (format (current-error-port) + (_ "error: while creating directory `~a': ~a~%") + %profile-directory + (strerror (system-error-errno args))) + (format (current-error-port) + (_ "Please create the `~a' directory, with you as the owner.~%") + %profile-directory) + (rtfm)))) + + ;; Bail out if it's not owned by the user. + (unless (or (not s) (= (stat:uid s) (getuid))) + (format (current-error-port) + (_ "error: directory `~a' is not owned by you~%") + %profile-directory) + (format (current-error-port) + (_ "Please change the owner of `~a' to user ~s.~%") + %profile-directory (or (getenv "USER") + (getenv "LOGNAME") + (getuid))) + (rtfm)))) + (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. GENERATIONS is a list of generation numbers." @@ -534,6 +581,111 @@ (define absolute (add-indirect-root store absolute)) +(define (process-query opts) + "Process any query specified by OPTS. Return #t when a query was actually +processed, #f otherwise." + (let* ((profiles (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst lst))) + (profile (match profiles + ((head tail ...) head)))) + (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation number) + (unless (zero? number) + (display-generation profile number) + (display-profile-content profile number) + (newline))) + + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each list-generation (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each list-generation numbers))))) + (else + (leave (_ "invalid syntax: ~a~%") + pattern))) + #t) + + (('list-installed regexp) + (let* ((regexp (and regexp (make-regexp* regexp))) + (manifest (profile-manifest profile)) + (installed (manifest-entries manifest))) + (leave-on-EPIPE + (for-each (match-lambda + (($ name version output path _) + (when (or (not regexp) + (regexp-exec regexp name)) + (format #t "~a\t~a\t~a\t~a~%" + name (or version "?") output path)))) + + ;; Show most recently installed packages last. + (reverse installed))) + #t)) + + (('list-available regexp) + (let* ((regexp (and regexp (make-regexp* regexp))) + (available (fold-packages + (lambda (p r) + (let ((n (package-name p))) + (if (supported-package? p) + (if regexp + (if (regexp-exec regexp n) + (cons p r) + r) + (cons p r)) + r))) + '()))) + (leave-on-EPIPE + (for-each (lambda (p) + (format #t "~a\t~a\t~a\t~a~%" + (package-name p) + (package-version p) + (string-join (package-outputs p) ",") + (location->string (package-location p)))) + (sort available + (lambda (p1 p2) + (stringrecutils <> (current-output-port)) + (find-packages-by-description regexp))) + #t)) + + (('show requested-name) + (let-values (((name version) + (package-name->name+version requested-name))) + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + (find-packages-by-name name version))) + #t)) + + (('search-paths kind) + (let* ((manifests (map profile-manifest profiles)) + (entries (append-map manifest-entries manifests)) + (profiles (map user-friendly-profile profiles)) + (settings (search-path-environment-variables entries profiles + (const #f) + #:kind kind))) + (format #t "~{~a~%~}" settings) + #t)) + + (_ #f)))) + ;;; ;;; Entry point. @@ -546,54 +698,6 @@ (define (handle-argument arg result arg-handler) (arg-handler arg result) (leave (_ "~A: extraneous argument~%") arg))) - (define (ensure-default-profile) - ;; Ensure the default profile symlink and directory exist and are - ;; writable. - - (define (rtfm) - (format (current-error-port) - (_ "Try \"info '(guix) Invoking guix package'\" for \ -more information.~%")) - (exit 1)) - - ;; Create ~/.guix-profile if it doesn't exist yet. - (when (and %user-profile-directory - %current-profile - (not (false-if-exception - (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory)) - - (let ((s (stat %profile-directory #f))) - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (and s (eq? 'directory (stat:type s))) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (rtfm)))) - - ;; Bail out if it's not owned by the user. - (unless (or (not s) (= (stat:uid s) (getuid))) - (format (current-error-port) - (_ "error: directory `~a' is not owned by you~%") - %profile-directory) - (format (current-error-port) - (_ "Please change the owner of `~a' to user ~s.~%") - %profile-directory (or (getenv "USER") - (getenv "LOGNAME") - (getuid))) - (rtfm)))) - (define (process-actions opts) ;; Process any install/remove/upgrade action from OPTS. @@ -703,111 +807,6 @@ (define (build-and-use-profile manifest) #:dry-run? dry-run?) (build-and-use-profile new)))))) - (define (process-query opts) - ;; Process any query specified by OPTS. Return #t when a query was - ;; actually processed, #f otherwise. - (let* ((profiles (match (filter-map (match-lambda - (('profile . p) p) - (_ #f)) - opts) - (() (list %current-profile)) - (lst lst))) - (profile (match profiles - ((head tail ...) head)))) - (match (assoc-ref opts 'query) - (('list-generations pattern) - (define (list-generation number) - (unless (zero? number) - (display-generation profile number) - (display-profile-content profile number) - (newline))) - - (cond ((not (file-exists? profile)) ; XXX: race condition - (raise (condition (&profile-not-found-error - (profile profile))))) - ((string-null? pattern) - (for-each list-generation (profile-generations profile))) - ((matching-generations pattern profile) - => - (lambda (numbers) - (if (null-list? numbers) - (exit 1) - (leave-on-EPIPE - (for-each list-generation numbers))))) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) - #t) - - (('list-installed regexp) - (let* ((regexp (and regexp (make-regexp* regexp))) - (manifest (profile-manifest profile)) - (installed (manifest-entries manifest))) - (leave-on-EPIPE - (for-each (match-lambda - (($ name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - - ;; Show most recently installed packages last. - (reverse installed))) - #t)) - - (('list-available regexp) - (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (supported-package? p) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) - '()))) - (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) - (sort available - (lambda (p1 p2) - (stringrecutils <> (current-output-port)) - (find-packages-by-description regexp))) - #t)) - - (('show requested-name) - (let-values (((name version) - (package-name->name+version requested-name))) - (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-name name version))) - #t)) - - (('search-paths kind) - (let* ((manifests (map profile-manifest profiles)) - (entries (append-map manifest-entries manifests)) - (profiles (map user-friendly-profile profiles)) - (settings (search-path-environment-variables entries profiles - (const #f) - #:kind kind))) - (format #t "~{~a~%~}" settings) - #t)) - - (_ #f)))) - (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) (with-error-handling -- cgit v1.2.3 From d1ac5c077522b93414d2ecb1320216046af2f233 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 10:09:33 +0100 Subject: guix package: Move 'build-and-use-profile' out of sight. * guix/scripts/package.scm (build-and-use-profile): New procedure. Adapted and moved from... (guix-package)[process-actions]: ... here. Adjust call sites. --- guix/scripts/package.scm | 101 +++++++++++++++++++++++++---------------------- 1 file changed, 54 insertions(+), 47 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index cdb3b3acb6..12a57efdab 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -182,6 +182,49 @@ (define (delete-matching-generations store profile pattern) (else (leave (_ "invalid syntax: ~a~%") pattern))))) +(define* (build-and-use-profile store profile manifest + #:key + bootstrap? use-substitutes? + dry-run?) + "Build a new generation of PROFILE, a file name, using the packages +specified in MANIFEST, a manifest object." + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (let* ((prof-drv (run-with-store store + (profile-derivation manifest + #:hooks (if bootstrap? + '() + %default-profile-hooks)))) + (prof (derivation->output-path prof-drv))) + (show-what-to-build store (list prof-drv) + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + + (cond + (dry-run? #t) + ((and (file-exists? profile) + (and=> (readlink* profile) (cut string=? prof <>))) + (format (current-error-port) (_ "nothing to be done~%"))) + (else + (let* ((number (generation-number profile)) + + ;; Always use NUMBER + 1 for the new profile, possibly + ;; overwriting a "previous future generation". + (name (generation-file-name profile (+ 1 number)))) + (and (build-derivations store (list prof-drv)) + (let* ((entries (manifest-entries manifest)) + (count (length entries))) + (switch-symlinks name prof) + (switch-symlinks profile name) + (unless (string=? profile %current-profile) + (register-gc-root store name)) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count) + (display-search-paths entries (list profile))))))))) + ;;; ;;; Package specifications. @@ -702,52 +745,10 @@ (define (process-actions opts) ;; Process any install/remove/upgrade action from OPTS. (define dry-run? (assoc-ref opts 'dry-run?)) + (define bootstrap? (assoc-ref opts 'bootstrap?)) + (define substitutes? (assoc-ref opts 'substitutes?)) (define profile (or (assoc-ref opts 'profile) %current-profile)) - (define (build-and-use-profile manifest) - (let* ((bootstrap? (assoc-ref opts 'bootstrap?))) - - (when (equal? profile %current-profile) - (ensure-default-profile)) - - (let* ((prof-drv (run-with-store (%store) - (profile-derivation - manifest - #:hooks (if bootstrap? - '() - %default-profile-hooks)))) - (prof (derivation->output-path prof-drv))) - (show-what-to-build (%store) (list prof-drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - - (cond - (dry-run? #t) - ((and (file-exists? profile) - (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) - (else - (let* ((number (generation-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (generation-file-name profile - (+ 1 number)))) - (and (build-derivations (%store) (list prof-drv)) - (let* ((entries (manifest-entries manifest)) - (count (length entries))) - (switch-symlinks name prof) - (switch-symlinks profile name) - (unless (string=? profile %current-profile) - (register-gc-root (%store) name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) - (display-search-paths entries (list profile)))))))))) - ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) @@ -787,12 +788,15 @@ (define (build-and-use-profile manifest) (user-module (make-user-module '((guix profiles) (gnu)))) (manifest (load* file-name user-module))) - (if (assoc-ref opts 'dry-run?) + (if dry-run? (format #t (_ "would install new manifest from '~a' with ~d entries~%") file-name (length (manifest-entries manifest))) (format #t (_ "installing new manifest from '~a' with ~d entries~%") file-name (length (manifest-entries manifest)))) - (build-and-use-profile manifest))) + (build-and-use-profile (%store) profile manifest + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?))) (else (let* ((manifest (profile-manifest profile)) (install (options->installable opts manifest)) @@ -805,7 +809,10 @@ (define (build-and-use-profile manifest) (unless (and (null? install) (null? remove)) (show-manifest-transaction (%store) manifest transaction #:dry-run? dry-run?) - (build-and-use-profile new)))))) + (build-and-use-profile (%store) profile new + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?)))))) (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) -- cgit v1.2.3 From 590558953b4fb514b8157a48a89bae3af3121fa0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 13:46:31 +0100 Subject: guix package: Formalize the list of actions. * guix/scripts/package.scm (roll-back-action, switch-generation-action) (delete-generations-action, manifest-action): New procedures. (%actions): New variable. * guix/scripts/package.scm (guix-package)[process-action]: Rewrite to traverse %ACTIONS. --- guix/scripts/package.scm | 145 ++++++++++++++++++++++++++--------------------- 1 file changed, 81 insertions(+), 64 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 12a57efdab..6cf0b02ac3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -624,6 +624,11 @@ (define absolute (add-indirect-root store absolute)) + +;;; +;;; Queries and actions. +;;; + (define (process-query opts) "Process any query specified by OPTS. Return #t when a query was actually processed, #f otherwise." @@ -729,6 +734,58 @@ (define (list-generation number) (_ #f)))) + +(define* (roll-back-action store profile arg opts + #:key dry-run?) + "Roll back PROFILE to its previous generation." + (unless dry-run? + (roll-back* store profile))) + +(define* (switch-generation-action store profile spec opts + #:key dry-run?) + "Switch PROFILE to the generation specified by SPEC." + (unless dry-run? + (let* ((number (string->number spec)) + (number (and number + (case (string-ref spec 0) + ((#\+ #\-) + (relative-generation profile number)) + (else number))))) + (if number + (switch-to-generation* profile number) + (leave (_ "cannot switch to generation '~a'~%") spec))))) + +(define* (delete-generations-action store profile pattern opts + #:key dry-run?) + "Delete PROFILE's generations that match PATTERN." + (unless dry-run? + (delete-matching-generations store profile pattern))) + +(define* (manifest-action store profile file opts + #:key dry-run?) + "Change PROFILE to contain the packages specified in FILE." + (let* ((user-module (make-user-module '((guix profiles) (gnu)))) + (manifest (load* file user-module)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (substitutes? (assoc-ref opts 'substitutes?))) + (if dry-run? + (format #t (_ "would install new manifest from '~a' with ~d entries~%") + file (length (manifest-entries manifest))) + (format #t (_ "installing new manifest from '~a' with ~d entries~%") + file (length (manifest-entries manifest)))) + (build-and-use-profile store profile manifest + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?))) + +(define %actions + ;; List of actions that may be processed. The car of each pair is the + ;; action's symbol in the option list; the cdr is the action's procedure. + `((roll-back? . ,roll-back-action) + (switch-generation . ,switch-generation-action) + (delete-generations . ,delete-generations-action) + (manifest . ,manifest-action))) + ;;; ;;; Entry point. @@ -749,70 +806,30 @@ (define bootstrap? (assoc-ref opts 'bootstrap?)) (define substitutes? (assoc-ref opts 'substitutes?)) (define profile (or (assoc-ref opts 'profile) %current-profile)) - ;; First roll back if asked to. - (cond ((and (assoc-ref opts 'roll-back?) - (not dry-run?)) - (roll-back* (%store) profile) - (process-actions (alist-delete 'roll-back? opts))) - ((and (assoc-ref opts 'switch-generation) - (not dry-run?)) - (for-each - (match-lambda - (('switch-generation . pattern) - (let* ((number (string->number pattern)) - (number (and number - (case (string-ref pattern 0) - ((#\+ #\-) - (relative-generation profile number)) - (else number))))) - (if number - (switch-to-generation* profile number) - (leave (_ "cannot switch to generation '~a'~%") - pattern))) - (process-actions (alist-delete 'switch-generation opts))) - (_ #f)) - opts)) - ((and (assoc-ref opts 'delete-generations) - (not dry-run?)) - (for-each - (match-lambda - (('delete-generations . pattern) - (delete-matching-generations (%store) profile pattern) - - (process-actions - (alist-delete 'delete-generations opts))) - (_ #f)) - opts)) - ((assoc-ref opts 'manifest) - (let* ((file-name (assoc-ref opts 'manifest)) - (user-module (make-user-module '((guix profiles) - (gnu)))) - (manifest (load* file-name user-module))) - (if dry-run? - (format #t (_ "would install new manifest from '~a' with ~d entries~%") - file-name (length (manifest-entries manifest))) - (format #t (_ "installing new manifest from '~a' with ~d entries~%") - file-name (length (manifest-entries manifest)))) - (build-and-use-profile (%store) profile manifest - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?))) - (else - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction (install install) - (remove remove))) - (new (manifest-perform-transaction - manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction (%store) manifest transaction - #:dry-run? dry-run?) - (build-and-use-profile (%store) profile new - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?)))))) + ;; First, process roll-backs, generation removals, etc. + (for-each (match-lambda + ((key . arg) + (and=> (assoc-ref %actions key) + (lambda (proc) + (proc (%store) profile arg opts + #:dry-run? dry-run?))))) + opts) + + ;; Then, process normal package installation/removal/upgrade. + (let* ((manifest (profile-manifest profile)) + (install (options->installable opts manifest)) + (remove (options->removable opts manifest)) + (transaction (manifest-transaction (install install) + (remove remove))) + (new (manifest-perform-transaction manifest transaction))) + + (unless (and (null? install) (null? remove)) + (show-manifest-transaction (%store) manifest transaction + #:dry-run? dry-run?) + (build-and-use-profile (%store) profile new + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?)))) (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) -- cgit v1.2.3 From 6e370175065732313c1badd10fc7e3d22de41bec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 21:18:11 +0200 Subject: guix package: Move 'process-actions' out of sight. * guix/scripts/package.scm (process-actions): New procedure, moved from... (guix-package): ... here. Adjust accordingly. --- guix/scripts/package.scm | 68 ++++++++++++++++++++++++------------------------ 1 file changed, 34 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6cf0b02ac3..5f65ed949d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -786,6 +786,39 @@ (define %actions (delete-generations . ,delete-generations-action) (manifest . ,manifest-action))) +(define (process-actions store opts) + "Process any install/remove/upgrade action from OPTS." + + (define dry-run? (assoc-ref opts 'dry-run?)) + (define bootstrap? (assoc-ref opts 'bootstrap?)) + (define substitutes? (assoc-ref opts 'substitutes?)) + (define profile (or (assoc-ref opts 'profile) %current-profile)) + + ;; First, process roll-backs, generation removals, etc. + (for-each (match-lambda + ((key . arg) + (and=> (assoc-ref %actions key) + (lambda (proc) + (proc store profile arg opts + #:dry-run? dry-run?))))) + opts) + + ;; Then, process normal package installation/removal/upgrade. + (let* ((manifest (profile-manifest profile)) + (install (options->installable opts manifest)) + (remove (options->removable opts manifest)) + (transaction (manifest-transaction (install install) + (remove remove))) + (new (manifest-perform-transaction manifest transaction))) + + (unless (and (null? install) (null? remove)) + (show-manifest-transaction store manifest transaction + #:dry-run? dry-run?) + (build-and-use-profile store profile new + #:bootstrap? bootstrap? + #:use-substitutes? substitutes? + #:dry-run? dry-run?)))) + ;;; ;;; Entry point. @@ -798,39 +831,6 @@ (define (handle-argument arg result arg-handler) (arg-handler arg result) (leave (_ "~A: extraneous argument~%") arg))) - (define (process-actions opts) - ;; Process any install/remove/upgrade action from OPTS. - - (define dry-run? (assoc-ref opts 'dry-run?)) - (define bootstrap? (assoc-ref opts 'bootstrap?)) - (define substitutes? (assoc-ref opts 'substitutes?)) - (define profile (or (assoc-ref opts 'profile) %current-profile)) - - ;; First, process roll-backs, generation removals, etc. - (for-each (match-lambda - ((key . arg) - (and=> (assoc-ref %actions key) - (lambda (proc) - (proc (%store) profile arg opts - #:dry-run? dry-run?))))) - opts) - - ;; Then, process normal package installation/removal/upgrade. - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction (install install) - (remove remove))) - (new (manifest-perform-transaction manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction (%store) manifest transaction - #:dry-run? dry-run?) - (build-and-use-profile (%store) profile new - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?)))) - (let ((opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument))) (with-error-handling @@ -844,4 +844,4 @@ (define profile (or (assoc-ref opts 'profile) %current-profile)) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.0))))) - (process-actions opts))))))) + (process-actions (%store) opts))))))) -- cgit v1.2.3 From 27b91d7851859c1c82e891fafc4a326b71fbf88d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 22:00:39 +0200 Subject: guix package: Refactor 'options->installable'. * guix/scripts/package.scm (options->upgrade-predicate) (store-item->manifest-entry): New procedures. * guix/scripts/package.scm (options->installable): Use them. Remove the 'packages-to-upgrade' and 'packages-to-install' variables by getting rid of a level of indirection. --- guix/scripts/package.scm | 119 +++++++++++++++++++++-------------------------- 1 file changed, 54 insertions(+), 65 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5f65ed949d..c62daee9a7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -510,87 +510,76 @@ (define %options %standard-build-options)) -(define (options->installable opts manifest) - "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return the new list of manifest entries." - (define (package->manifest-entry* package output) - (check-package-freshness package) - ;; When given a package via `-e', install the first of its - ;; outputs (XXX). - (package->manifest-entry package output)) - +(define (options->upgrade-predicate opts) + "Return a predicate based on the upgrade/do-not-upgrade regexps in OPTS +that, given a package name, returns true if the package is a candidate for +upgrading, #f otherwise." (define upgrade-regexps (filter-map (match-lambda - (('upgrade . regexp) - (make-regexp* (or regexp ""))) - (_ #f)) + (('upgrade . regexp) + (make-regexp* (or regexp ""))) + (_ #f)) opts)) (define do-not-upgrade-regexps (filter-map (match-lambda - (('do-not-upgrade . regexp) - (make-regexp* regexp)) - (_ #f)) + (('do-not-upgrade . regexp) + (make-regexp* regexp)) + (_ #f)) opts)) - (define packages-to-upgrade - (match upgrade-regexps - (() - '()) - ((_ ...) - (filter-map (match-lambda - (($ name version output path _) - (and (any (cut regexp-exec <> name) - upgrade-regexps) - (not (any (cut regexp-exec <> name) - do-not-upgrade-regexps)) - (upgradeable? name version path) - (let ((output (or output "out"))) - (call-with-values - (lambda () - (specification->package+output name output)) - list)))) - (_ #f)) - (manifest-entries manifest))))) + (lambda (name) + (and (any (cut regexp-exec <> name) upgrade-regexps) + (not (any (cut regexp-exec <> name) do-not-upgrade-regexps))))) + +(define (store-item->manifest-entry item) + "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name." + (let-values (((name version) + (package-name->name+version (store-path-package-name item)))) + (manifest-entry + (name name) + (version version) + (output #f) + (item item)))) + +(define (options->installable opts manifest) + "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', +return the new list of manifest entries." + (define (package->manifest-entry* package output) + (check-package-freshness package) + (package->manifest-entry package output)) + + (define upgrade? + (options->upgrade-predicate opts)) (define to-upgrade - (map (match-lambda - ((package output) - (package->manifest-entry* package output))) - packages-to-upgrade)) + (filter-map (match-lambda + (($ name version output path _) + (and (upgrade? name) + (upgradeable? name version path) + (let ((output (or output "out"))) + (call-with-values + (lambda () + (specification->package+output name output)) + package->manifest-entry*)))) + (_ #f)) + (manifest-entries manifest))) - (define packages-to-install + (define to-install (filter-map (match-lambda - (('install . (? package? p)) - (list p "out")) - (('install . (? string? spec)) - (and (not (store-path? spec)) + (('install . (? package? p)) + ;; When given a package via `-e', install the first of its + ;; outputs (XXX). + (package->manifest-entry* p "out")) + (('install . (? string? spec)) + (if (store-path? spec) + (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (and package (list package output))))) - (_ #f)) + (package->manifest-entry* package output)))) + (_ #f)) opts)) - (define to-install - (append (map (match-lambda - ((package output) - (package->manifest-entry* package output))) - packages-to-install) - (filter-map (match-lambda - (('install . (? package?)) - #f) - (('install . (? store-path? path)) - (let-values (((name version) - (package-name->name+version - (store-path-package-name path)))) - (manifest-entry - (name name) - (version version) - (output #f) - (item path)))) - (_ #f)) - opts))) - (append to-upgrade to-install)) (define (options->removable options manifest) -- cgit v1.2.3 From 64ec0e291209ea6c0fb98204e7b546479c6ab737 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Nov 2015 23:07:35 +0200 Subject: guix build: Modularize transformation handling. * guix/scripts/build.scm (options/resolve-packages): Remove. (options->things-to-build, transform-package-source): New procedure. (%transformations): New variable. (options->transformation): New procedure. (options->derivations): Rewrite to use 'options->things-to-build' and 'options->transformation'. --- guix/scripts/build.scm | 207 ++++++++++++++++++++++++++----------------------- 1 file changed, 111 insertions(+), 96 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index b415403473..192ed5cd45 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -383,9 +383,40 @@ (define %options %standard-build-options)) +(define (options->things-to-build opts) + "Read the arguments from OPTS and return a list of high-level objects to +build---packages, gexps, derivations, and so on." + (define ensure-list + (match-lambda + ((x ...) x) + (x (list x)))) + + (append-map (match-lambda + (('argument . (? string? spec)) + (cond ((derivation-path? spec) + (list (call-with-input-file spec read-derivation))) + ((store-path? spec) + ;; Nothing to do; maybe for --log-file. + '()) + (else + (list (specification->package spec))))) + (('file . file) + (ensure-list (load* file (make-user-module '())))) + (('expression . str) + (ensure-list (read/eval str))) + (('argument . (? derivation? drv)) + drv) + (('argument . (? derivation-path? drv)) + (list )) + (_ '())) + opts)) + (define (options->derivations store opts) "Given OPTS, the result of 'args-fold', return a list of derivations to build." + (define transform + (options->transformation opts)) + (define package->derivation (match (assoc-ref opts 'target) (#f package-derivation) @@ -393,106 +424,90 @@ (define package->derivation (cut package-cross-derivation <> <> triplet <>)))) (define src (assoc-ref opts 'source)) - (define sys (assoc-ref opts 'system)) + (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? graft?)) - (let ((opts (options/with-source store - (options/resolve-packages store opts)))) - (concatenate - (filter-map (match-lambda - (('argument . (? package? p)) - (match src - (#f - (list (package->derivation store p sys))) - (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) - (proc - (map (cut package-source-derivation store <>) - (proc p))))) - (('argument . (? derivation? drv)) - (list drv)) - (('argument . (? derivation-path? drv)) - (list (call-with-input-file drv read-derivation))) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (_ #f)) - opts))))) - -(define (options/resolve-packages store opts) - "Return OPTS with package specification strings replaced by actual -packages." - (define system - (or (assoc-ref opts 'system) (%current-system))) - - (define (object->argument obj) - (match obj - ((? package? p) - `(argument . ,p)) - ((? procedure? proc) - (let ((drv (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - `(argument . ,drv))) - ((? gexp? gexp) - (let ((drv (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system))))) - `(argument . ,drv))))) - - (map (match-lambda - (('argument . (? string? spec)) - (if (store-path? spec) - `(argument . ,spec) - `(argument . ,(specification->package spec)))) - (('file . file) - (object->argument (load* file (make-user-module '())))) - (('expression . str) - (object->argument (read/eval str))) - (opt opt)) - opts)) - -(define (options/with-source store opts) - "Process with 'with-source' options in OPTS, replacing the relevant package -arguments with packages that use the specified source." + (append-map (match-lambda + ((? package? p) + (match src + (#f + (list (package->derivation store p system))) + (#t + (let ((s (package-source p))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)))))) + (transform store (options->things-to-build opts))))) + +(define (transform-package-source sources) + "Return a transformation procedure that uses replaces package sources with +the matching URIs given in SOURCES." (define new-sources - (filter-map (match-lambda - (('with-source . uri) - (cons (package-name->name+version (basename uri)) - uri)) - (_ #f)) - opts)) - - (let loop ((opts opts) - (sources new-sources) - (result '())) - (match opts - (() - (unless (null? sources) - (warning (_ "sources do not match any package:~{ ~a~}~%") - (match sources - (((name . uri) ...) - uri)))) - (reverse result)) - ((('argument . (? package? p)) tail ...) - (let ((source (assoc-ref sources (package-name p)))) - (loop tail - (alist-delete (package-name p) sources) - (alist-cons 'argument - (if source - (package-with-source store p source) - p) - result)))) - ((('with-source . _) tail ...) - (loop tail sources result)) - ((head tail ...) - (loop tail sources (cons head result)))))) + (map (lambda (uri) + (cons (package-name->name+version (basename uri)) + uri)) + sources)) + + (lambda (store packages) + (let loop ((packages packages) + (sources new-sources) + (result '())) + (match packages + (() + (unless (null? sources) + (warning (_ "sources do not match any package:~{ ~a~}~%") + (match sources + (((name . uri) ...) + uri)))) + (reverse result)) + (((? package? p) tail ...) + (let ((source (assoc-ref sources (package-name p)))) + (loop tail + (alist-delete (package-name p) sources) + (cons (if source + (package-with-source store p source) + p) + result)))) + ((thing tail ...) + (loop tail sources result)))))) + +(define %transformations + ;; Transformations that can be applied to things to build. The car is the + ;; key used in the option alist, and the cdr is the transformation + ;; procedure; it is called with two arguments: the store, and a list of + ;; things to build. + `((with-source . ,transform-package-source))) + +(define (options->transformation opts) + "Return a procedure that, when passed a list of things to build (packages, +derivations, etc.), applies the transformations specified by OPTS." + (apply compose + (map (match-lambda + ((key . transform) + (let ((args (filter-map (match-lambda + ((k . arg) + (and (eq? k key) arg))) + opts))) + (if (null? args) + (lambda (store things) things) + (transform args))))) + %transformations))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if -- cgit v1.2.3 From 85dce718cb8acaffa8f961a5784588936147debd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 1 Dec 2015 23:15:19 +0100 Subject: import: pypi: Updater silently ignores packages without source. Reported by Andreas Enge at . * guix/import/pypi.scm (&missing-source-error): New error type. (latest-source-release): Raise it instead of using 'error'. (pypi->guix-package): Guard against it and use 'leave' to report the error. (latest-release): Guard against it and return #f when caught. --- guix/import/pypi.scm | 55 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 7ca0cc991e..d54bb9fbba 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2015 Cyril Roelandt +;;; Copyright © 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,8 @@ (define-module (guix import pypi) #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (json) #:use-module (web uri) @@ -54,6 +57,11 @@ (define (pypi-fetch name) (json-fetch (string-append "https://pypi.python.org/pypi/" name "/json"))))))) +;; For packages found on PyPI that lack a source distribution. +(define-condition-type &missing-source-error &error + missing-source-error? + (package missing-source-error-package)) + (define (latest-source-release pypi-package) "Return the latest source release for PYPI-PACKAGE." (let ((releases (assoc-ref* pypi-package "releases" @@ -61,9 +69,8 @@ (define (latest-source-release pypi-package) (or (find (lambda (release) (string=? "sdist" (assoc-ref release "packagetype"))) releases) - (error "No source release found for pypi package: " - (assoc-ref* pypi-package "info" "name") - (assoc-ref* pypi-package "info" "version"))))) + (raise (condition (&missing-source-error + (package pypi-package))))))) (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the @@ -203,15 +210,20 @@ (define (pypi->guix-package package-name) `package' s-expression corresponding to that package, or #f on failure." (let ((package (pypi-fetch package-name))) (and package - (let ((name (assoc-ref* package "info" "name")) - (version (assoc-ref* package "info" "version")) - (release (assoc-ref (latest-source-release package) "url")) - (synopsis (assoc-ref* package "info" "summary")) - (description (assoc-ref* package "info" "summary")) - (home-page (assoc-ref* package "info" "home_page")) - (license (string->license (assoc-ref* package "info" "license")))) - (make-pypi-sexp name version release home-page synopsis - description license))))) + (guard (c ((missing-source-error? c) + (let ((package (missing-source-error-package c))) + (leave (_ "no source release for pypi package ~a ~a~%") + (assoc-ref* package "info" "name") + (assoc-ref* package "info" "version"))))) + (let ((name (assoc-ref* package "info" "name")) + (version (assoc-ref* package "info" "version")) + (release (assoc-ref (latest-source-release package) "url")) + (synopsis (assoc-ref* package "info" "summary")) + (description (assoc-ref* package "info" "summary")) + (home-page (assoc-ref* package "info" "home_page")) + (license (string->license (assoc-ref* package "info" "license")))) + (make-pypi-sexp name version release home-page synopsis + description license)))))) (define (pypi-package? package) "Return true if PACKAGE is a Python package from PyPI." @@ -230,15 +242,16 @@ (define (pypi-url? url) (define (latest-release guix-package) "Return an for the latest release of GUIX-PACKAGE." - (let* ((pypi-name (guix-package->pypi-name - (specification->package guix-package))) - (metadata (pypi-fetch pypi-name)) - (version (assoc-ref* metadata "info" "version")) - (url (assoc-ref (latest-source-release metadata) "url"))) - (upstream-source - (package guix-package) - (version version) - (urls (list url))))) + (guard (c ((missing-source-error? c) #f)) + (let* ((pypi-name (guix-package->pypi-name + (specification->package guix-package))) + (metadata (pypi-fetch pypi-name)) + (version (assoc-ref* metadata "info" "version")) + (url (assoc-ref (latest-source-release metadata) "url"))) + (upstream-source + (package guix-package) + (version version) + (urls (list url)))))) (define %pypi-updater (upstream-updater -- cgit v1.2.3 From d203d3d4cb3d83beaadaaef6c279c3d84ac142f7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 3 Dec 2015 18:53:01 +0200 Subject: store: Update to the new daemon protocol. * guix/store.scm (%protocol-version): Set minor to 14. (open-connection): Add 'cpu-affinity' parameter and honor it. --- guix/store.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 8413d1f452..89f5df052a 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -129,7 +129,7 @@ (define-module (guix store) direct-store-path log-file)) -(define %protocol-version #x10c) +(define %protocol-version #x10e) (define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-2 #x6478696f) ; "dxio" @@ -328,11 +328,13 @@ (define-condition-type &nix-protocol-error &nix-error (status nix-protocol-error-status)) (define* (open-connection #:optional (file (%daemon-socket-file)) - #:key (reserve-space? #t)) + #:key (reserve-space? #t) cpu-affinity) "Connect to the daemon over the Unix-domain socket at FILE. 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, should the disk become full. Return a server object." +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. When CPU-AFFINITY is true, it must be an integer +corresponding to an OS-level CPU number to which the daemon's worker process +for this connection will be pinned. Return a server object." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0))) @@ -355,8 +357,12 @@ (define* (open-connection #:optional (file (%daemon-socket-file)) (protocol-major v)) (begin (write-int %protocol-version s) - (if (>= (protocol-minor v) 11) - (write-int (if reserve-space? 1 0) s)) + (when (>= (protocol-minor v) 14) + (write-int (if cpu-affinity 1 0) s) + (when cpu-affinity + (write-int cpu-affinity s))) + (when (>= (protocol-minor v) 11) + (write-int (if reserve-space? 1 0) s)) (let ((s (%make-nix-server s (protocol-major v) (protocol-minor v) -- cgit v1.2.3 From 07e70f4846521c1fa5319b25f23eea171a03fccd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 3 Dec 2015 19:08:35 +0200 Subject: store: Add mode parameter to 'build-paths'. * guix/store.scm (%protocol-version): Set minor to 15. (build-mode): New enumerate type. (build-things): Add 'mode' parameter; pass it to the RPC. * tests/store.scm ("build-things, check mode"): New check. --- guix/store.scm | 20 ++++++++++++++++---- tests/store.scm | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 89f5df052a..1818187155 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -53,6 +53,7 @@ (define-module (guix store) nix-protocol-error-status hash-algo + build-mode open-connection close-connection @@ -129,7 +130,7 @@ (define-module (guix store) direct-store-path log-file)) -(define %protocol-version #x10e) +(define %protocol-version #x10f) (define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-2 #x6478696f) ; "dxio" @@ -188,6 +189,12 @@ (define-enumerate-type hash-algo (sha1 2) (sha256 3)) +(define-enumerate-type build-mode + ;; store-api.hh + (normal 0) + (repair 1) + (check 2)) + (define-enumerate-type gc-action ;; store-api.hh (return-live 0) @@ -637,12 +644,17 @@ (define add-to-store (hash-set! cache args path) path)))))) -(define-operation (build-things (string-list things)) - "Build THINGS, a list of store items which may be either '.drv' files or +(define build-things + (let ((build (operation (build-things (string-list things) + (integer mode)) + "Do it!" + boolean))) + (lambda* (store things #:optional (mode (build-mode normal))) + "Build THINGS, a list of store items which may be either '.drv' files or outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Return #t on success." - boolean) + (build store things mode)))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. diff --git a/tests/store.scm b/tests/store.scm index 60d1085f99..72abf2c694 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -756,6 +756,41 @@ (define ref-hash ;; Delete the corrupt item to leave the store in a clean state. (delete-paths s (list file))))))) +(test-assert "build-things, check mode" + (with-store store + (call-with-temporary-output-file + (lambda (entropy entropy-port) + (write (random-text) entropy-port) + (force-output entropy-port) + (let* ((drv (build-expression->derivation + store "non-deterministic" + `(begin + (use-modules (rnrs io ports)) + (let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + (display (call-with-input-file ,entropy + get-string-all) + port))) + #t)) + #:guile-for-build + (package-derivation store %bootstrap-guile (%current-system)))) + (file (derivation->output-path drv))) + (and (build-things store (list (derivation-file-name drv))) + (begin + (write (random-text) entropy-port) + (force-output entropy-port) + (guard (c ((nix-protocol-error? c) + (pk 'determinism-exception c) + (and (not (zero? (nix-protocol-error-status c))) + (string-contains (nix-protocol-error-message c) + "deterministic")))) + ;; This one will produce a different result. Since we're in + ;; 'check' mode, this must fail. + (build-things store (list (derivation-file-name drv)) + (build-mode check)) + #f)))))))) + (test-equal "store-lower" "Lowered." (let* ((add (store-lower text-file)) -- cgit v1.2.3 From 2734cbb89598dbd212d598800bef5a1e649f71f7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Dec 2015 11:32:50 +0200 Subject: store: 'build-things' now supports older daemon protocols. This is a followup to d203d3d. * guix/store.scm (build-things): Add 'build/old'. Use it when STORE's minor version is less than 15. --- guix/store.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 1818187155..98ccbd1004 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -648,13 +648,22 @@ (define build-things (let ((build (operation (build-things (string-list things) (integer mode)) "Do it!" - boolean))) + boolean)) + (build/old (operation (build-things (string-list things)) + "Do it!" + boolean))) (lambda* (store things #:optional (mode (build-mode normal))) "Build THINGS, a list of store items which may be either '.drv' files or outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Return #t on success." - (build store things mode)))) + (if (>= (nix-server-minor-version store) 15) + (build store things mode) + (if (= mode (build-mode normal)) + (build/old store things) + (raise (condition (&nix-protocol-error + (message "unsupported build mode") + (status 1))))))))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. -- cgit v1.2.3 From 4bddf74ef23a515635e3b5787ade3cb39deaf17d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Dec 2015 15:53:31 +0100 Subject: profiles: Silence GTK+ icon theme union. Suggested by Ricardo Wurmus . * guix/profiles.scm (gtk-icon-themes)[build]: Pass 'union-build' a #:log-port argument. --- guix/profiles.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index e8bd564efa..154c8a105f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -658,7 +658,8 @@ (define build ;; Union all the icons. (mkdir-p (string-append #$output "/share")) - (union-build destdir icondirs) + (union-build destdir icondirs + #:log-port (%make-void-port "w")) ;; Update the 'icon-theme.cache' file for each icon theme. (for-each -- cgit v1.2.3 From 2aacd9179ca618fe4f3d568caf2052a47b17cbe6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Dec 2015 15:57:03 +0100 Subject: profiles: Silence GTK+ icon cache creation. Suggested by Ricardo Wurmus . * guix/profiles.scm (gtk-icon-themes)[build]: Pass --quiet to 'gtk-update-icon-cache'. --- guix/profiles.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 154c8a105f..c222f4115d 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -669,7 +669,7 @@ (define build ;; "abiword_48.png". Ignore these. (when (file-is-directory? dir) (ensure-writable-directory dir) - (system* update-icon-cache "-t" dir)))) + (system* update-icon-cache "-t" dir "--quiet")))) (scandir destdir (negate (cut member <> '("." "..")))))))) ;; Don't run the hook when there's nothing to do. -- cgit v1.2.3 From b16dbd1311c9bd1346dcf0d490f25455e12b04cf Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 21 Nov 2015 14:37:54 +0100 Subject: edit: Allow command line arguments in $VISUAL and $EDITOR. * guix/scripts/edit.scm (guix-edit): Fix the assumption that %editor is a one word command. --- guix/scripts/edit.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 73a5bb78d2..660bd57985 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. ;;; @@ -83,8 +84,11 @@ (define (guix-edit . args) (catch 'system-error (lambda () - (apply execlp (%editor) (%editor) - (append-map package->location-specification packages))) + (let ((file-names (append-map package->location-specification + packages))) + ;; Use `system' instead of `exec' in order to sanely handle + ;; possible command line arguments in %EDITOR. + (exit (system (string-join (cons (%editor) file-names)))))) (lambda args (let ((errno (system-error-errno args))) (leave (_ "failed to launch '~a': ~a~%") -- cgit v1.2.3 From cd08fe4259f72815a4b096b2a5ce325e9b445da4 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sat, 21 Nov 2015 15:05:07 +0100 Subject: edit: Don't assume that an emacs daemon is running. * guix/scripts/edit.scm (%editor): Use Emacs as a default value. --- guix/scripts/edit.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 660bd57985..ce3ac4146d 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -49,8 +49,10 @@ (define (show-help) (show-bug-report-information)) (define %editor - (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") - "emacsclient"))) + ;; XXX: It would be better to default to something more likely to be + ;; pre-installed on an average GNU system. Since Nano is not suited for + ;; editing Scheme, Emacs is used instead. + (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") "emacs"))) (define (search-path* path file) "Like 'search-path' but exit if FILE is not found." -- cgit v1.2.3 From b6124f00b86cd2138ed8d50c5ac04aa4d1e7bc82 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 21:48:31 +0100 Subject: gnu-maintenance: Fix URLs returned by 'latest-release' for deep trees. With this, (latest-release "gcc") returns an with URL: ftp://ftp.gnu.org/gnu/gcc/gcc-5.3.0/gcc-5.3.0.tar.gz Previous it would omit "gcc-5.3.0/" from the URL. Fixes a regression introduced in 0a7c5a0. * guix/gnu-maintenance.scm (latest-release)[file->url, file->source]: Add 'directory' parameter. Update users. --- guix/gnu-maintenance.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index e1455ccb98..cd45702628 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -329,11 +329,11 @@ (define patch-directory-name? (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) - (define (file->url file) + (define (file->url directory file) (string-append "ftp://" server directory "/" file)) - (define (file->source file) - (let ((url (file->url file))) + (define (file->source directory file) + (let ((url (file->url directory file))) (upstream-source (package project) (version (tarball->version file)) @@ -362,7 +362,7 @@ (define (file->source file) (releases (filter-map (match-lambda ((file 'file . _) (and (release-file? project file) - (file->source file))) + (file->source directory file))) (_ #f)) entries))) -- cgit v1.2.3 From f00dccf4418af5857223ed9b7932daadb61cd7b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 22:17:43 +0100 Subject: gnu-maintenance: Adjust tarball regexp for IceCat tarballs. * guix/gnu-maintenance.scm (%tarball-rx): Tweak to match IceCat tarball patterns. --- guix/gnu-maintenance.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index cd45702628..54bc6f5d50 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -237,8 +237,10 @@ (define (sans-extension tarball) (substring tarball 0 end))) (define %tarball-rx - ;; Note: .zip files are notably used for freefont-ttf. - (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.(tar\\.|zip$)")) + ;; The .zip extensions is notably used for freefont-ttf. + ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". + ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2". + (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)")) (define %alpha-tarball-rx (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) -- cgit v1.2.3 From fa04a04f18bbab671459ea789fb61da6cd1d74fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 22:18:31 +0100 Subject: gnu-maintenance: Properly handle TeXmacs. * guix/gnu-maintenance.scm (ftp-server/directory): Add comment. (release-file?): Use 'string-ci=?' instead of 'equal?' when comparing project names. --- guix/gnu-maintenance.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 54bc6f5d50..aa3202fd2c 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -222,6 +222,9 @@ (define quirks ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") ("glib" "ftp.gnome.org" "/pub/gnome/sources/glib") ("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls") + + ;; FIXME: ftp.texmacs.org is currently outdated; texmacs.org refers to + ;; its own http URL instead. ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz"))) (match (assoc project quirks) @@ -252,7 +255,10 @@ (define (release-file? project file) (and=> (regexp-exec %tarball-rx file) (lambda (match) ;; Filter out unrelated files, like `guile-www-1.1.1'. - (equal? project (match:substring match 1)))) + ;; Case-insensitive for things like "TeXmacs" vs. "texmacs". + (and=> (match:substring match 1) + (lambda (name) + (string-ci=? name project))))) (not (regexp-exec %alpha-tarball-rx file)) (let ((s (sans-extension file))) (regexp-exec %package-name-rx s)))) -- cgit v1.2.3 From 202440e07a9dd40dc4b9814a91c67e24554d53c1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 22:45:00 +0100 Subject: gnu-maintenance: Add tests for 'release-file?'. * tests/gnu-maintenance.scm: New file. * Makefile.am (SCM_TESTS): Add it. * guix/gnu-maintenance.scm (release-file?): Export. --- Makefile.am | 1 + guix/gnu-maintenance.scm | 1 + tests/gnu-maintenance.scm | 44 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 46 insertions(+) create mode 100644 tests/gnu-maintenance.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 245070b033..4adf39ee05 100644 --- a/Makefile.am +++ b/Makefile.am @@ -199,6 +199,7 @@ SCM_TESTS = \ tests/pk-crypto.scm \ tests/pki.scm \ tests/sets.scm \ + tests/gnu-maintenance.scm \ tests/substitute.scm \ tests/builders.scm \ tests/derivations.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index aa3202fd2c..b3240f82a4 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -50,6 +50,7 @@ (define-module (guix gnu-maintenance) find-packages gnu-package? + release-file? releases latest-release gnu-release-archive-types diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm new file mode 100644 index 0000000000..e7296137dc --- /dev/null +++ b/tests/gnu-maintenance.scm @@ -0,0 +1,44 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-gnu-maintenance) + #:use-module (guix gnu-maintenance) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(test-begin "gnu-maintenance") + +(test-assert "release-file?" + (and (every (lambda (project+file) + (apply release-file? project+file)) + '(("gcc" "gcc-5.3.0.tar.bz2") + ("texmacs" "TeXmacs-1.0.7.9-src.tar.gz") + ("icecat" "icecat-38.4.0-gnu1.tar.bz2") + ("mit-scheme" "mit-scheme-9.2.tar.gz"))) + (every (lambda (project+file) + (not (apply release-file? project+file))) + '(("guile" "guile-www-1.1.1.tar.gz") + ("guile" "guile-2.0.11.tar.gz.sig") + ("mit-scheme" "mit-scheme-9.2-i386.tar.gz") + ("mit-scheme" "mit-scheme-9.2-doc-pdf.tar.gz") + ("gnutls" "gnutls-3.2.18-w32.zip"))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From e3cc793e7c5a71189564f11ce825735b008871b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 22:45:52 +0100 Subject: gnu-maintenance: Do not look for releases in "w32" sub-directories. * guix/gnu-maintenance.scm (latest-release): Filter out "w32" directories. --- guix/gnu-maintenance.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index b3240f82a4..ab9577f4fe 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -354,11 +354,14 @@ (define (file->source directory file) (let* ((entries (ftp-list conn directory)) ;; Filter out sub-directories that do not contain digits---e.g., - ;; /gnuzilla/lang and /gnupg/patches. + ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32" + ;; directories as found on ftp.gnutls.org. (subdirs (filter-map (match-lambda (((? patch-directory-name? dir) 'directory . _) #f) + (("w32" 'directory . _) + #f) (((? contains-digit? dir) 'directory . _) dir) (_ #f)) -- cgit v1.2.3 From fba607b12919b254d75b1e7e9223d712fe2ac32c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 23:10:02 +0100 Subject: refresh: Bail out when asked for a nonexistent updater. * guix/scripts/refresh.scm (lookup-updater): Call 'leave' when 'find' returns #f. --- guix/scripts/refresh.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index a94bb22a91..2341ae6777 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -197,9 +197,10 @@ (define %updaters (define (lookup-updater name) "Return the updater called NAME." - (find (lambda (updater) - (eq? name (upstream-updater-name updater))) - %updaters)) + (or (find (lambda (updater) + (eq? name (upstream-updater-name updater))) + %updaters) + (leave (_ "~a: no such updater~%") name))) (define (list-updaters-and-exit) "Display available updaters and exit." -- cgit v1.2.3 From e946f2ec92c690fde6dd076df594b71be55c96db Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 23:18:06 +0100 Subject: gnu-maintenance: Generalize 'latest-ftp-release'. * guix/gnu-maintenance.scm (latest-release): Rename to... (latest-ftp-release): ... this. Add #:server and #:directory parameters. (latest-release): New procedure. --- guix/gnu-maintenance.scm | 135 ++++++++++++++++++++++++++--------------------- 1 file changed, 74 insertions(+), 61 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index ab9577f4fe..7e990a50a8 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -317,10 +317,14 @@ (define (file->source file) files) result)))))))) -(define* (latest-release project - #:key (ftp-open ftp-open) (ftp-close ftp-close)) - "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f. Use FTP-OPEN and FTP-CLOSE to -open (resp. close) FTP connections; this can be useful to reuse connections." +(define* (latest-ftp-release project + #:key + (server "ftp.gnu.org") + (directory (string-append "/gnu/" project)) + (ftp-open ftp-open) (ftp-close ftp-close)) + "Return an for the latest release of PROJECT on SERVER +under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP +connections; this can be useful to reuse connections." (define (latest a b) (if (version>? a b) a b)) @@ -335,63 +339,72 @@ (define patch-directory-name? ;; Return #t for patch directory names such as 'bash-4.2-patches'. (cut string-suffix? "patches" <>)) - (let-values (((server directory) (ftp-server/directory project))) - (define conn (ftp-open server)) - - (define (file->url directory file) - (string-append "ftp://" server directory "/" file)) - - (define (file->source directory file) - (let ((url (file->url directory file))) - (upstream-source - (package project) - (version (tarball->version file)) - (urls (list url)) - (signature-urls (list (string-append url ".sig")))))) - - (let loop ((directory directory) - (result #f)) - (let* ((entries (ftp-list conn directory)) - - ;; Filter out sub-directories that do not contain digits---e.g., - ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32" - ;; directories as found on ftp.gnutls.org. - (subdirs (filter-map (match-lambda - (((? patch-directory-name? dir) - 'directory . _) - #f) - (("w32" 'directory . _) - #f) - (((? contains-digit? dir) 'directory . _) - dir) - (_ #f)) - entries)) - - ;; Whether or not SUBDIRS is empty, compute the latest releases - ;; for the current directory. This is necessary for packages - ;; such as 'sharutils' that have a sub-directory that contains - ;; only an older release. - (releases (filter-map (match-lambda - ((file 'file . _) - (and (release-file? project file) - (file->source directory file))) - (_ #f)) - entries))) - - ;; Assume that SUBDIRS correspond to versions, and jump into the - ;; one with the highest version number. - (let* ((release (reduce latest-release #f - (coalesce-sources releases))) - (result (if (and result release) - (latest-release release result) - (or release result))) - (target (reduce latest #f subdirs))) - (if target - (loop (string-append directory "/" target) - result) - (begin - (ftp-close conn) - result))))))) + (define conn (ftp-open server)) + + (define (file->url directory file) + (string-append "ftp://" server directory "/" file)) + + (define (file->source directory file) + (let ((url (file->url directory file))) + (upstream-source + (package project) + (version (tarball->version file)) + (urls (list url)) + (signature-urls (list (string-append url ".sig")))))) + + (let loop ((directory directory) + (result #f)) + (let* ((entries (ftp-list conn directory)) + + ;; Filter out sub-directories that do not contain digits---e.g., + ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32" + ;; directories as found on ftp.gnutls.org. + (subdirs (filter-map (match-lambda + (((? patch-directory-name? dir) + 'directory . _) + #f) + (("w32" 'directory . _) + #f) + (((? contains-digit? dir) 'directory . _) + dir) + (_ #f)) + entries)) + + ;; Whether or not SUBDIRS is empty, compute the latest releases + ;; for the current directory. This is necessary for packages + ;; such as 'sharutils' that have a sub-directory that contains + ;; only an older release. + (releases (filter-map (match-lambda + ((file 'file . _) + (and (release-file? project file) + (file->source directory file))) + (_ #f)) + entries))) + + ;; Assume that SUBDIRS correspond to versions, and jump into the + ;; one with the highest version number. + (let* ((release (reduce latest-release #f + (coalesce-sources releases))) + (result (if (and result release) + (latest-release release result) + (or release result))) + (target (reduce latest #f subdirs))) + (if target + (loop (string-append directory "/" target) + result) + (begin + (ftp-close conn) + result)))))) + +(define (latest-release package . rest) + "Return the for the latest version of PACKAGE or #f. +PACKAGE is the name of a GNU package. This procedure automatically uses the +right FTP server and directory for PACKAGE." + (let-values (((server directory) (ftp-server/directory package))) + (apply latest-ftp-release package + #:server server + #:directory directory + rest))) (define (latest-release* package) "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE -- cgit v1.2.3 From e80c0f85ba3429d0a43830247a2212ed93f67d49 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 23:23:46 +0100 Subject: gnu-maintenance: Add GNOME updater. * guix/gnu-maintenance.scm (ftp-server/directory)[quirks]: Remove glib. (false-if-ftp-error): New macro. (latest-release*): Use it. (non-emacs-gnu-package?): Rename to... (pure-gnu-package?): ... this. Add call to 'gnome-package?'. (%gnu-updater): Adjust accordingly. (gnome-package?, latest-gnome-release): New procedures. (%gnome-updater): New variable. * guix/scripts/refresh.scm (%updaters): Add %GNOME-UPDATER. * doc/guix.texi (Invoking guix refresh): Mention it. --- doc/guix.texi | 2 ++ guix/gnu-maintenance.scm | 62 +++++++++++++++++++++++++++++++++++++++--------- guix/scripts/refresh.scm | 4 +++- 3 files changed, 56 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4c525a6476..309548be88 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4342,6 +4342,8 @@ list of updaters). Currently, @var{updater} may be one of: @table @code @item gnu the updater for GNU packages; +@item gnome +the updater for GNOME packages; @item elpa the updater for @uref{http://elpa.gnu.org/, ELPA} packages; @item cran diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 7e990a50a8..5ca2923379 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -56,7 +56,8 @@ (define-module (guix gnu-maintenance) gnu-release-archive-types gnu-package-name->name+version - %gnu-updater)) + %gnu-updater + %gnome-updater)) ;;; Commentary: ;;; @@ -221,7 +222,6 @@ (define quirks ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") ("icecat" "ftp.gnu.org" "/gnu/gnuzilla") ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") - ("glib" "ftp.gnome.org" "/pub/gnome/sources/glib") ("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls") ;; FIXME: ftp.texmacs.org is currently outdated; texmacs.org refers to @@ -406,19 +406,24 @@ (define (latest-release package . rest) #:directory directory rest))) -(define (latest-release* package) - "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE -is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that -name (this is the case for \"emacs-auctex\", for instance.)" +(define-syntax-rule (false-if-ftp-error exp) + "Return #f if an FTP error is raise while evaluating EXP; return the result +of EXP otherwise." (catch 'ftp-error (lambda () - (latest-release package)) + exp) (lambda (key port . rest) (if (ftp-connection? port) (ftp-close port) (close-port port)) #f))) +(define (latest-release* package) + "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE +is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that +name (this is the case for \"emacs-auctex\", for instance.)" + (false-if-ftp-error (latest-release package))) + (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. @@ -431,17 +436,52 @@ (define (gnu-package-name->name+version name+version) (values name+version #f) (values (match:substring match 1) (match:substring match 2))))) -(define (non-emacs-gnu-package? package) - "Return true if PACKAGE is a non-Emacs GNU package. This excludes AucTeX, -for instance, whose releases are now uploaded to elpa.gnu.org." +(define (pure-gnu-package? package) + "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This +excludes AucTeX, for instance, whose releases are now uploaded to +elpa.gnu.org, and all the GNOME packages." (and (not (string-prefix? "emacs-" (package-name package))) + (not (gnome-package? package)) (gnu-package? package))) +(define (gnome-package? package) + "Return true if PACKAGE is a GNOME package, hosted on gnome.org." + (define gnome-uri? + (match-lambda + ((? string? uri) + (string-prefix? "mirror://gnome/" uri)) + (_ + #f))) + + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((? gnome-uri?) #t) + (_ #f))) + (_ #f))) + +(define (latest-gnome-release package) + "Return the latest release of PACKAGE, the name of a GNOME package." + (false-if-ftp-error + (latest-ftp-release package + #:server "ftp.gnome.org" + #:directory (string-append "/pub/gnome/sources/" + (match package + ("gconf" "GConf") + (x x)))))) + (define %gnu-updater (upstream-updater (name 'gnu) (description "Updater for GNU packages") - (pred non-emacs-gnu-package?) + (pred pure-gnu-package?) (latest latest-release*))) +(define %gnome-updater + (upstream-updater + (name 'gnome) + (description "Updater for GNOME packages") + (pred gnome-package?) + (latest latest-gnome-release))) + ;;; gnu-maintenance.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 2341ae6777..a5834d12cc 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -30,7 +30,8 @@ (define-module (guix scripts refresh) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix monads) - #:use-module ((guix gnu-maintenance) #:select (%gnu-updater)) + #:use-module ((guix gnu-maintenance) + #:select (%gnu-updater %gnome-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) #:use-module (guix gnupg) @@ -191,6 +192,7 @@ (define-syntax-rule (list-updaters updaters ...) (define %updaters ;; List of "updaters" used by default. They are consulted in this order. (list-updaters %gnu-updater + %gnome-updater %elpa-updater %cran-updater ((guix import pypi) => %pypi-updater))) -- cgit v1.2.3 From 6efa6f7645a95a08b0d4c663cd4a873eb0003555 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Dec 2015 23:54:35 +0100 Subject: gnu-maintenance: ftp.gnome.org does not provide signatures. * guix/gnu-maintenance.scm (latest-ftp-release): Add #:file->signature parameter. Honor it. (latest-gnome-release): Pass #:file->signature. * guix/upstream.scm (coalesce-sources): Keep 'signature-urls' as #f unless both sources provide it. --- guix/gnu-maintenance.scm | 15 ++++++++++++--- guix/upstream.scm | 5 +++-- 2 files changed, 15 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 5ca2923379..93645367e9 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -321,10 +321,13 @@ (define* (latest-ftp-release project #:key (server "ftp.gnu.org") (directory (string-append "/gnu/" project)) + (file->signature (cut string-append <> ".sig")) (ftp-open ftp-open) (ftp-close ftp-close)) "Return an for the latest release of PROJECT on SERVER under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP -connections; this can be useful to reuse connections." +connections; this can be useful to reuse connections. FILE->SIGNATURE must be +a procedure; it is passed a source file URL and must return the corresponding +signature URL, or #f it signatures are unavailable." (define (latest a b) (if (version>? a b) a b)) @@ -350,7 +353,9 @@ (define (file->source directory file) (package project) (version (tarball->version file)) (urls (list url)) - (signature-urls (list (string-append url ".sig")))))) + (signature-urls (match (file->signature url) + (#f #f) + (sig (list sig))))))) (let loop ((directory directory) (result #f)) @@ -468,7 +473,11 @@ (define (latest-gnome-release package) #:directory (string-append "/pub/gnome/sources/" (match package ("gconf" "GConf") - (x x)))))) + (x x))) + + ;; ftp.gnome.org provides no signatures, only + ;; checksums. + #:file->signature (const #f)))) (define %gnu-updater (upstream-updater diff --git a/guix/upstream.scm b/guix/upstream.scm index 12eed3f2b4..c62667dd01 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -98,8 +98,9 @@ (define (release>? r1 r2) (urls (append (upstream-source-urls release) (upstream-source-urls head))) (signature-urls - (append (upstream-source-signature-urls release) - (upstream-source-signature-urls head)))) + (let ((one (upstream-source-signature-urls release)) + (two (upstream-source-signature-urls release))) + (and one two (append one two))))) tail) (cons release result))) (() -- cgit v1.2.3 From c4991257047f5969946da387cbeee10e2db4e6ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Dec 2015 16:05:55 +0100 Subject: gnu-maintenance: Exclude development releases from GNOME update candidates. Suggested by Efraim Flashner . * guix/gnu-maintenance.scm (latest-ftp-release): Add #:keep-file? parameter and honor it. (latest-gnome-release)[%not-dot]: New variable. [even-minor-version?, even-numbered-tarball?]: New procedures. Pass EVEN-NUMBERED-TARBALL? as #:keep-file? argument. --- guix/gnu-maintenance.scm | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 93645367e9..910270fab1 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -321,13 +321,18 @@ (define* (latest-ftp-release project #:key (server "ftp.gnu.org") (directory (string-append "/gnu/" project)) + (keep-file? (const #t)) (file->signature (cut string-append <> ".sig")) (ftp-open ftp-open) (ftp-close ftp-close)) "Return an for the latest release of PROJECT on SERVER under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP -connections; this can be useful to reuse connections. FILE->SIGNATURE must be -a procedure; it is passed a source file URL and must return the corresponding -signature URL, or #f it signatures are unavailable." +connections; this can be useful to reuse connections. + +KEEP-FILE? is a predicate to decide whether to consider a given file (source +tarball) as a valid candidate based on its name. + +FILE->SIGNATURE must be a procedure; it is passed a source file URL and must +return the corresponding signature URL, or #f it signatures are unavailable." (define (latest a b) (if (version>? a b) a b)) @@ -382,6 +387,7 @@ (define (file->source directory file) (releases (filter-map (match-lambda ((file 'file . _) (and (release-file? project file) + (keep-file? file) (file->source directory file))) (_ #f)) entries))) @@ -467,6 +473,22 @@ (define gnome-uri? (define (latest-gnome-release package) "Return the latest release of PACKAGE, the name of a GNOME package." + (define %not-dot + (char-set-complement (char-set #\.))) + + (define (even-minor-version? version) + (match (string-tokenize (version-major+minor version) + %not-dot) + (((= string->number major) (= string->number minor)) + (even? minor)) + (_ + #t))) ;cross fingers + + (define (even-numbered-tarball? file) + (let-values (((name version) (gnu-package-name->name+version file))) + (and version + (even-minor-version? version)))) + (false-if-ftp-error (latest-ftp-release package #:server "ftp.gnome.org" @@ -475,6 +497,12 @@ (define (latest-gnome-release package) ("gconf" "GConf") (x x))) + + ;; explains + ;; that odd minor version numbers represent development + ;; releases, which we are usually not interested in. + #:keep-file? even-numbered-tarball? + ;; ftp.gnome.org provides no signatures, only ;; checksums. #:file->signature (const #f)))) -- cgit v1.2.3 From 2fba87ac7c3e6fc6ca1a6e94131303c37425b2ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Dec 2015 22:58:32 +0100 Subject: store: Allow clients to request multiple builds. * guix/store.scm (set-build-options): Add #:rounds parameter and honor it. * tests/store.scm ("build multiple times"): New test. --- guix/store.scm | 5 +++++ tests/store.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 45 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 98ccbd1004..3c4d1c0058 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -504,6 +504,7 @@ (define %default-substitute-urls (define* (set-build-options server #:key keep-failed? keep-going? fallback? (verbosity 0) + rounds ;number of build rounds (max-build-jobs 1) timeout (max-silent-time 3600) @@ -549,6 +550,10 @@ (define socket ,@(if substitute-urls `(("substitute-urls" . ,(string-join substitute-urls))) + '()) + ,@(if rounds + `(("build-repeat" + . ,(number->string (max 0 (1- rounds))))) '())))) (send (string-pairs pairs)))) (let loop ((done? (process-stderr server))) diff --git a/tests/store.scm b/tests/store.scm index 72abf2c694..394c06bc0f 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -769,6 +769,8 @@ (define ref-hash (let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) + ;; Rely on the fact that tests do not use the + ;; chroot, and thus ENTROPY is readable. (display (call-with-input-file ,entropy get-string-all) port))) @@ -791,6 +793,44 @@ (define ref-hash (build-mode check)) #f)))))))) +(test-assert "build multiple times" + (with-store store + ;; Ask to build twice. + (set-build-options store #:rounds 2 #:use-substitutes? #f) + + (call-with-temporary-output-file + (lambda (entropy entropy-port) + (write (random-text) entropy-port) + (force-output entropy-port) + (let* ((drv (build-expression->derivation + store "non-deterministic" + `(begin + (use-modules (rnrs io ports)) + (let ((out (assoc-ref %outputs "out"))) + (call-with-output-file out + (lambda (port) + ;; Rely on the fact that tests do not use the + ;; chroot, and thus ENTROPY is accessible. + (display (call-with-input-file ,entropy + get-string-all) + port) + (call-with-output-file ,entropy + (lambda (port) + (write 'foobar port))))) + #t)) + #:guile-for-build + (package-derivation store %bootstrap-guile (%current-system)))) + (file (derivation->output-path drv))) + (guard (c ((nix-protocol-error? c) + (pk 'multiple-build c) + (and (not (zero? (nix-protocol-error-status c))) + (string-contains (nix-protocol-error-message c) + "deterministic")))) + ;; This one will produce a different result on the second run. + (current-build-output-port (current-error-port)) + (build-things store (list (derivation-file-name drv))) + #f)))))) + (test-equal "store-lower" "Lowered." (let* ((add (store-lower text-file)) -- cgit v1.2.3 From 5b74fe065b33ee99372d472f2d6ee5284d720b75 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Dec 2015 23:27:53 +0100 Subject: guix build: Add '--rounds'. * guix/scripts/build.scm (show-build-options-help) (%standard-build-options): Add --rounds. (set-build-options-from-command-line): Honor it. * doc/guix.texi (Invoking guix build): Document it. * doc/contributing.texi (Submitting Patches): Mention it. --- doc/contributing.texi | 26 +++++++++++++++++++++----- doc/guix.texi | 14 ++++++++++++++ guix/scripts/build.scm | 9 +++++++++ 3 files changed, 44 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/contributing.texi b/doc/contributing.texi index a66f5374b9..b61f6a534c 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -279,15 +279,31 @@ not affected by the change; @code{guix refresh --list-dependent @var{package}} will help you do that (@pxref{Invoking guix refresh}). @item +@cindex determinism, of build processes +@cindex reproducible builds, checking Check whether the package's build process is deterministic. This typically means checking whether an independent build of the package yields the exact same result that you obtained, bit for bit. -A simple way to do that is with @command{guix challenge} -(@pxref{Invoking guix challenge}). You may run it once the package has -been committed and built by @code{hydra.gnu.org} to check whether it -obtains the same result as you did. Better yet: Find another machine -that can build it and run @command{guix publish}. +A simple way to do that is by building the same package several times in +a row on your machine (@pxref{Invoking guix build}): + +@example +guix build --rounds=2 my-package +@end example + +This is enough to catch a class of common non-determinism issues, such +as timestamps or randomly-generated output in the build result. + +Another option is to use @command{guix challenge} (@pxref{Invoking guix +challenge}). You may run it once the package has been committed and +built by @code{hydra.gnu.org} to check whether it obtains the same +result as you did. Better yet: Find another machine that can build it +and run @command{guix publish}. Since the remote build machine is +likely different from yours, this can catch non-determinism issues +related to the hardware---e.g., use of different instruction set +extensions---or to the operating system kernel---e.g., reliance on +@code{uname} or @file{/proc} files. @end enumerate diff --git a/doc/guix.texi b/doc/guix.texi index 309548be88..390e7949c0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3876,6 +3876,20 @@ Do not use substitutes for build products. That is, always build things locally instead of allowing downloads of pre-built binaries (@pxref{Substitutes}). +@item --rounds=@var{n} +Build each derivation @var{n} times in a row, and raise an error if +consecutive build results are not bit-for-bit identical. + +This is a useful way to detect non-deterministic builds processes. +Non-deterministic build processes are a problem because they make it +practically impossible for users to @emph{verify} whether third-party +binaries are genuine. @xref{Invoking guix challenge}, for more. + +Note that, currently, the differing build results are not kept around, +so you will have to manually investigate in case of an error---e.g., by +stashing one of the build results with @code{guix archive --export}, +then rebuilding, and finally comparing the two results. + @item --no-build-hook Do not attempt to offload builds @i{via} the daemon's ``build hook'' (@pxref{Daemon Offload Setup}). That is, always build things locally diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 192ed5cd45..072840b953 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -170,6 +170,8 @@ (define (show-build-options-help) --timeout=SECONDS mark the build as failed after SECONDS of activity")) (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) + (display (_ " + --rounds=N build N times in a row to detect non-determinism")) (display (_ " -c, --cores=N allow the use of up to N CPU cores for the build")) (display (_ " @@ -181,6 +183,7 @@ (define (set-build-options-from-command-line store opts) ;; TODO: Add more options. (set-build-options store #:keep-failed? (assoc-ref opts 'keep-failed?) + #:rounds (assoc-ref opts 'rounds) #:build-cores (or (assoc-ref opts 'cores) 0) #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) #:fallback? (assoc-ref opts 'fallback?) @@ -210,6 +213,12 @@ (define %standard-build-options (apply values (alist-cons 'keep-failed? #t result) rest))) + (option '("rounds") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'rounds (string->number* arg) + result) + rest))) (option '("fallback") #f #f (lambda (opt name arg result . rest) (apply values -- cgit v1.2.3 From 58c08df0544bc39b3b5a8f6638f776159b6b8d8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Dec 2015 10:30:03 +0100 Subject: derivations: Determine what's built in 'check' mode. * guix/derivations.scm (substitution-oracle): Add #:mode parameter and honor it. (derivation-prerequisites-to-build): Likewise. [derivation-built?]: Take it into account. * guix/ui.scm (show-what-to-build): Add #:mode parameter. Pass it to 'substitute-oracle' and 'derivations-prerequisites-to-build'. * tests/derivations.scm ("derivation-prerequisites-to-build in 'check' mode"): New test. --- guix/derivations.scm | 23 ++++++++++++++++------- guix/ui.scm | 12 +++++++----- tests/derivations.scm | 20 ++++++++++++++++++++ 3 files changed, 43 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 342a6c83f3..8a0fecaaee 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -239,7 +239,8 @@ (define (derivation-output-paths drv sub-drvs) (derivation-output-path (assoc-ref outputs sub-drv))) sub-drvs)))) -(define* (substitution-oracle store drv) +(define* (substitution-oracle store drv + #:key (mode (build-mode normal))) "Return a one-argument procedure that, when passed a store file name, returns #t if it's substitutable and #f otherwise. The returned procedure knows about all substitutes for all the derivations listed in DRV, *except* @@ -271,9 +272,12 @@ (define (dependencies drv) (let ((self (match (derivation->output-paths drv) (((names . paths) ...) paths)))) - (if (every valid? self) - result - (cons* self (dependencies drv) result)))) + (cond ((eqv? mode (build-mode check)) + (cons (dependencies drv) result)) + ((every valid? self) + result) + (else + (cons* self (dependencies drv) result))))) '() drv)))) (subst (list->set (substitutable-paths store paths)))) @@ -281,11 +285,13 @@ (define (dependencies drv) (define* (derivation-prerequisites-to-build store drv #:key + (mode (build-mode normal)) (outputs (derivation-output-names drv)) (substitutable? (substitution-oracle store - (list drv)))) + (list drv) + #:mode mode))) "Return two values: the list of derivation-inputs required to build the OUTPUTS of DRV and not already available in STORE, recursively, and the list of required store paths that can be substituted. SUBSTITUTABLE? must be a @@ -301,8 +307,11 @@ (define input-substitutable? ;; least one is missing, then everything must be rebuilt. (compose (cut every substitutable? <>) derivation-input-output-paths)) - (define (derivation-built? drv sub-drvs) - (every built? (derivation-output-paths drv sub-drvs))) + (define (derivation-built? drv* sub-drvs) + ;; In 'check' mode, assume that DRV is not built. + (and (not (and (eqv? mode (build-mode check)) + (eq? drv* drv))) + (every built? (derivation-output-paths drv* sub-drvs)))) (define (derivation-substitutable? drv sub-drvs) (and (substitutable-derivation? drv) diff --git a/guix/ui.scm b/guix/ui.scm index 581fb941f5..35a6671a07 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -531,17 +531,18 @@ (define (show-derivation-outputs derivation) (derivation-outputs derivation)))) (define* (show-what-to-build store drv - #:key dry-run? (use-substitutes? #t)) + #:key dry-run? (use-substitutes? #t) + (mode (build-mode normal))) "Show what will or would (depending on DRY-RUN?) be built in realizing the -derivations listed in DRV. Return #t if there's something to build, #f -otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are -available for download." +derivations listed in DRV using MODE, a 'build-mode' value. Return #t if +there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and +report what is prerequisites are available for download." (define substitutable? ;; Call 'substitutation-oracle' upfront so we don't end up launching the ;; substituter many times. This makes a big difference, especially when ;; DRV is a long list as is the case with 'guix environment'. (if use-substitutes? - (substitution-oracle store drv) + (substitution-oracle store drv #:mode mode) (const #f))) (define (built-or-substitutable? drv) @@ -555,6 +556,7 @@ (define (built-or-substitutable? drv) (let-values (((b d) (derivation-prerequisites-to-build store drv + #:mode mode #:substitutable? substitutable?))) (values (append b build) (append d download)))) diff --git a/tests/derivations.scm b/tests/derivations.scm index 9fc96c71ae..1bbc93fe5c 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -670,6 +670,26 @@ (define %coreutils (((? string? item)) (string=? item (derivation->output-path drv)))))))))) +(test-assert "derivation-prerequisites-to-build in 'check' mode" + (with-store store + (let* ((dep (build-expression->derivation store "dep" + `(begin ,(random-text) + (mkdir %output)))) + (drv (build-expression->derivation store "to-check" + '(mkdir %output) + #:inputs `(("dep" ,dep))))) + (build-derivations store (list drv)) + (delete-paths store (list (derivation->output-path dep))) + + ;; In 'check' mode, DEP must be rebuilt. + (and (null? (derivation-prerequisites-to-build store drv)) + (match (derivation-prerequisites-to-build store drv + #:mode (build-mode + check)) + ((input) + (string=? (derivation-input-path input) + (derivation-file-name dep)))))))) + (test-assert "build-expression->derivation with expression returning #f" (let* ((builder '(begin (mkdir %output) -- cgit v1.2.3 From a8d65643fb21fdf6c46b3d248bda411d970e53ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Dec 2015 11:04:57 +0100 Subject: guix build: Add '--check'. * guix/derivations.scm (build-derivations): Add optional 'mode' parameter. * guix/scripts/build.scm (%default-options): Add 'build-mode'. (show-help, %options): Add '--check'. (guix-build): Honor 'build-mode' key of OPTS. Pass it to 'show-what-to-build' and 'build-derivations'. * doc/guix.texi (Invoking guix build): Document it. (Substitutes): Mention it. --- doc/guix.texi | 18 +++++++++++++++++- guix/derivations.scm | 9 ++++++--- guix/scripts/build.scm | 15 +++++++++++++-- 3 files changed, 36 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 390e7949c0..97fddd025e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1638,7 +1638,10 @@ a diverse set of independent package builds, we can strengthen the integrity of our systems. The @command{guix challenge} command aims to help users assess substitute servers, and to assist developers in finding out about non-deterministic package builds (@pxref{Invoking guix -challenge}). +challenge}). Similarly, the @option{--check} option of @command{guix +build} allows users to check whether previously-installed substitutes +are genuine by rebuilding them locally (@pxref{build-check, +@command{guix build --check}}). In the future, we want Guix to have support to publish and retrieve binaries to/from other users, in a peer-to-peer fashion. If you would @@ -3786,6 +3789,19 @@ $ git clone git://git.sv.gnu.org/guix.git $ guix build guix --with-source=./guix @end example +@anchor{build-check} +@item --check +@cindex determinism, checking +@cindex reproducibility, checking +Rebuild @var{package-or-derivation}, which are already available in the +store, and raise an error if the build results are not bit-for-bit +identical. + +This mechanism allows you to check whether previously-installed +substitutes are genuine (@pxref{Substitutes}), or whether a package's +build result is deterministic. @xref{Invoking guix challenge}, for more +background information and tools. + @item --no-grafts Do not ``graft'' packages. In practice, this means that package updates available as grafts are not applied. @xref{Security Updates}, for more diff --git a/guix/derivations.scm b/guix/derivations.scm index 8a0fecaaee..5db739a97d 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -972,13 +972,16 @@ (define rewritten-input ;;; Store compatibility layer. ;;; -(define (build-derivations store derivations) - "Build DERIVATIONS, a list of objects or .drv file names." +(define* (build-derivations store derivations + #:optional (mode (build-mode normal))) + "Build DERIVATIONS, a list of objects or .drv file names, using +the specified MODE." (build-things store (map (match-lambda ((? string? file) file) ((and drv ($ )) (derivation-file-name drv))) - derivations))) + derivations) + mode)) ;;; diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 072840b953..8ecd9560ed 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -285,6 +285,7 @@ (define %standard-build-options (define %default-options ;; Alist of default option values. `((system . ,(%current-system)) + (build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -316,6 +317,8 @@ (define (show-help) --no-grafts do not graft packages")) (display (_ " -d, --derivations return the derivation paths of the given packages")) + (display (_ " + --check rebuild items to check for non-determinism issues")) (display (_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) @@ -356,6 +359,12 @@ (define %options (leave (_ "invalid argument: '~a' option argument: ~a, ~ must be one of 'package', 'all', or 'transitive'~%") name arg))))) + (option '("check") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-mode (build-mode check) + result) + rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -540,6 +549,7 @@ (define (guix-build . args) (let* ((opts (parse-command-line args %options (list %default-options))) (store (open-connection)) + (mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") (if (assoc-ref opts 'substitutes?) @@ -562,7 +572,8 @@ (define (guix-build . args) (unless (assoc-ref opts 'log-file?) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?))) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) (cond ((assoc-ref opts 'log-file?) (for-each (cut show-build-log store <> urls) @@ -575,7 +586,7 @@ (define (guix-build . args) (map (compose list derivation-file-name) drv) roots)) ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv) + (and (build-derivations store drv mode) (for-each show-derivation-outputs drv) (for-each (cut register-root store <> <>) (map (lambda (drv) -- cgit v1.2.3 From 873d0ff2cddfbd260e8ae3a76cb2731a6139eb6b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Dec 2015 21:59:32 +0100 Subject: gnu-maintenance: Really find the latest GNOME releases. Reported by Efraim Flashner at . * guix/gnu-maintenance.scm (latest-ftp-release): Call KEEP-FILE? on directories too. (latest-gnome-release)[even-minor-version?]: Protect again MINOR being false; change pattern to match VERSION with two or more numbers. Remove use of 'version-major+minor'. [even-numbered-tarball?]: Rename to... [even-numbered?]: ... this. Use 'package-name->name+version'. When VERSION is #f, check NAME. --- guix/gnu-maintenance.scm | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 910270fab1..96fbfb76b4 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -328,8 +328,8 @@ (define* (latest-ftp-release project under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be useful to reuse connections. -KEEP-FILE? is a predicate to decide whether to consider a given file (source -tarball) as a valid candidate based on its name. +KEEP-FILE? is a predicate to decide whether to enter a directory and to +consider a given file (source tarball) as a valid candidate based on its name. FILE->SIGNATURE must be a procedure; it is passed a source file URL and must return the corresponding signature URL, or #f it signatures are unavailable." @@ -376,7 +376,7 @@ (define (file->source directory file) (("w32" 'directory . _) #f) (((? contains-digit? dir) 'directory . _) - dir) + (and (keep-file? dir) dir)) (_ #f)) entries)) @@ -477,17 +477,18 @@ (define %not-dot (char-set-complement (char-set #\.))) (define (even-minor-version? version) - (match (string-tokenize (version-major+minor version) - %not-dot) - (((= string->number major) (= string->number minor)) - (even? minor)) + (match (string-tokenize version %not-dot) + (((= string->number major) (= string->number minor) . rest) + (and minor (even? minor))) (_ #t))) ;cross fingers - (define (even-numbered-tarball? file) - (let-values (((name version) (gnu-package-name->name+version file))) - (and version - (even-minor-version? version)))) + (define (even-numbered? file) + ;; Return true if FILE somehow denotes an even-numbered file name. The + ;; trick here is that we want this to match both directories such as + ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2". + (let-values (((name version) (package-name->name+version file))) + (even-minor-version? (or version name)))) (false-if-ftp-error (latest-ftp-release package @@ -501,7 +502,7 @@ (define (even-numbered-tarball? file) ;; explains ;; that odd minor version numbers represent development ;; releases, which we are usually not interested in. - #:keep-file? even-numbered-tarball? + #:keep-file? even-numbered? ;; ftp.gnome.org provides no signatures, only ;; checksums. -- cgit v1.2.3 From b6a222757bfebdbf3b907b39f1c3b42967aaa915 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 3 Dec 2015 15:00:43 +0100 Subject: import: cran: Match more license strings. * guix/import/cran.scm (string->license): Match more license strings to license symbols. --- guix/import/cran.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 4b53d5e2c2..43dc2c80b6 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -51,12 +51,18 @@ (define string->license ("Apache License 2.0" 'asl2.0) ("BSD_2_clause" 'bsd-2) ("BSD_3_clause" 'bsd-3) + ("GPL" (list 'gpl2+ 'gpl3+)) + ("GPL (>= 2)" 'gpl2+) + ("GPL (>= 3)" 'gpl3+) ("GPL-2" 'gpl2+) ("GPL-3" 'gpl3+) ("LGPL-2" 'lgpl2.0+) ("LGPL-2.1" 'lgpl2.1+) ("LGPL-3" 'lgpl3+) + ("LGPL (>= 2)" 'lgpl2.0+) + ("LGPL (>= 3)" 'lgpl3+) ("MIT" 'x11) + ("MIT + file LICENSE" 'x11) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) (_ #f))) -- cgit v1.2.3 From 0f6b9e9828dfc269bfc4eade771efed1753e8c62 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 3 Dec 2015 16:12:09 +0100 Subject: import: cran: Parse DESCRIPTION instead of HTML. * guix/import/cran.scm (description->alist, listify, beautify-description, description->package): New procedures. (table-datum, downloads->url, nodes->text, cran-sxml->sexp): Remove proceduces. (latest-release): Use parsed DESCRIPTION instead of SXML. * tests/cran.scm: Rewrite to match importer. --- guix/import/cran.scm | 265 +++++++++++++++++++++++++-------------------------- tests/cran.scm | 189 +++++++++++++++--------------------- 2 files changed, 209 insertions(+), 245 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 43dc2c80b6..845ecb5832 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -20,26 +20,26 @@ (define-module (guix import cran) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module ((ice-9 rdelim) #:select (read-string)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:use-module (sxml simple) - #:use-module (sxml match) - #:use-module (sxml xpath) #:use-module (guix http-client) #:use-module (guix hash) #:use-module (guix store) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) + #:use-module ((guix build-system r) #:select (cran-uri)) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (gnu packages) #:export (cran->guix-package %cran-updater)) ;;; Commentary: ;;; ;;; Generate a package declaration template for the latest version of an R -;;; package on CRAN, using the HTML description downloaded from +;;; package on CRAN, using the DESCRIPTION file downloaded from ;;; cran.r-project.org. ;;; ;;; Code: @@ -67,6 +67,31 @@ (define string->license ((lst ...) `(list ,@(map string->license lst))) (_ #f))) + +(define (description->alist description) + "Convert a DESCRIPTION string into an alist." + (let ((lines (string-split description #\newline)) + (parse (lambda (line acc) + (if (string-null? line) acc + ;; Keys usually start with a capital letter and end with + ;; ":". There are some exceptions, unfortunately (such + ;; as "biocViews"). There are no blanks in a key. + (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line) + ;; New key/value pair + (let* ((pos (string-index line #\:)) + (key (string-take line pos)) + (value (string-drop line (+ 1 pos)))) + (cons (cons key + (string-trim-both value)) + acc)) + ;; This is a continuation of the previous pair + (match-let ((((key . value) . rest) acc)) + (cons (cons key (string-join + (list value + (string-trim-both line)))) + rest))))))) + (fold parse '() lines))) + (define (format-inputs names) "Generate a sorted list of package inputs from a list of package NAMES." (map (lambda (name) @@ -82,125 +107,94 @@ (define* (maybe-inputs package-inputs #:optional (type 'inputs)) ((package-inputs ...) `((,type (,'quasiquote ,(format-inputs package-inputs))))))) -(define (table-datum tree label) - "Extract the datum node following a LABEL in the sxml table TREE. Only the -first cell of a table row is considered a label cell." - ((node-pos 1) - ((sxpath `(xhtml:tr - (xhtml:td 1) ; only first cell can contain label - (equal? ,label) - ,(node-parent tree) ; go up to label cell - ,(node-parent tree) ; go up to matching row - (xhtml:td 2))) ; select second cell - tree))) - (define %cran-url "http://cran.r-project.org/web/packages/") (define (cran-fetch name) - "Return an sxml representation of the CRAN page for the R package NAME, -or #f on failure. NAME is case-sensitive." + "Return an alist of the contents of the DESCRIPTION file for the R package +NAME, or #f on failure. NAME is case-sensitive." ;; This API always returns the latest release of the module. - (let ((cran-url (string-append %cran-url name "/"))) - (false-if-exception - (xml->sxml (http-fetch cran-url) - #:trim-whitespace? #t - #:namespaces '((xhtml . "http://www.w3.org/1999/xhtml")) - #:default-entity-handler - (lambda (port name) - (case name - ((nbsp) " ") - ((ge) ">=") - ((gt) ">") - ((lt) "<") - (else - (format (current-warning-port) - "~a:~a:~a: undefined entitity: ~a\n" - cran-url (port-line port) (port-column port) - name) - (symbol->string name)))))))) - -(define (downloads->url downloads) - "Extract from DOWNLOADS, the downloads item of the CRAN sxml tree, the -download URL." - (string-append "mirror://cran/" - ;; Remove double dots, because we want an - ;; absolute path. - (regexp-substitute/global - #f "\\.\\./" - (string-join ((sxpath '((xhtml:a 1) @ href *text*)) - (table-datum downloads " Package source: "))) - 'pre 'post))) - -(define (nodes->text nodeset) - "Return the concatenation of the text nodes among NODESET." - (string-join ((sxpath '(// *text*)) nodeset) " ")) - -(define (cran-sxml->sexp sxml) - "Return the `package' s-expression for a CRAN package from the SXML -representation of the package page." + (let ((url (string-append %cran-url name "/DESCRIPTION"))) + (description->alist (read-string (http-fetch url))))) + +(define (listify meta field) + "Look up FIELD in the alist META. If FIELD contains a comma-separated +string, turn it into a list and strip off parenthetic expressions. Return the +empty list when the FIELD cannot be found." + (let ((value (assoc-ref meta field))) + (if (not value) + '() + ;; Strip off parentheses + (let ((items (string-split (regexp-substitute/global + #f "( *\\([^\\)]+\\)) *" + value 'pre 'post) + #\,))) + ;; When there is whitespace inside of items it is probably because + ;; this was not an actual list to begin with. + (remove (cut string-any char-set:whitespace <>) + (map string-trim-both items)))))) + +(define (beautify-description description) + "Improve the package DESCRIPTION by turning a beginning sentence fragment +into a proper sentence and by using two spaces between sentences." + (let ((cleaned (if (string-prefix? "A " description) + (string-append "This package provides a" + (substring description 1)) + description))) + ;; Use double spacing between sentences + (regexp-substitute/global #f "\\. \\b" + cleaned 'pre ". " 'post))) + +(define (description->package meta) + "Return the `package' s-expression for a CRAN package from the alist META, +which was derived from the R package's DESCRIPTION file." (define (guix-name name) (if (string-prefix? "r-" name) (string-downcase name) (string-append "r-" (string-downcase name)))) - (sxml-match-let* - (((*TOP* (xhtml:html - ,head - (xhtml:body - (xhtml:h2 ,name-and-synopsis) - (xhtml:p ,description) - ,summary - (xhtml:h4 "Downloads:") ,downloads - . ,rest))) - sxml)) - (let* ((name (match:prefix (string-match ": " name-and-synopsis))) - (synopsis (match:suffix (string-match ": " name-and-synopsis))) - (version (nodes->text (table-datum summary "Version:"))) - (license ((compose string->license nodes->text) - (table-datum summary "License:"))) - (home-page (nodes->text ((sxpath '((xhtml:a 1))) - (table-datum summary "URL:")))) - (source-url (downloads->url downloads)) - (tarball (with-store store (download-to-store store source-url))) - (sysdepends (map match:substring - (list-matches - "[^ ]+" - ;; Strip off comma and parenthetical - ;; expressions. - (regexp-substitute/global - #f "(,|\\([^\\)]+\\))" - (nodes->text (table-datum summary - "SystemRequirements:")) - 'pre 'post)))) - (imports (map guix-name - ((sxpath '(// xhtml:a *text*)) - (table-datum summary "Imports:"))))) - `(package - (name ,(guix-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (cran-uri ,name version)) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - (build-system r-build-system) - ,@(maybe-inputs sysdepends) - ,@(maybe-inputs imports 'propagated-inputs) - (home-page ,(if (string-null? home-page) - (string-append %cran-url name) - home-page)) - (synopsis ,synopsis) - ;; Use double spacing - (description ,(regexp-substitute/global #f "\\. \\b" description - 'pre ". " 'post)) - (license ,license))))) + (let* ((name (assoc-ref meta "Package")) + (synopsis (assoc-ref meta "Title")) + (version (assoc-ref meta "Version")) + (license (string->license (assoc-ref meta "License"))) + ;; Some packages have multiple home pages. Some have none. + (home-page (match (listify meta "URL") + ((url rest ...) url) + (_ (string-append %cran-url name)))) + (source-url (match (cran-uri name version) + ((url rest ...) url) + (_ #f))) + (tarball (with-store store (download-to-store store source-url))) + (sysdepends (map string-downcase (listify meta "SystemRequirements"))) + (propagate (map guix-name (lset-union equal? + (listify meta "Imports") + (listify meta "LinkingTo") + (delete "R" + (listify meta "Depends")))))) + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (cran-uri ,name version)) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (properties ,`(,'quasiquote ((,'upstream-name . ,name)))) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs propagate 'propagated-inputs) + (home-page ,(if (string-null? home-page) + (string-append %cran-url name) + home-page)) + (synopsis ,synopsis) + (description ,(beautify-description (assoc-ref meta "Description"))) + (license ,license)))) (define (cran->guix-package package-name) "Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((module-meta (cran-fetch package-name))) - (and=> module-meta cran-sxml->sexp))) + (and=> module-meta description->package))) ;;; @@ -209,32 +203,33 @@ (define (cran->guix-package package-name) (define (latest-release package) "Return an for the latest release of PACKAGE." - (define name - (if (string-prefix? "r-" package) - (string-drop package 2) - package)) - - (define sxml - (cran-fetch name)) - - (and sxml - (sxml-match-let* - (((*TOP* (xhtml:html - ,head - (xhtml:body - (xhtml:h2 ,name-and-synopsis) - (xhtml:p ,description) - ,summary - (xhtml:h4 "Downloads:") ,downloads - . ,rest))) - sxml)) - (let ((version (nodes->text (table-datum summary "Version:"))) - (url (downloads->url downloads))) - ;; CRAN does not provide signatures. - (upstream-source - (package package) - (version version) - (urls (list url))))))) + + (define (package->cran-name package) + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((url rest ...) + (let ((end (string-rindex url #\_)) + (start (string-rindex url #\/))) + ;; The URL ends on + ;; (string-append "/" name "_" version ".tar.gz") + (substring url start end))) + (_ #f))) + (_ #f))) + + (define cran-name + (package->cran-name (specification->package package))) + + (define meta + (cran-fetch cran-name)) + + (and meta + (let ((version (assoc-ref meta "Version"))) + ;; CRAN does not provide signatures. + (upstream-source + (package package) + (version version) + (urls (cran-uri cran-name version)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/tests/cran.scm b/tests/cran.scm index ba5699a133..0a4a2fdd8f 100644 --- a/tests/cran.scm +++ b/tests/cran.scm @@ -19,120 +19,84 @@ (define-module (test-cran) #:use-module (guix import cran) #:use-module (guix tests) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) + #:use-module (srfi srfi-26) #:use-module (ice-9 match)) -(define sxml - '(*TOP* (xhtml:html - (xhtml:head - (xhtml:title "CRAN - Package my-example-sxml")) - (xhtml:body - (xhtml:h2 "my-example-sxml: Short description") - (xhtml:p "Long description") - (xhtml:table - (@ (summary "Package my-example-sxml summary")) - (xhtml:tr - (xhtml:td "Version:") - (xhtml:td "1.2.3")) - (xhtml:tr - (xhtml:td "Depends:") - (xhtml:td "R (>= 3.1.0)")) - (xhtml:tr - (xhtml:td "SystemRequirements:") - (xhtml:td "cairo (>= 1.2 http://www.cairographics.org/)")) - (xhtml:tr - (xhtml:td "Imports:") - (xhtml:td - (xhtml:a (@ (href "../scales/index.html")) - "scales") - " (>= 0.2.3), " - (xhtml:a (@ (href "../proto/index.html")) - "proto") - ", " - (xhtml:a (@ (href "../Rcpp/index.html")) "Rcpp") - " (>= 0.11.0)")) - (xhtml:tr - (xhtml:td "Suggests:") - (xhtml:td - (xhtml:a (@ (href "../some/index.html")) - "some") - ", " - (xhtml:a (@ (href "../suggestions/index.html")) - "suggestions"))) - (xhtml:tr - (xhtml:td "License:") - (xhtml:td - (xhtml:a (@ (href "../../licenses/MIT")) "MIT"))) - (xhtml:tr - (xhtml:td "URL:") - (xhtml:td - (xhtml:a (@ (href "http://gnu.org/s/my-example-sxml")) - "http://gnu.org/s/my-example-sxml") - ", " - (xhtml:a (@ (href "http://alternative/home/page")) - "http://alternative/home/page")))) - (xhtml:h4 "Downloads:") - (xhtml:table - (@ (summary "Package my-example-sxml downloads")) - (xhtml:tr - (xhtml:td " Reference manual: ") - (xhtml:td - (xhtml:a (@ (href "my-example-sxml.pdf")) - " my-example-sxml.pdf "))) - (xhtml:tr - (xhtml:td " Package source: ") - (xhtml:td - (xhtml:a - (@ (href "../../../src/contrib/my-example-sxml_1.2.3.tar.gz")) - " my-example-sxml_1.2.3.tar.gz ")))) - (xhtml:h4 "Reverse dependencies:") - (xhtml:table - (@ (summary "Package my-example-sxml reverse dependencies")) - (xhtml:tr - (xhtml:td "Reverse depends:") - (xhtml:td "Too many.")) - (xhtml:tr - (xhtml:td "Reverse imports:") - (xhtml:td "Likewise.")) - (xhtml:tr - (xhtml:td "Reverse suggests:") - (xhtml:td "Uncountable."))))))) +(define description " +Package: My-Example +Type: Package +Title: Example package +Version: 1.2.3 +Date: 2015-12-10 +Author: Ricardo Wurmus +Maintainer: Guix Schmeeks +URL: http://gnu.org/s/my-example +Description: This is a long description +spanning multiple lines: and it could confuse the parser that +there is a colon : on the lines. + And: this line continues the description. +biocViews: 0 +SystemRequirements: Cairo (>= 0) +Depends: A C++11 compiler. Version 4.6.* of g++ (as + currently in Rtools) is insufficient; versions 4.8.*, 4.9.* or + later will be fine. +License: GPL (>= 3) +Imports: Rcpp (>= 0.11.5), proto, Scales +LinkingTo: Rcpp, BH +NeedsCompilation: yes +Repository: CRAN +Date/Publication: 2015-07-14 14:15:16 +") -(define simple-table - '(xhtml:table - (xhtml:tr - (xhtml:td "Numbers") - (xhtml:td "123")) - (xhtml:tr - (@ (class "whatever")) - (xhtml:td (@ (class "unimportant")) "Letters") - (xhtml:td "abc")) - (xhtml:tr - (xhtml:td "Letters") - (xhtml:td "xyz")) - (xhtml:tr - (xhtml:td "Single")) - (xhtml:tr - (xhtml:td "not a value") - (xhtml:td "not a label") - (xhtml:td "also not a label")))) +(define description-alist + ((@@ (guix import cran) description->alist) description)) + +(define simple-alist + '(("Key" . "Value") + ("SimpleList" . "R, Rcpp, something, whatever") + ("BadList" . "This is not a real list, you know?") + ("List" . "R (>= 2.2), BH (for no reason), GenomicRanges"))) (test-begin "cran") -(test-equal "table-datum: return list of first table cell matching label" - '((xhtml:td "abc")) - ((@@ (guix import cran) table-datum) simple-table "Letters")) +(test-assert "description->alist: contains all valid keys" + (let ((keys '("Package" "Type" "Title" "Version" "Date" + "Author" "Maintainer" "URL" "Description" + "SystemRequirements" "Depends" "License" + "Imports" "biocViews" "LinkingTo" + "NeedsCompilation" "Repository" + "Date/Publication"))) + (lset= string=? keys (map car description-alist)))) -(test-equal "table-datum: return empty list if no match" +(test-equal "listify: return empty list if key cannot be found" '() - ((@@ (guix import cran) table-datum) simple-table "Astronauts")) + ((@@ (guix import cran) listify) simple-alist "Letters")) + +(test-equal "listify: split comma-separated value into elements" + '("R" "Rcpp" "something" "whatever") + ((@@ (guix import cran) listify) simple-alist "SimpleList")) -(test-equal "table-datum: only consider the first cell as a label cell" +(test-equal "listify: strip off parentheses" + '("R" "BH" "GenomicRanges") + ((@@ (guix import cran) listify) simple-alist "List")) + +(test-equal "listify: ignore values that are no lists" '() - ((@@ (guix import cran) table-datum) simple-table "not a label")) + ((@@ (guix import cran) listify) simple-alist "BadList")) + +(test-equal "beautify-description: use double spacing" + "This is a package. It is great. Trust me Mr. Hendrix." + ((@@ (guix import cran) beautify-description) + "This is a package. It is great. Trust me Mr. Hendrix.")) +(test-equal "beautify-description: transform fragment into sentence" + "This package provides a function to establish world peace" + ((@@ (guix import cran) beautify-description) + "A function to establish world peace")) -(test-assert "cran-sxml->sexp" +(test-assert "description->package" ;; Replace network resources with sample data. (mock ((guix build download) url-fetch (lambda* (url file-name #:key (mirrors '())) @@ -140,32 +104,37 @@ (define simple-table (lambda () (display (match url - ("mirror://cran/src/contrib/my-example-sxml_1.2.3.tar.gz" + ("mirror://cran/src/contrib/My-Example_1.2.3.tar.gz" "source") (_ (error "Unexpected URL: " url)))))))) - (match ((@@ (guix import cran) cran-sxml->sexp) sxml) + (match ((@@ (guix import cran) description->package) description-alist) (('package - ('name "r-my-example-sxml") + ('name "r-my-example") ('version "1.2.3") ('source ('origin ('method 'url-fetch) - ('uri ('cran-uri "my-example-sxml" 'version)) + ('uri ('cran-uri "My-Example" 'version)) ('sha256 ('base32 (? string? hash))))) + ('properties ('quasiquote (('upstream-name . "My-Example")))) ('build-system 'r-build-system) ('inputs ('quasiquote (("cairo" ('unquote 'cairo))))) ('propagated-inputs ('quasiquote - (("r-proto" ('unquote 'r-proto)) + (("r-bh" ('unquote 'r-bh)) + ("r-proto" ('unquote 'r-proto)) ("r-rcpp" ('unquote 'r-rcpp)) ("r-scales" ('unquote 'r-scales))))) - ('home-page "http://gnu.org/s/my-example-sxml") - ('synopsis "Short description") - ('description "Long description") - ('license 'x11))) + ('home-page "http://gnu.org/s/my-example") + ('synopsis "Example package") + ('description + "This is a long description spanning multiple lines: \ +and it could confuse the parser that there is a colon : on the \ +lines. And: this line continues the description.") + ('license 'gpl3+))) (x (begin (format #t "~s\n" x) -- cgit v1.2.3