mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
build: syscalls: Add setns.
* guix/build/syscalls.scm (setns): New procedure. * tests/syscalls.scm ("setns"): New test. squash: setns
This commit is contained in:
parent
8950ed11c6
commit
43ace6ea76
2 changed files with 42 additions and 0 deletions
|
@ -54,6 +54,7 @@ (define-module (guix build syscalls)
|
|||
CLONE_NEWPID
|
||||
CLONE_NEWNET
|
||||
clone
|
||||
setns
|
||||
|
||||
IFF_UP
|
||||
IFF_BROADCAST
|
||||
|
@ -313,6 +314,21 @@ (define clone
|
|||
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.
|
||||
|
|
|
@ -90,6 +90,32 @@ (define (user-namespace pid)
|
|||
((_ . 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)
|
||||
|
|
Loading…
Reference in a new issue