diff options
| -rw-r--r-- | gnu/system/linux-container.scm | 49 | ||||
| -rw-r--r-- | tests/containers.scm | 50 |
2 files changed, 98 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)))))))))))) diff --git a/tests/containers.scm b/tests/containers.scm index 37408f380d..c6c738f234 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -21,7 +21,15 @@ #:use-module (guix utils) #:use-module (guix build syscalls) #:use-module (gnu build linux-container) + #:use-module ((gnu system linux-container) + #:select (eval/container)) #:use-module (gnu system file-systems) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module (guix tests) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -219,4 +227,46 @@ (lambda () (* 6 7)))) +(skip-if-unsupported) +(test-equal "eval/container, exit status" + 42 + (let* ((store (open-connection-for-tests)) + (status (run-with-store store + (eval/container #~(exit 42))))) + (close-connection store) + (status:exit-val status))) + +(skip-if-unsupported) +(test-assert "eval/container, writable user mapping" + (call-with-temporary-directory + (lambda (directory) + (define store + (open-connection-for-tests)) + (define result + (string-append directory "/r")) + (define requisites* + (store-lift requisites)) + + (call-with-output-file result (const #t)) + (run-with-store store + (mlet %store-monad ((status (eval/container + #~(begin + (use-modules (ice-9 ftw)) + (call-with-output-file "/result" + (lambda (port) + (write (scandir #$(%store-prefix)) + port)))) + #:mappings + (list (file-system-mapping + (source result) + (target "/result") + (writable? #t))))) + (reqs (requisites* + (list (derivation->output-path + (%guile-for-build)))))) + (close-connection store) + (return (and (zero? (pk 'status status)) + (lset= string=? (cons* "." ".." (map basename reqs)) + (pk (call-with-input-file result read)))))))))) + (test-end) |