[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#34638] [PATCH v2 2/4] linux-container: Add 'start-child-in-containe
From: |
Christopher Baines |
Subject: |
[bug#34638] [PATCH v2 2/4] linux-container: Add 'start-child-in-container'. |
Date: |
Fri, 19 Apr 2019 15:04:25 +0100 |
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.
---
gnu/build/linux-container.scm | 83 +++++++++++++++++++++++++++++++++++
1 file changed, 83 insertions(+)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 3d7b52f098..88b00e00f6 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -32,6 +32,7 @@
setgroups-supported?
%namespaces
run-container
+ start-child-in-container
call-with-container
container-excursion
container-excursion*))
@@ -213,6 +214,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
--
2.21.0