~ruther/guix-local

b7d48312bbfc7bdbb3895eb10edc352eeb555b98 — David Thompson 10 years ago 9ff7827
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.
3 files changed, 32 insertions(+), 6 deletions(-)

M gnu/build/linux-container.scm
M tests/containers.scm
M tests/syscalls.scm
M gnu/build/linux-container.scm => gnu/build/linux-container.scm +21 -1
@@ 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))


M tests/containers.scm => tests/containers.scm +3 -2
@@ 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")

M tests/syscalls.scm => tests/syscalls.scm +8 -3
@@ 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)