From c06f6db7a424fd47e3cd2625dbfda2367316f3bd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 30 May 2016 22:44:58 +0200
Subject: [PATCH] container: Gracefully report mount errors in the child
 process.

Fixes <http://bugs.gnu.org/23306>.

* gnu/build/linux-container.scm (run-container): Use 'socketpair'
instead of 'pipe'.  Rename 'in' to 'child' and 'out' to 'parent'.  Send
a 'ready message or an exception argument list from the child to the
parent; adjust the parent accordingly.
* tests/containers.scm ("call-with-container, mnt namespace, wrong bind
mount"): New test.
* tests/guix-environment-container.sh: Add test with
--expose=/does-not-exist.
---
 gnu/build/linux-container.scm       | 42 ++++++++++++++++++++---------
 tests/containers.scm                | 12 +++++++++
 tests/guix-environment-container.sh | 10 +++++++
 3 files changed, 52 insertions(+), 12 deletions(-)

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 562d50bcc7..91996d06ca 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -205,35 +205,53 @@ host user identifiers to map into the user namespace."
   ;; The parent process must initialize the user namespace for the child
   ;; before it can boot.  To negotiate this, a pipe is used such that the
   ;; child process blocks until the parent writes to it.
-  (match (pipe)
-    ((in . out)
+  (match (socketpair PF_UNIX SOCK_STREAM 0)
+    ((child . parent)
      (let ((flags (namespaces->bit-mask namespaces)))
        (match (clone flags)
          (0
           (call-with-clean-exit
            (lambda ()
-             (close out)
+             (close-port parent)
              ;; Wait for parent to set things up.
-             (match (read in)
+             (match (read child)
                ('ready
-                (close in)
                 (purify-environment)
                 (when (memq 'mnt namespaces)
-                  (mount-file-systems root mounts
-                                      #:mount-/proc? (memq 'pid namespaces)
-                                      #:mount-/sys?  (memq 'net namespaces)))
+                  (catch #t
+                    (lambda ()
+                      (mount-file-systems root mounts
+                                          #:mount-/proc? (memq 'pid namespaces)
+                                          #:mount-/sys?  (memq 'net
+                                                               namespaces)))
+                    (lambda args
+                      ;; Forward the exception to the parent process.
+                      (write args child)
+                      (primitive-exit 3))))
                 ;; TODO: Manage capabilities.
+                (write 'ready child)
+                (close-port child)
                 (thunk))
                (_                                 ;parent died or something
                 (primitive-exit 2))))))
          (pid
+          (close-port child)
           (when (memq 'user namespaces)
             (initialize-user-namespace pid host-uids))
           ;; TODO: Initialize cgroups.
-          (close in)
-          (write 'ready out)
-          (close out)
-          pid))))))
+          (write 'ready parent)
+          (newline parent)
+
+          ;; Check whether the child process' setup phase succeeded.
+          (let ((message (read parent)))
+            (close-port parent)
+            (match message
+              ('ready                             ;success
+               pid)
+              (((? symbol? key) args ...)         ;exception
+               (apply throw key args))
+              (_                                  ;unexpected termination
+               #f)))))))))
 
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                               (host-uids 1))
diff --git a/tests/containers.scm b/tests/containers.scm
index c11cdd1ce5..5a0f9937bb 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -79,6 +79,18 @@
        (assert-exit (file-exists? "/testing")))
      #:namespaces '(user mnt))))
 
+(test-equal "call-with-container, mnt namespace, wrong bind mount"
+  `(system-error ,ENOENT)
+  ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
+  (catch 'system-error
+    (lambda ()
+      (call-with-container '(("/does-not-exist" device "/foo"
+                              "none" (bind-mount) #f #f))
+        (const #t)
+        #:namespaces '(user mnt)))
+    (lambda args
+      (list 'system-error (system-error-errno args)))))
+
 (test-assert "call-with-container, all namespaces"
   (zero?
    (call-with-container '()
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
index 0a7ea481fc..5ea6c49263 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -44,6 +44,16 @@ else
     test $? = 42
 fi
 
+# Make sure file-not-found errors in mounts are reported.
+if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
+	--expose=/does-not-exist -- guile -c 1 2> "$tmpdir/error"
+then
+    false
+else
+    grep "/does-not-exist" "$tmpdir/error"
+    grep "[Nn]o such file" "$tmpdir/error"
+fi
+
 # Make sure that the right directories are mapped.
 mount_test_code="
 (use-modules (ice-9 rdelim)