Toggle diff (82 lines)
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