me/guix
Archived
1
0
Fork 0
Code Activity

linux-container: Add 'eval/container'.

Browse source 
* 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:
Ludovic Courtès 2019-07-15 16:14:31 +02:00
parent b41c7beb0b
commit bacfec8611
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 98 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
gnu/system/linux-container.scm
View file

@ -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))))))))))))

50
tests/containers.scm
View file

@ -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)