summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-07-15 16:14:31 +0200
committerLudovic Courtès <ludo@gnu.org>2019-07-19 11:53:47 +0200
commitbacfec8611530dc3e849fb804b51f50b299796f0 (patch)
tree0d114dfcf5692742ade19a7dfad829b2546835a2 /gnu
parentb41c7beb0b5b7a16656d6acf53f77eaf2a58e125 (diff)
downloadpatches-bacfec8611530dc3e849fb804b51f50b299796f0.tar
patches-bacfec8611530dc3e849fb804b51f50b299796f0.tar.gz
linux-container: Add 'eval/container'.
* gnu/system/linux-container.scm (eval/container): New procedure. * tests/containers.scm ("eval/container, exit status") ("eval/container, writable user mapping"): New tests.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/system/linux-container.scm49
1 files changed, 48 insertions, 1 deletions
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 61248c62b9..6273cee3d3 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -35,7 +35,8 @@
#:use-module (gnu system file-systems)
#:export (system-container
containerized-operating-system
- container-script))
+ container-script
+ eval/container))
(define* (container-essential-services os #:key shared-network?)
"Return a list of essential services corresponding to OS, a
@@ -205,3 +206,49 @@ that will be shared with the host system."
%namespaces)))))
(gexp->script "run-container" script)))
+
+(define* (eval/container exp
+ #:key
+ (mappings '())
+ (namespaces %namespaces))
+ "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
+listed in NAMESPACES. Add MAPPINGS, a list of <file-system-mapping>, to the
+set of directories visible in the process's mount namespace. Return the
+process' exit status as a monadic value.
+
+This is useful to implement processes that, unlike derivations, are not
+entirely pure and need to access the outside world or to perform side
+effects."
+ (mlet %store-monad ((lowered (lower-gexp exp)))
+ (define inputs
+ (cons (lowered-gexp-guile lowered)
+ (lowered-gexp-inputs lowered)))
+
+ (define items
+ (append (append-map derivation-input-output-paths inputs)
+ (lowered-gexp-sources lowered)))
+
+ (mbegin %store-monad
+ (built-derivations inputs)
+ (mlet %store-monad ((closure ((store-lift requisites) items)))
+ (return (call-with-container (map file-system-mapping->bind-mount
+ (append (map (lambda (item)
+ (file-system-mapping
+ (source item)
+ (target source)))
+ closure)
+ mappings))
+ (lambda ()
+ (apply execl
+ (string-append (derivation-input-output-path
+ (lowered-gexp-guile lowered))
+ "/bin/guile")
+ "guile"
+ (append (map (lambda (directory) `("-L" ,directory))
+ (lowered-gexp-load-path lowered))
+ (map (lambda (directory) `("-C" ,directory))
+ (lowered-gexp-load-compiled-path
+ lowered))
+ (list "-c"
+ (object->string
+ (lowered-gexp-sexp lowered))))))))))))