pack: Honor package transformation options.

[jackhill/guix/guix.git] / tests / containers.scm

diff --git a/tests/containers.scm b/tests/containers.scm
index cb1aedd..5323e50 100644 (file)
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -20,18 +20,29 @@
   #:use-module (guix utils)
   #:use-module (guix build syscalls)
   #:use-module (gnu build linux-container)
+  #:use-module (gnu system file-systems)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
 (define (assert-exit x)
   (primitive-exit (if x 0 1)))
 
-;; Skip these tests unless user namespaces are available.
-(unless (file-exists? "/proc/self/ns/user")
-  (exit 77))
-
 (test-begin "containers")
 
+;; Skip these tests unless user namespaces are available and the setgroups
+;; file (introduced in Linux 3.19 to address a security issue) exists.
+(define (skip-if-unsupported)
+  (unless (and (user-namespace-supported?)
+               (unprivileged-user-namespace-supported?)
+               (setgroups-supported?))
+    (test-skip 1)))
+
+(skip-if-unsupported)
+(test-assert "call-with-container, exit with 0 when there is no error"
+  (zero?
+   (call-with-container '() (const #t) #:namespaces '(user))))
+
+(skip-if-unsupported)
 (test-assert "call-with-container, user namespace"
   (zero?
    (call-with-container '()
@@ -40,6 +51,7 @@
        (assert-exit (and (zero? (getuid)) (zero? (getgid)))))
      #:namespaces '(user))))
 
+(skip-if-unsupported)
 (test-assert "call-with-container, uts namespace"
   (zero?
    (call-with-container '()
@@ -50,6 +62,7 @@
        (primitive-exit 0))
      #:namespaces '(user uts))))
 
+(skip-if-unsupported)
 (test-assert "call-with-container, pid namespace"
   (zero?
    (call-with-container '()
@@ -65,19 +78,43 @@
               (status:exit-val status)))))))
      #:namespaces '(user pid))))
 
+(skip-if-unsupported)
 (test-assert "call-with-container, mnt namespace"
   (zero?
-   (call-with-container '(("none" device "/testing" "tmpfs" () #f #f))
+   (call-with-container (list (file-system
+                                (device "none")
+                                (mount-point "/testing")
+                                (type "tmpfs")
+                                (check? #f)))
      (lambda ()
        (assert-exit (file-exists? "/testing")))
      #:namespaces '(user mnt))))
 
+(skip-if-unsupported)
+(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 (list (file-system
+                                   (device "/does-not-exist")
+                                   (mount-point "/foo")
+                                   (type "none")
+                                   (flags '(bind-mount))
+                                   (check? #f)))
+        (const #t)
+        #:namespaces '(user mnt)))
+    (lambda args
+      (list 'system-error (system-error-errno args)))))
+
+(skip-if-unsupported)
 (test-assert "call-with-container, all namespaces"
   (zero?
    (call-with-container '()
      (lambda ()
        (primitive-exit 0)))))
 
+(skip-if-unsupported)
 (test-assert "container-excursion"
   (call-with-temporary-directory
    (lambda (root)
@@ -102,7 +139,7 @@
                    (readlink (string-append "/proc/" pid "/ns/" ns)))
                  '("user" "ipc" "uts" "net" "pid" "mnt"))))
 
-        (let* ((pid (run-container root '() %namespaces container))
+        (let* ((pid (run-container root '() %namespaces 1 container))
                (container-namespaces (namespaces pid))
                (result
                 (begin
@@ -134,7 +171,41 @@
           (waitpid pid)
           (zero? result)))))))
 
-(test-end)
+(skip-if-unsupported)
+(test-equal "container-excursion, same namespaces"
+  42
+  ;; The parent and child are in the same namespaces.  'container-excursion'
+  ;; should notice that and avoid calling 'setns' since that would fail.
+  (container-excursion (getpid)
+    (lambda ()
+      (primitive-exit 42))))
 
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+(skip-if-unsupported)
+(test-assert "container-excursion*"
+  (call-with-temporary-directory
+   (lambda (root)
+     (define (namespaces pid)
+       (let ((pid (number->string pid)))
+         (map (lambda (ns)
+                (readlink (string-append "/proc/" pid "/ns/" ns)))
+              '("user" "ipc" "uts" "net" "pid" "mnt"))))
+
+     (let* ((pid    (run-container root '()
+                                   %namespaces 1
+                                   (lambda ()
+                                     (sleep 100))))
+            (expected (namespaces pid))
+            (result (container-excursion* pid
+                      (lambda ()
+                        (namespaces 1)))))
+       (kill pid SIGKILL)
+       (equal? result expected)))))
+
+(skip-if-unsupported)
+(test-equal "container-excursion*, same namespaces"
+  42
+  (container-excursion* (getpid)
+    (lambda ()
+      (* 6 7))))
+
+(test-end)