diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 08bb33039c..ec49244cf6 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -277,45 +277,87 @@ and return the resulting '.go' file." (let ((files (map shepherd-service-file services))) (define config - #~(begin - (use-modules (srfi srfi-34) - (system repl error-handling)) + (with-imported-modules '((guix build syscalls)) + #~(begin + (use-modules (srfi srfi-34) + (system repl error-handling) + (guix build syscalls) + (system foreign)) - ;; Arrange to spawn a REPL if something goes wrong. This is better - ;; than a kernel panic. - (call-with-error-handling - (lambda () - (apply register-services - (map load-compiled '#$(map scm->go files))))) + (define signal + (let ((proc (pointer->procedure int + (dynamic-func "signal" + (dynamic-link)) + (list int '*)))) + (lambda (signum handler) + (proc signum + (if (integer? handler) ;SIG_DFL, etc. + (make-pointer handler) + (procedure->pointer void handler (list int))))))) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around - ;; it. - (setenv "PATH" "/run/current-system/profile/bin") + (define (handle-crash sig) + (dynamic-wind + (const #t) + (lambda () + (gc-disable) + (pk 'crash! sig) + ;; Fork and have the child dump core at the root. + (match (clone SIGCHLD) + (0 + (setrlimit 'core #f #f) + (chdir "/") + (signal sig SIG_DFL) + ;; Note: 'getpid' would return 1, hence this hack. + (kill (string->number (readlink "/proc/self")) + sig) + (primitive-_exit 253)) + (child + (waitpid child) + (sync) + ;; Hopefully at this point core has been dumped. + (pk 'done) + (sleep 3) + (primitive-_exit 255)))) + (lambda () + (primitive-_exit 254)))) - (format #t "starting services...~%") - (for-each (lambda (service) - ;; In the Shepherd 0.3 the 'start' method can raise - ;; '&action-runtime-error' if it fails, so protect - ;; against it. (XXX: 'action-runtime-error?' is not - ;; exported is 0.3, hence 'service-error?'.) - (guard (c ((service-error? c) - (format (current-error-port) - "failed to start service '~a'~%" - service))) - (start service))) - '#$(append-map shepherd-service-provision - (filter shepherd-service-auto-start? - services))) + (signal SIGSEGV handle-crash) - ;; Hang up stdin. At this point, we assume that 'start' methods - ;; that required user interaction on the console (e.g., - ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have - ;; completed. User interaction becomes impossible after this - ;; call; this avoids situations where services wrongfully lead - ;; PID 1 to read from stdin (the console), which users may not - ;; have access to (see ). - (redirect-port (open-input-file "/dev/null") - (current-input-port)))) + ;; Arrange to spawn a REPL if something goes wrong. This is better + ;; than a kernel panic. + (call-with-error-handling + (lambda () + (apply register-services + (map load-compiled '#$(map scm->go files))))) + + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around + ;; it. + (setenv "PATH" "/run/current-system/profile/bin") + + (format #t "starting services...~%") + (for-each (lambda (service) + ;; In the Shepherd 0.3 the 'start' method can raise + ;; '&action-runtime-error' if it fails, so protect + ;; against it. (XXX: 'action-runtime-error?' is not + ;; exported is 0.3, hence 'service-error?'.) + (guard (c ((service-error? c) + (format (current-error-port) + "failed to start service '~a'~%" + service))) + (start service))) + '#$(append-map shepherd-service-provision + (filter shepherd-service-auto-start? + services))) + + ;; Hang up stdin. At this point, we assume that 'start' methods + ;; that required user interaction on the console (e.g., + ;; 'cryptsetup open' invocations, post-fsck emergency REPL) have + ;; completed. User interaction becomes impossible after this + ;; call; this avoids situations where services wrongfully lead + ;; PID 1 to read from stdin (the console), which users may not + ;; have access to (see ). + (redirect-port (open-input-file "/dev/null") + (current-input-port))))) (scheme-file "shepherd.conf" config)))