build: syscalls: Add clone.

* guix/build/syscalls.scm (clone): New procedure.
  (CLONE_NEWNS, CLONE_NEWUTS, CLONE_NEWIPC, CLONE_NEWUSER, CLONE_NEWPID,
  CLONE_NEWNET): New variables.
* tests/syscalls.scm ("clone"): New test.
This commit is contained in:
David Thompson 2015-05-31 20:26:47 -04:00 committed by David Thompson
parent 0e88cbf8c1
commit 8950ed11c6
2 changed files with 48 additions and 0 deletions

View File

@ -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.

View File

@ -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)