mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 05:48:07 -05:00
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.
This commit is contained in:
parent
b41c7beb0b
commit
bacfec8611
2 changed files with 98 additions and 1 deletions
|
@ -35,7 +35,8 @@ (define-module (gnu system linux-container)
|
||||||
#:use-module (gnu system file-systems)
|
#:use-module (gnu system file-systems)
|
||||||
#:export (system-container
|
#:export (system-container
|
||||||
containerized-operating-system
|
containerized-operating-system
|
||||||
container-script))
|
container-script
|
||||||
|
eval/container))
|
||||||
|
|
||||||
(define* (container-essential-services os #:key shared-network?)
|
(define* (container-essential-services os #:key shared-network?)
|
||||||
"Return a list of essential services corresponding to OS, a
|
"Return a list of essential services corresponding to OS, a
|
||||||
|
@ -205,3 +206,49 @@ (define script
|
||||||
%namespaces)))))
|
%namespaces)))))
|
||||||
|
|
||||||
(gexp->script "run-container" script)))
|
(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))))))))))))
|
||||||
|
|
|
@ -21,7 +21,15 @@ (define-module (test-containers)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix build syscalls)
|
#:use-module (guix build syscalls)
|
||||||
#:use-module (gnu build linux-container)
|
#:use-module (gnu build linux-container)
|
||||||
|
#:use-module ((gnu system linux-container)
|
||||||
|
#:select (eval/container))
|
||||||
#:use-module (gnu system file-systems)
|
#: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 (srfi srfi-64)
|
||||||
#:use-module (ice-9 match))
|
#:use-module (ice-9 match))
|
||||||
|
|
||||||
|
@ -219,4 +227,46 @@ (define (namespaces pid)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(* 6 7))))
|
(* 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)
|
(test-end)
|
||||||
|
|
Loading…
Reference in a new issue