system: Introduce 'file-systems' Shepherd service.

* gnu/services/base.scm (file-system-shepherd-services): New procedure.
(file-system-service-type): Use it as the SHEPHERD-ROOT-SERVICE-TYPE
extension.
(user-processes-service-type): Change to take a single 'grace-delay'
parameter.
(user-processes-service): Remove 'file-systems' parameter.  Pass
GRACE-DELAY as the only value for the service.
* gnu/system.scm (essential-services): Adjust accordingly.

2 files changed, 84 insertions, 76 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index ef4d4b723e..ecabf78429 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
@@ -313,13 +313,26 @@ FILE-SYSTEM."
                         #:select (mount-file-system))
                        ,@%default-modules)))))))
 
+(define (file-system-shepherd-services file-systems)
+  "Return the list of Shepherd services for FILE-SYSTEMS."
+  (let* ((file-systems (filter file-system-mount? file-systems)))
+    (define sink
+      (shepherd-service
+       (provision '(file-systems))
+       (requirement (cons* 'root-file-system 'user-file-systems
+                           (map file-system->shepherd-service-name
+                                file-systems)))
+       (documentation "Target for all the initially-mounted file systems")
+       (start #~(const #t))
+       (stop #~(const #f))))
+
+    (cons sink (map file-system-shepherd-service file-systems))))
+
 (define file-system-service-type
   (service-type (name 'file-systems)
                 (extensions
                  (list (service-extension shepherd-root-service-type
-                                          (lambda (file-systems)
-                                            (filter-map file-system-shepherd-service
-                                                        file-systems)))
+                                          file-system-shepherd-services)
                        (service-extension fstab-service-type
                                           identity)))
                 (compose concatenate)
@@ -366,93 +379,89 @@ in KNOWN-MOUNT-POINTS when it is stopped."
 (define user-processes-service-type
   (shepherd-service-type
    'user-processes
-   (match-lambda
-     ((requirements grace-delay)
-      (shepherd-service
-       (documentation "When stopped, terminate all user processes.")
-       (provision '(user-processes))
-       (requirement (cons* 'root-file-system 'user-file-systems
-                           (map file-system->shepherd-service-name
-                                requirements)))
-       (start #~(const #t))
-       (stop #~(lambda _
-                 (define (kill-except omit signal)
-                   ;; Kill all the processes with SIGNAL except those listed
-                   ;; in OMIT and the current process.
-                   (let ((omit (cons (getpid) omit)))
-                     (for-each (lambda (pid)
-                                 (unless (memv pid omit)
-                                   (false-if-exception
-                                    (kill pid signal))))
-                               (processes))))
+   (lambda (grace-delay)
+     (shepherd-service
+      (documentation "When stopped, terminate all user processes.")
+      (provision '(user-processes))
+      (requirement '(file-systems))
+      (start #~(const #t))
+      (stop #~(lambda _
+                (define (kill-except omit signal)
+                  ;; Kill all the processes with SIGNAL except those listed
+                  ;; in OMIT and the current process.
+                  (let ((omit (cons (getpid) omit)))
+                    (for-each (lambda (pid)
+                                (unless (memv pid omit)
+                                  (false-if-exception
+                                   (kill pid signal))))
+                              (processes))))
 
-                 (define omitted-pids
-                   ;; List of PIDs that must not be killed.
-                   (if (file-exists? #$%do-not-kill-file)
-                       (map string->number
-                            (call-with-input-file #$%do-not-kill-file
-                              (compose string-tokenize
-                                       (@ (ice-9 rdelim) read-string))))
-                       '()))
+                (define omitted-pids
+                  ;; List of PIDs that must not be killed.
+                  (if (file-exists? #$%do-not-kill-file)
+                      (map string->number
+                           (call-with-input-file #$%do-not-kill-file
+                             (compose string-tokenize
+                                      (@ (ice-9 rdelim) read-string))))
+                      '()))
 
-                 (define (now)
-                   (car (gettimeofday)))
+                (define (now)
+                  (car (gettimeofday)))
 
-                 (define (sleep* n)
-                   ;; Really sleep N seconds.
-                   ;; Work around <http://bugs.gnu.org/19581>.
-                   (define start (now))
-                   (let loop ((elapsed 0))
-                     (when (> n elapsed)
-                       (sleep (- n elapsed))
-                       (loop (- (now) start)))))
+                (define (sleep* n)
+                  ;; Really sleep N seconds.
+                  ;; Work around <http://bugs.gnu.org/19581>.
+                  (define start (now))
+                  (let loop ((elapsed 0))
+                    (when (> n elapsed)
+                      (sleep (- n elapsed))
+                      (loop (- (now) start)))))
 
-                 (define lset= (@ (srfi srfi-1) lset=))
+                (define lset= (@ (srfi srfi-1) lset=))
 
-                 (display "sending all processes the TERM signal\n")
+                (display "sending all processes the TERM signal\n")
 
-                 (if (null? omitted-pids)
-                     (begin
-                       ;; Easy: terminate all of them.
-                       (kill -1 SIGTERM)
-                       (sleep* #$grace-delay)
-                       (kill -1 SIGKILL))
-                     (begin
-                       ;; Kill them all except OMITTED-PIDS.  XXX: We would
-                       ;; like to (kill -1 SIGSTOP) to get a fixed list of
-                       ;; processes, like 'killall5' does, but that seems
-                       ;; unreliable.
-                       (kill-except omitted-pids SIGTERM)
-                       (sleep* #$grace-delay)
-                       (kill-except omitted-pids SIGKILL)
-                       (delete-file #$%do-not-kill-file)))
+                (if (null? omitted-pids)
+                    (begin
+                      ;; Easy: terminate all of them.
+                      (kill -1 SIGTERM)
+                      (sleep* #$grace-delay)
+                      (kill -1 SIGKILL))
+                    (begin
+                      ;; Kill them all except OMITTED-PIDS.  XXX: We would
+                      ;; like to (kill -1 SIGSTOP) to get a fixed list of
+                      ;; processes, like 'killall5' does, but that seems
+                      ;; unreliable.
+                      (kill-except omitted-pids SIGTERM)
+                      (sleep* #$grace-delay)
+                      (kill-except omitted-pids SIGKILL)
+                      (delete-file #$%do-not-kill-file)))
 
-                 (let wait ()
-                   (let ((pids (processes)))
-                     (unless (lset= = pids (cons 1 omitted-pids))
-                       (format #t "waiting for process termination\
+                (let wait ()
+                  (let ((pids (processes)))
+                    (unless (lset= = pids (cons 1 omitted-pids))
+                      (format #t "waiting for process termination\
  (processes left: ~s)~%"
-                               pids)
-                       (sleep* 2)
-                       (wait))))
+                              pids)
+                      (sleep* 2)
+                      (wait))))
 
-                 (display "all processes have been terminated\n")
-                 #f))
-       (respawn? #f))))))
+                (display "all processes have been terminated\n")
+                #f))
+      (respawn? #f)))))
 
-(define* (user-processes-service file-systems #:key (grace-delay 4))
+(define* (user-processes-service #:key (grace-delay 4))
   "Return the service that is responsible for terminating all the processes so
 that the root file system can be re-mounted read-only, just before
 rebooting/halting.  Processes still running GRACE-DELAY seconds after SIGTERM
 has been sent are terminated with SIGKILL.
 
-The returned service will depend on 'root-file-system' and on all the shepherd
-services corresponding to FILE-SYSTEMS.
+The returned service will depend on 'file-systems', meaning that it is
+considered started after all the auto-mount file systems have been mounted.
 
 All the services that spawn processes must depend on this one so that they are
 stopped before 'kill' is called."
-  (service user-processes-service-type
-           (list (filter file-system-mount? file-systems) grace-delay)))
+  (service user-processes-service-type grace-delay))
 
 
 ;;;
diff --git a/gnu/system.scm b/gnu/system.scm
index 4e57f975e6..1006c842c9 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
@@ -293,8 +293,7 @@ a container or that of a \"bare metal\" system."
          (other-fs  (non-boot-file-system-service os))
          (unmount   (user-unmount-service known-fs))
          (swaps     (swap-services os))
-         (procs     (user-processes-service
-                     (service-parameters other-fs)))
+         (procs     (user-processes-service))
          (host-name (host-name-service (operating-system-host-name os)))
          (entries   (operating-system-directory-base-entries
                      os #:container? container?)))