diff options
| -rw-r--r-- | guix/build/syscalls.scm | 33 | ||||
| -rw-r--r-- | tests/syscalls.scm | 15 |
2 files changed, 48 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a464040e56..cff010648a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -47,6 +47,14 @@ processes mkdtemp! + CLONE_NEWNS + CLONE_NEWUTS + CLONE_NEWIPC + CLONE_NEWUSER + CLONE_NEWPID + CLONE_NEWNET + clone + IFF_UP IFF_BROADCAST IFF_LOOPBACK @@ -280,6 +288,31 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (list err))) (pointer->string result))))) +;; Linux clone flags, from linux/sched.h +(define CLONE_NEWNS #x00020000) +(define CLONE_NEWUTS #x04000000) +(define CLONE_NEWIPC #x08000000) +(define CLONE_NEWUSER #x10000000) +(define CLONE_NEWPID #x20000000) +(define CLONE_NEWNET #x40000000) + +;; The libc interface to sys_clone is not useful for Scheme programs, so the +;; low-level system call is wrapped instead. +(define clone + (let* ((ptr (dynamic-func "syscall" (dynamic-link))) + (proc (pointer->procedure int ptr (list int int '*))) + ;; TODO: Don't do this. + (syscall-id (match (utsname:machine (uname)) + ("i686" 120) + ("x86_64" 56) + ("mips64" 5055) + ("armv7l" 120)))) + (lambda (flags) + "Create a new child process by duplicating the current parent process. +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)))) + ;;; ;;; Packed structures. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 049ca93267..4bc6f0332c 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -76,6 +76,21 @@ (rmdir dir) #t)))) +(define (user-namespace pid) + (string-append "/proc/" (number->string pid) "/ns/user")) + +(test-assert "clone" + (match (clone (logior CLONE_NEWUSER SIGCHLD)) + (0 (primitive-exit 42)) + (pid + ;; Check if user namespaces are different. + (and (not (equal? (readlink (user-namespace pid)) + (readlink (user-namespace (getpid))))) + (match (waitpid pid) + ((_ . status) + (= 42 (status:exit-val status)))))))) + + (test-assert "all-network-interfaces" (match (all-network-interfaces) (((? string? names) ..1) |