aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2019-02-24 13:18:52 +0000
committerChristopher Baines <mail@cbaines.net>2020-03-28 09:36:03 +0000
commita0801652dc649cd8e688a3d5cadb9e0d49e5cd83 (patch)
treebcf961a8368750930cc0534a344bea642dac2701
parentf27490e2d33d2b191f51fba59ea7bc0d5a99d037 (diff)
downloadguix-a0801652dc649cd8e688a3d5cadb9e0d49e5cd83.tar
guix-a0801652dc649cd8e688a3d5cadb9e0d49e5cd83.tar.gz
linux-container: Add 'start-child-in-container'.
This new procedure is similar to open-pipe* in (ice-9 popen), but using run-container from (gnu build linux-container). * gnu/build/linux-container.scm (start-child-in-container): New procedure.
-rw-r--r--gnu/build/linux-container.scm83
1 files changed, 83 insertions, 0 deletions
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 87695c98fd..5720f08c3e 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -31,6 +31,7 @@
setgroups-supported?
%namespaces
run-container
+ start-child-in-container
call-with-container
container-excursion
container-excursion*))
@@ -217,6 +218,88 @@ corresponds to the symbols in NAMESPACES."
('net CLONE_NEWNET))
namespaces)))
+(define* (start-child-in-container command
+ #:key read? write?
+ (root 'temporary)
+ (mounts '())
+ (namespaces %namespaces)
+ (host-uids 1)
+ (extra-environment-variables '()))
+ (define (with-root-directory f)
+ (if (eq? root 'temporary)
+ (call-with-temporary-directory f)
+ (f root)))
+
+ (define (make-rw-port read-port write-port)
+ (make-soft-port
+ (vector
+ (lambda (c) (write-char c write-port))
+ (lambda (s) (display s write-port))
+ (lambda () (force-output write-port))
+ (lambda () (read-char read-port))
+ (lambda () (close-port read-port) (close-port write-port)))
+ "r+"))
+
+ ;; car is the inport port, cdr is the output port. You write to the output
+ ;; port, and read from the input port.
+ (define child-to-parent-pipe
+ (if read?
+ (pipe)
+ #f))
+
+ (define parent-to-child-pipe
+ (if write?
+ (pipe)
+ #f))
+
+ (define (run-program)
+ (when read?
+ (match child-to-parent-pipe
+ ((input-port . output-port)
+ ;; close the output part of the child-to-parent-pipe, as this is used
+ ;; by the parent process
+ (close-port input-port)
+
+ ;; Make the input part of the child-to-parent-pipe the standard
+ ;; output of this process
+ (dup2 (fileno output-port) 1))))
+
+ (when write?
+ (match parent-to-child-pipe
+ ((input-port . output-port)
+ ;; close the input part of the parent-to-child-pipe, as this is used
+ ;; by the parent processs
+ (close-port output-port)
+
+ ;; Make the output part of the parent-to-child-pipe the standard
+ ;; input of this process
+ (dup2 (fileno input-port) 0))))
+
+ ;; TODO Maybe close all file descriptors, as start_child in Guile does?
+
+ (for-each putenv extra-environment-variables)
+
+ (apply execlp command))
+
+ (with-root-directory
+ (lambda (root)
+ (let ((pid (run-container root mounts namespaces host-uids run-program)))
+ ;; Catch SIGINT and kill the container process.
+ (sigaction SIGINT
+ (lambda (signum)
+ (false-if-exception
+ (kill pid SIGKILL))))
+
+ (let* ((read-port (and=> child-to-parent-pipe car))
+ (write-port (and=> parent-to-child-pipe cdr))
+
+ (port (or (and read-port write-port
+ (make-rw-port read-port write-port))
+ read-port
+ write-port)))
+
+ (values port pid))))))
+
(define* (run-container root mounts namespaces host-uids thunk
#:key (guest-uid 0) (guest-gid 0))
"Run THUNK in a new container process and return its PID. ROOT specifies