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.
This commit is contained in:
parent
581176c00b
commit
f535dcbe19
|
@ -253,6 +253,7 @@ SH_TESTS = \
|
||||||
tests/guix-archive.sh \
|
tests/guix-archive.sh \
|
||||||
tests/guix-authenticate.sh \
|
tests/guix-authenticate.sh \
|
||||||
tests/guix-environment.sh \
|
tests/guix-environment.sh \
|
||||||
|
tests/guix-environment-container.sh \
|
||||||
tests/guix-graph.sh \
|
tests/guix-graph.sh \
|
||||||
tests/guix-lint.sh
|
tests/guix-lint.sh
|
||||||
|
|
||||||
|
|
|
@ -4681,6 +4681,18 @@ NumPy:
|
||||||
guix environment --ad-hoc python2-numpy python-2.7 -- python
|
guix environment --ad-hoc python2-numpy python-2.7 -- python
|
||||||
@end example
|
@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.
|
The available options are summarized below.
|
||||||
|
|
||||||
@table @code
|
@table @code
|
||||||
|
@ -4741,6 +4753,49 @@ environment.
|
||||||
@item --system=@var{system}
|
@item --system=@var{system}
|
||||||
@itemx -s @var{system}
|
@itemx -s @var{system}
|
||||||
Attempt to build for @var{system}---e.g., @code{i686-linux}.
|
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
|
@end table
|
||||||
|
|
||||||
It also supports all of the common build options that @command{guix
|
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
|
@item vm
|
||||||
@cindex virtual machine
|
@cindex virtual machine
|
||||||
@cindex VM
|
@cindex VM
|
||||||
|
@anchor{guix system vm}
|
||||||
Build a virtual machine that contain the operating system declared in
|
Build a virtual machine that contain the operating system declared in
|
||||||
@var{file}, and return a script to run that virtual machine (VM).
|
@var{file}, and return a script to run that virtual machine (VM).
|
||||||
Arguments given to the script are passed as is to QEMU.
|
Arguments given to the script are passed as is to QEMU.
|
||||||
|
|
|
@ -25,13 +25,19 @@
|
||||||
#:use-module (guix profiles)
|
#:use-module (guix profiles)
|
||||||
#:use-module (guix search-paths)
|
#:use-module (guix search-paths)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
|
#:use-module (guix build utils)
|
||||||
#:use-module (guix monads)
|
#:use-module (guix monads)
|
||||||
#:use-module ((guix gexp) #:select (lower-inputs))
|
#:use-module ((guix gexp) #:select (lower-inputs))
|
||||||
#:use-module (guix scripts)
|
#:use-module (guix scripts)
|
||||||
#:use-module (guix scripts build)
|
#: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)
|
||||||
|
#:use-module (gnu packages bash)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 rdelim)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
|
@ -60,6 +66,12 @@ OUTPUT) tuples."
|
||||||
(define %default-shell
|
(define %default-shell
|
||||||
(or (getenv "SHELL") "/bin/sh"))
|
(or (getenv "SHELL") "/bin/sh"))
|
||||||
|
|
||||||
|
(define %network-configuration-files
|
||||||
|
'("/etc/resolv.conf"
|
||||||
|
"/etc/nsswitch.conf"
|
||||||
|
"/etc/services"
|
||||||
|
"/etc/hosts"))
|
||||||
|
|
||||||
(define (purify-environment)
|
(define (purify-environment)
|
||||||
"Unset almost all environment variables. A small number of variables such
|
"Unset almost all environment variables. A small number of variables such
|
||||||
as 'HOME' and 'USER' are left untouched."
|
as 'HOME' and 'USER' are left untouched."
|
||||||
|
@ -124,6 +136,18 @@ COMMAND or an interactive shell in that environment.\n"))
|
||||||
--search-paths display needed environment variable definitions"))
|
--search-paths display needed environment variable definitions"))
|
||||||
(display (_ "
|
(display (_ "
|
||||||
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
|
-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)
|
(newline)
|
||||||
(show-build-options-help)
|
(show-build-options-help)
|
||||||
(newline)
|
(newline)
|
||||||
|
@ -176,6 +200,25 @@ COMMAND or an interactive shell in that environment.\n"))
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'system arg
|
(alist-cons 'system arg
|
||||||
(alist-delete 'system result eq?))))
|
(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))
|
%standard-build-options))
|
||||||
|
|
||||||
(define (pick-all alist key)
|
(define (pick-all alist key)
|
||||||
|
@ -231,6 +274,131 @@ OUTPUT) tuples, using the build options in OPTS."
|
||||||
(built-derivations derivations)
|
(built-derivations derivations)
|
||||||
(return 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)
|
(define (parse-args args)
|
||||||
"Parse the list of command line arguments ARGS."
|
"Parse the list of command line arguments ARGS."
|
||||||
(define (handle-argument arg result)
|
(define (handle-argument arg result)
|
||||||
|
@ -250,9 +418,14 @@ OUTPUT) tuples, using the build options in OPTS."
|
||||||
(with-error-handling
|
(with-error-handling
|
||||||
(let* ((opts (parse-args args))
|
(let* ((opts (parse-args args))
|
||||||
(pure? (assoc-ref opts 'pure))
|
(pure? (assoc-ref opts 'pure))
|
||||||
|
(container? (assoc-ref opts 'container?))
|
||||||
|
(network? (assoc-ref opts 'network?))
|
||||||
(ad-hoc? (assoc-ref opts 'ad-hoc?))
|
(ad-hoc? (assoc-ref opts 'ad-hoc?))
|
||||||
|
(bootstrap? (assoc-ref opts 'bootstrap?))
|
||||||
|
(system (assoc-ref opts 'system))
|
||||||
(command (assoc-ref opts 'exec))
|
(command (assoc-ref opts 'exec))
|
||||||
(packages (pick-all (options/resolve-packages opts) 'package))
|
(packages (pick-all (options/resolve-packages opts) 'package))
|
||||||
|
(mappings (pick-all opts 'file-system-mapping))
|
||||||
(inputs (if ad-hoc?
|
(inputs (if ad-hoc?
|
||||||
(append-map (match-lambda
|
(append-map (match-lambda
|
||||||
((package output)
|
((package output)
|
||||||
|
@ -274,26 +447,45 @@ OUTPUT) tuples, using the build options in OPTS."
|
||||||
eq?)))
|
eq?)))
|
||||||
(with-store store
|
(with-store store
|
||||||
(run-with-store store
|
(run-with-store store
|
||||||
(mlet %store-monad ((inputs (lower-inputs
|
(mlet* %store-monad ((inputs (lower-inputs
|
||||||
(map (match-lambda
|
(map (match-lambda
|
||||||
((label item)
|
((label item)
|
||||||
(list item))
|
(list item))
|
||||||
((label item output)
|
((label item output)
|
||||||
(list item output)))
|
(list item output)))
|
||||||
inputs)
|
inputs)
|
||||||
#:system (assoc-ref opts 'system))))
|
#:system system))
|
||||||
|
;; Containers need a Bourne shell at /bin/sh.
|
||||||
|
(bash (environment-bash container?
|
||||||
|
bootstrap?
|
||||||
|
system)))
|
||||||
(mbegin %store-monad
|
(mbegin %store-monad
|
||||||
;; First build INPUTS. This is necessary even for
|
;; First build the inputs. This is necessary even for
|
||||||
;; --search-paths.
|
;; --search-paths. Additionally, we might need to build bash
|
||||||
(build-inputs inputs opts)
|
;; for a container.
|
||||||
(cond ((assoc-ref opts 'dry-run?)
|
(build-inputs (if (derivation? bash)
|
||||||
|
`((,bash "out") ,@inputs)
|
||||||
|
inputs)
|
||||||
|
opts)
|
||||||
|
(cond
|
||||||
|
((assoc-ref opts 'dry-run?)
|
||||||
(return #t))
|
(return #t))
|
||||||
((assoc-ref opts 'search-paths)
|
((assoc-ref opts 'search-paths)
|
||||||
(show-search-paths inputs paths pure?)
|
(show-search-paths inputs paths pure?)
|
||||||
(return #t))
|
(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
|
(else
|
||||||
(create-environment inputs paths pure?)
|
|
||||||
(return
|
(return
|
||||||
(exit
|
(exit/status
|
||||||
(status:exit-val
|
(launch-environment command inputs paths pure?))))))))))))
|
||||||
(apply system* command)))))))))))))
|
|
||||||
|
|
|
@ -488,19 +488,6 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
||||||
(newline)
|
(newline)
|
||||||
(show-bug-report-information))
|
(show-bug-report-information))
|
||||||
|
|
||||||
(define (specification->file-system-mapping spec writable?)
|
|
||||||
"Read the SPEC and return the corresponding <file-system-mapping>."
|
|
||||||
(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
|
(define %options
|
||||||
;; Specifications of the command-line options.
|
;; Specifications of the command-line options.
|
||||||
(cons* (option '(#\h "help") #f #f
|
(cons* (option '(#\h "help") #f #f
|
||||||
|
|
19
guix/ui.scm
19
guix/ui.scm
|
@ -34,6 +34,7 @@
|
||||||
#:use-module (guix serialization)
|
#:use-module (guix serialization)
|
||||||
#:use-module ((guix build utils) #:select (mkdir-p))
|
#:use-module ((guix build utils) #:select (mkdir-p))
|
||||||
#:use-module ((guix licenses) #:select (license? license-name))
|
#:use-module ((guix licenses) #:select (license? license-name))
|
||||||
|
#:use-module (gnu system file-systems)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-19)
|
#:use-module (srfi srfi-19)
|
||||||
|
@ -80,6 +81,7 @@
|
||||||
string->recutils
|
string->recutils
|
||||||
package->recutils
|
package->recutils
|
||||||
package-specification->name+version+output
|
package-specification->name+version+output
|
||||||
|
specification->file-system-mapping
|
||||||
string->generations
|
string->generations
|
||||||
string->duration
|
string->duration
|
||||||
run-guix-command
|
run-guix-command
|
||||||
|
@ -966,6 +968,23 @@ optionally contain a version number and an output name, as in these examples:
|
||||||
(package-name->name+version name)))
|
(package-name->name+version name)))
|
||||||
(values name version sub-drv)))
|
(values name version sub-drv)))
|
||||||
|
|
||||||
|
(define (specification->file-system-mapping spec writable?)
|
||||||
|
"Read the SPEC and return the corresponding <file-system-mapping>. 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.
|
;;; Command-line option processing.
|
||||||
|
|
|
@ -0,0 +1,75 @@
|
||||||
|
# GNU Guix --- Functional package management for GNU
|
||||||
|
# Copyright © 2015 David Thompson <davet@gnu.org>
|
||||||
|
#
|
||||||
|
# This file is part of GNU Guix.
|
||||||
|
#
|
||||||
|
# GNU Guix is free software; you can redistribute it and/or modify it
|
||||||
|
# under the terms of the GNU General Public License as published by
|
||||||
|
# the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
# your option) any later version.
|
||||||
|
#
|
||||||
|
# GNU Guix is distributed in the hope that it will be useful, but
|
||||||
|
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
# GNU General Public License for more details.
|
||||||
|
#
|
||||||
|
# You should have received a copy of the GNU General Public License
|
||||||
|
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
#
|
||||||
|
# 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
|
Loading…
Reference in New Issue