diff options
| -rw-r--r-- | guix/build/syscalls.scm | 16 | ||||
| -rw-r--r-- | tests/syscalls.scm | 26 |
2 files changed, 42 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index cff010648a..3f0a0c92f8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -54,6 +54,7 @@ CLONE_NEWPID CLONE_NEWNET clone + setns IFF_UP IFF_BROADCAST @@ -313,6 +314,21 @@ Unlike the fork system call, clone accepts FLAGS that specify which resources are shared between the parent and child processes." (proc syscall-id flags %null-pointer)))) +(define setns + (let* ((ptr (dynamic-func "setns" (dynamic-link))) + (proc (pointer->procedure int ptr (list int int)))) + (lambda (fdes nstype) + "Reassociate the current process with the namespace specified by FDES, a +file descriptor obtained by opening a /proc/PID/ns/* file. NSTYPE specifies +which type of namespace the current process may be reassociated with, or 0 if +there is no such limitation." + (let ((ret (proc fdes nstype)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "setns" "~d ~d: ~A" + (list fdes nstype (strerror err)) + (list err))))))) + ;;; ;;; Packed structures. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 4bc6f0332c..9b8ac9e603 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -90,6 +90,32 @@ ((_ . status) (= 42 (status:exit-val status)))))))) +(test-assert "setns" + (match (clone (logior CLONE_NEWUSER SIGCHLD)) + (0 (primitive-exit 0)) + (clone-pid + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (close in) + ;; Join the user namespace. + (call-with-input-file (user-namespace clone-pid) + (lambda (port) + (setns (port->fdes port) 0))) + (write 'done out) + (close out) + (primitive-exit 0)) + (fork-pid + (close out) + ;; Wait for the child process to join the namespace. + (read in) + (let ((result (and (equal? (readlink (user-namespace clone-pid)) + (readlink (user-namespace fork-pid)))))) + ;; Clean up. + (waitpid clone-pid) + (waitpid fork-pid) + result)))))))) (test-assert "all-network-interfaces" (match (all-network-interfaces) |