01/02: build: container: Add feature test predicates.

[David Thompson]

davexunit pushed a commit to branch master
in repository guix.

commit b7d48312bbfc7bdbb3895eb10edc352eeb555b98
Author: David Thompson <address@hidden>
Date:   Tue Nov 3 08:32:53 2015 -0500

    build: container: Add feature test predicates.
    
    * gnu/build/linux-container.scm (user-namespace-supported?,
      unprivileged-user-namespace-supported?, setgroups-supported?): New
      procedures.
    * tests/container.scm: Use predicates.
    * tests/syscalls.scm: Likewise.
---
 gnu/build/linux-container.scm |   22 +++++++++++++++++++++-
 tests/containers.scm          |    5 +++--
 tests/syscalls.scm            |   11 ++++++++---
 3 files changed, 32 insertions(+), 6 deletions(-)

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 556422b..eb5dbf9 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -19,16 +19,36 @@
 (define-module (gnu build linux-container)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-98)
   #:use-module (guix utils)
   #:use-module (guix build utils)
   #:use-module (guix build syscalls)
   #:use-module ((gnu build file-systems) #:select (mount-file-system))
-  #:export (%namespaces
+  #:export (user-namespace-supported?
+            unprivileged-user-namespace-supported?
+            setgroups-supported?
+            %namespaces
             run-container
             call-with-container
             container-excursion))
 
+(define (user-namespace-supported?)
+  "Return #t if user namespaces are supported on this system."
+  (file-exists? "/proc/self/ns/user"))
+
+(define (unprivileged-user-namespace-supported?)
+  "Return #t if user namespaces can be created by unprivileged users."
+  (let ((userns-file "/proc/sys/kernel/unprivileged_userns_clone"))
+    (if (file-exists? userns-file)
+        (string=? "1" (call-with-input-file userns-file read-string))
+        #t)))
+
+(define (setgroups-supported?)
+  "Return #t if the setgroups proc file, introduced in Linux-libre 3.19,
+exists."
+  (file-exists? "/proc/self/setgroups"))
+
 (define %namespaces
   '(mnt pid ipc uts user net))
 
diff --git a/tests/containers.scm b/tests/containers.scm
index 0ba8149..12982a6 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -28,8 +28,9 @@
 
 ;; Skip these tests unless user namespaces are available and the setgroups
 ;; file (introduced in Linux 3.19 to address a security issue) exists.
-(unless (and (file-exists? "/proc/self/ns/user")
-             (file-exists? "/proc/self/setgroups"))
+(unless (and (user-namespace-supported?)
+             (unprivileged-user-namespace-supported?)
+             (setgroups-supported?))
   (exit 77))
 
 (test-begin "containers")
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 86783b9..a57a9ca 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -20,6 +20,7 @@
 (define-module (test-syscalls)
   #:use-module (guix utils)
   #:use-module (guix build syscalls)
+  #:use-module (gnu build linux-container)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
@@ -80,7 +81,11 @@
 (define (user-namespace pid)
   (string-append "/proc/" (number->string pid) "/ns/user"))
 
-(unless (file-exists? (user-namespace (getpid)))
+(define perform-container-tests?
+  (and (user-namespace-supported?)
+       (unprivileged-user-namespace-supported?)))
+
+(unless perform-container-tests?
   (test-skip 1))
 (test-assert "clone"
   (match (clone (logior CLONE_NEWUSER SIGCHLD))
@@ -93,7 +98,7 @@
             ((_ . status)
              (= 42 (status:exit-val status))))))))
 
-(unless (file-exists? (user-namespace (getpid)))
+(unless perform-container-tests?
   (test-skip 1))
 (test-assert "setns"
   (match (clone (logior CLONE_NEWUSER SIGCHLD))
@@ -122,7 +127,7 @@
              (waitpid fork-pid)
              result))))))))
 
-(unless (file-exists? (user-namespace (getpid)))
+(unless perform-container-tests?
   (test-skip 1))
 (test-assert "pivot-root"
   (match (pipe)