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.

1 files changed, 82 insertions, 0 deletions

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 65e1325577..63c83902e4 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*))
@@ -210,6 +211,87 @@ 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)))
+
+  ;; (ice-9 popen) internals
+  (define make-rw-port (@@ (ice-9 popen) make-rw-port))
+  (define pipe-guardian (@@ (ice-9 popen) pipe-guardian))
+  (define make-pipe-info (@@ (ice-9 popen) make-pipe-info))
+
+  ;; 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))
+              (pipe-info (make-pipe-info pid)))
+
+         (pipe-guardian pipe-info)
+         (%set-port-property! port 'popen-pipe-info pipe-info)
+
+         port)))))
+
 (define (run-container root mounts namespaces host-uids thunk)
   "Run THUNK in a new container process and return its PID.  ROOT specifies
 the root directory for the container.  MOUNTS is a list of <file-system>