3 files changed, 74 insertions(+), 54 deletions(-) gnu/build/linux-container.scm | 2 +- guix/build/syscalls.scm | 61 ++++++++++++++++++++++++++++++++++++++++++------------------- tests/syscalls.scm | 65 +++++++++++++++++++++++++++++++---------------------------------- modified gnu/build/linux-container.scm @@ -264,7 +264,7 @@ (define* (run-container root mounts namespaces host-uids thunk (match (socketpair PF_UNIX (logior SOCK_CLOEXEC SOCK_STREAM) 0) ((child . parent) (let ((flags (namespaces->bit-mask namespaces))) - (match (clone flags) + (match (safe-clone flags) (0 (call-with-clean-exit (lambda () modified guix/build/syscalls.scm @@ -150,6 +150,7 @@ (define-module (guix build syscalls) CLONE_THREAD CLONE_VM clone + safe-clone unshare setns get-user-ns @@ -1184,7 +1185,8 @@ (define-syntax-rule (without-automatic-finalization body ...) (define-syntax-rule (without-garbage-collection body ...) "Turn off garbage collection within the dynamic extent of BODY. This is useful -to ensure there are no garbage collection threads." +to avoid the creation new garbage collection thread. Note that pre-existing +GC marker threads are only disabled, not terminated." (dynamic-wind (lambda () (gc-disable)) @@ -1194,15 +1196,22 @@ (define-syntax-rule (without-garbage-collection body ...) (gc-enable)))) (define-syntax-rule (without-threads body ...) - "Ensure there are no Guile or garbage collection threads." - ;; Guile can spawn the following threads: the finalization thread, the - ;; signal thread, or the GC marker threads. - - ;; TODO: Assert there are no signal threads, or better, pause and restore - ;; them later? + "Ensure the Guile finalizer thread is stopped and that garbage collection does +not run. Note that pre-existing GC marker threads are only disabled, not +terminated. This also leaves the signal handling thread to be disabled by +another means, since there is no Guile API to do so." + ;; Note: the three kind of threads that Guile can spawn are the finalization + ;; thread, the signal thread, or the GC marker threads. (without-automatic-finalization (without-garbage-collection body ...))) +(define (ensure-signal-delivery-thread) + "Ensure the signal delivery thread is spawned and its state set + to 'RUNNNING'." + (match (sigaction SIGUSR1) + ((handler . flags) + (sigaction SIGUSR1 handler flags)))) + ;; The libc interface to sys_clone is not useful for Scheme programs, so the ;; low-level system call is wrapped instead. The 'syscall' function is ;; declared in as a variadic function; in practice, it expects 6 @@ -1245,15 +1254,33 @@ (define clone (list err)) ret))))) +(define (safe-clone flags child parent) + "This is a raw clone syscall wrapper that ensures no Guile thread will be +spawned during execution of the child. `clone' is called with FLAGS. CHILD +is a thunk to run in the child process. PARENT is procedure that accepts the +child PID as argument. This is useful in many contexts, such as when calling +`unshare' or async-unsafe procedures in the child when the parent process +memory (CLONE_VM) or threads (CLONE_THREAD) are shared with it." + ;; TODO: Contribute `clone' to Guile, and handle these complications there, + ;; similarly to how it's handled for scm_fork in posix.c. + + ;; XXX: This is a hack: by starting the signal delivery thread in the + ;; parent, it's state will be known as RUNNING, and the child won't attempt + ;; to start it itself. + (ensure-signal-delivery-thread) + (match (clone flags) + (0 (without-threads (child))) + (pid (parent pid)))) + (define unshare (let ((proc (syscall->procedure int "unshare" (list int)))) (lambda (flags) "Disassociate the current process from parts of its execution context according to FLAGS, which must be a logical or of CLONE_* constants. When CLONE_NEWUSER, CLONE_SIGHAND, CLONE_THREAD or CLONE_VM are specified, this -wrapper attempts to ensure be single-threaded operation, by disabling -finalization and garbage collection. If this requirement is not met, this -produces a warning and throws to 'system-error' with EINVAL." +wrapper verifies the caller's environment is single-threaded. If this +requirement is not met, this produces a warning and throws to 'system-error' +with EINVAL." (let* ((require-single-thread? (logand (logior CLONE_NEWUSER CLONE_SIGHAND CLONE_THREAD @@ -1263,15 +1290,11 @@ (define unshare (when (and require-single-thread? (not (>= 1 (length (all-threads))))) (format (current-warning-port) - (string-append - "warning: unshare single-thread " - "requirement violated~%")))))) - (let-values (((ret err) - (if require-single-thread? - (without-threads - (warn/maybe) - (proc flags)) - (proc flags)))) + "warning: unshare single-thread \ +requirement violated~%"))))) + (let-values (((ret err) (begin + (warn/maybe) + (proc flags)))) (unless (zero? ret) (throw 'system-error "unshare" "~a: ~A" (list flags (strerror err)) modified tests/syscalls.scm @@ -28,6 +28,7 @@ (srfi srfi-64) (srfi srfi-71) (system foreign) + (ice-9 format) ((ice-9 ftw) #:select (scandir)) (ice-9 match) (ice-9 threads)) @@ -159,44 +160,40 @@ (define perform-container-tests? (lambda args (system-error-errno args)))) -(unless perform-container-tests? - (test-skip 1)) -(test-equal "unshare handles GC threads" - 0 - (match (clone (logior CLONE_NEWUSER SIGCHLD)) - (0 - (gc) - (let ((status (catch 'system-error - (lambda () - (unshare CLONE_THREAD) - 0) - (lambda args - (system-error-errno args))))) - (primitive-exit status))) - (pid - (match (waitpid pid) +(define child-thunk + (lambda () + ;; Spawn a background thread to ensure multi-threaded state. + (call-with-new-thread + (lambda () + (sleep 1))) ;keep it alive for long enough + (let ((status (catch 'system-error + (lambda () + (unshare CLONE_THREAD) + 0) ;no error + (lambda args + (system-error-errno args))))) + (primitive-exit status)))) + +(define parent-proc + (lambda (pid) + (match (waitpid pid) ((_ . status) - (status:exit-val status)))))) + (status:exit-val status))))) -(test-equal "unshare fails in multi-threaded scenario" +(unless perform-container-tests? + (test-skip 1)) +(test-equal "clone and unshare triggers EINVAL" EINVAL (match (clone (logior CLONE_NEWUSER SIGCHLD)) - (0 - ;; Spawn a background thread to ensure multi-threaded state. - (call-with-new-thread - (lambda () - (sleep 1))) ;keep it alive for long enough - (let ((status (catch 'system-error - (lambda () - (unshare CLONE_THREAD) - 0) ;no error - (lambda args - (system-error-errno args))))) - (primitive-exit status))) - (pid - (match (waitpid pid) - ((_ . status) - (status:exit-val status)))))) + (0 (child-thunk)) + (pid (parent-proc pid)))) + +(unless perform-container-tests? + (test-skip 1)) +(test-equal "safe-clone and unshare succeeds" + 0 + (safe-clone (logior CLONE_NEWUSER SIGCHLD) + child-thunk parent-proc)) (unless perform-container-tests? (test-skip 1)) [back]