From: "Ludovic Courtès" <ludo@gnu.org>
To: 36668@debbugs.gnu.org
Subject: [bug#36668] [PATCH 1/1] linux-container: Add 'eval/container'.
Date: Mon, 15 Jul 2019 16:25:36 +0200 [thread overview]
Message-ID: <20190715142536.14793-1-ludo@gnu.org> (raw)
In-Reply-To: <20190715142126.14612-1-ludo@gnu.org>
* gnu/system/linux-container.scm (eval/container): New procedure.
* tests/containers.scm ("eval/container, exit status")
("eval/container, writable user mapping"): New tests.
---
gnu/system/linux-container.scm | 49 ++++++++++++++++++++++++++++++++-
tests/containers.scm | 50 ++++++++++++++++++++++++++++++++++
2 files changed, 98 insertions(+), 1 deletion(-)
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)
--
2.22.0
next prev parent reply other threads:[~2019-07-15 14:26 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-07-15 14:21 [bug#36668] [PATCH 0/1] Add 'eval/container' Ludovic Courtès
2019-07-15 14:25 ` Ludovic Courtès [this message]
2019-07-15 15:22 ` Thompson, David
2019-07-15 15:51 ` Ludovic Courtès
2019-07-19 9:55 ` bug#36668: " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190715142536.14793-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=36668@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).