diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index 17b7b38a15..dea58354d9 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -328,7 +328,18 @@ (define-public shepherd-0.9 version ".tar.gz")) (sha256 (base32 - "0l2arn6gsyw88xk9phxnyplvv1mn8sqp3ipgyyb0nszdzvxlgd36")))) + "0l2arn6gsyw88xk9phxnyplvv1mn8sqp3ipgyyb0nszdzvxlgd36")) + (modules '((guix build utils))) + (snippet + ;; Avoid continuation barriers so (@ (fibers) sleep) can be + ;; called from a service's 'stop' method + '(substitute* "modules/shepherd/service.scm" + (("call-with-blocked-asyncs") ;in 'stop' method + "(lambda (thunk) (thunk))") + (("\\(for-each-service\n") ;in 'shutdown-services' + "((lambda (proc) + (for-each proc + (fold-services cons '())))\n"))))) (arguments (list #:configure-flags #~'("--localstatedir=/var") #:make-flags #~'("GUILE_AUTO_COMPILE=0") diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d58afb27e3..1fd4cd84f3 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -300,27 +300,36 @@ (define %root-file-system-shepherd-service ;; Return #f if successfully stopped. (sync) - (call-with-blocked-asyncs - (lambda () - (let ((null (%make-void-port "w"))) - ;; Close 'shepherd.log'. - (display "closing log\n") - ((@ (shepherd comm) stop-logging)) + (let ((null (%make-void-port "w"))) + ;; Close 'shepherd.log'. + (display "closing log\n") + ((@ (shepherd comm) stop-logging)) - ;; Redirect the default output ports.. - (set-current-output-port null) - (set-current-error-port null) + ;; Redirect the default output ports.. + (set-current-output-port null) + (set-current-error-port null) - ;; Close /dev/console. - (for-each close-fdes '(0 1 2)) + ;; Close /dev/console. + (for-each close-fdes '(0 1 2)) - ;; At this point, there are no open files left, so the - ;; root file system can be re-mounted read-only. - (mount #f "/" #f - (logior MS_REMOUNT MS_RDONLY) - #:update-mtab? #f) + (let loop ((n 10)) + (unless (catch 'system-error + (lambda () + ;; At this point, there are no open files left, so the + ;; root file system can be re-mounted read-only. + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + #t) + (const #f)) + (unless (zero? n) + ;; Yield to the other fibers. That gives logging fibers + ;; an opportunity to close log files so the 'mount' call + ;; doesn't fail with EBUSY. + ((@ (fibers) sleep) 1) + (loop (- n 1))))) - #f))))) + #f))) (respawn? #f))) (define root-file-system-service-type