From a0801652dc649cd8e688a3d5cadb9e0d49e5cd83 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 24 Feb 2019 13:18:52 +0000
Subject: 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.
---
 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 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
-- 
cgit v1.2.3