path: root/whispers/services/whispers.scm

;;; Whispers --- Stealth VPN and ssh tunneler
;;; Copyright � 2023 Runciter <runciter@whispers-vpn.org>
;;;
;;; This file is part of Whispers.
;;;
;;; Whispers is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Whispers is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Whispers.  If not, see <http://www.gnu.org/licenses/>.

(define-module (whispers services whispers)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu system shadow)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services mcron)
  #:use-module (gnu services admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages networking)
  #:use-module (whispers packages whispers)
  #:use-module (srfi srfi-1)
  #:export (whispers-configuration
            whispers-configuration?
            whispers-user-group
            whispers-user-group?
            whispers-user-group-user
            whispers-user-group-group
            user-container-name
            lieutenant-path->socket-file-path
            whispers-service-type))

(define-record-type* <whispers-configuration>
  whispers-configuration make-whispers-configuration
  whispers-configuration?
  this-whispers-configuration
  ;; A file-like-object
  (coreutils-package                whispers-configuration-coreutils-package
                                    (default coreutils))
  ;; A file-like-object
  (util-linux-package               whispers-configuration-util-linux-package
                                    (default util-linux))
  ;; A file-like-object
  (whispers-package                 whispers-configuration-whispers-package
                                    (default whispers))
  ;; A symbol
  (name                             whispers-configuration-name
                                    (default 'whispers))
  ;; A list of guix service objects
  (lieutenants                      whispers-configuration-lieutenants
                                    (default '()))
  ;; A list of symbols
  (requires                         whispers-configuration-requires
                                    (default '()))
  ;; A string
  (user                             whispers-configuration-user
                                    (default "root"))
  ;; A boolean value
  (extend-user?                     whispers-configuration-extend-user?
                                    (default #f))
  ;; A string
  (group                            whispers-configuration-group
                                    (default "root"))
  ;; A boolean value
  (extend-group?                    whispers-configuration-extend-group?
                                    (default #f))
  ;; A string
  (timeout                          whispers-configuration-timeout
                                    (default '(default-pid-file-timeout)))
  ;; A list of package objects
  (extra-packages                   whispers-configuration-extra-packages
                                    (default (list)))
  ;; A list of shepherd-action records
  (extra-actions                    whispers-configuration-extra-actions
                                    (default (list)))
  ;; A boolean value
  (pre-start-action?                whispers-configuration-pre-start-action?
                                    (default #f))
  ;; A boolean value
  (post-stop-action?                whispers-configuration-post-stop-action?
                                    (default #f))
  ;; A boolean value
  (%auto-start?                     whispers-configuration-auto-start?
                                    (default #t)))

(define-record-type* <whispers-user-group>
  whispers-user-group make-whispers-user-group
  whispers-user-group?
  this-whispers-user-group
  ;; A string
  (user                 whispers-user-group-user
                        (default "johndoe"))
  ;; A string
  (group                whispers-user-group-group
                        (default "loner")))

(define (user-container-name user)
  "Return the string \"root-user\" if the string USER is equal to
\"root\", return the string USER otherwise. This is exported to other
modules as a dirty ad-hoc convenience function, for use by modules which
extend a sub-tree whose first branching is done on a per-handle basis."
  (if (equal? user "root")
      "root-user"
      user))

(define (lieutenant-path->socket-file-path lieutenant-path)
  "Returns as a string the expected path to the socket of the whispers
lieutenant shepherd at the whispers path defined by the string
LIEUTENANT-PATH. This is exported to other modules as a dirty ad-hoc
convenience function."
  (string-append "/run/whispers"
                 lieutenant-path
                 "/unix-sockets/"
                 (last (string-split lieutenant-path
                                     #\/))
                 ".sock"))

(define (shepherd-service-lieutenate parent-path
                                     parent-user
                                     parent-group
                                     config)
  "Message-passing along the strings PARENT-USER and PARENT-GROUP and
configurable by CONFIG, a record of the <whispers-configuration> type,
returns a one argument procedure taking a root shepherd service
extension as its single parameter and returning a <shepherd-service>
type guix records for a shepherd service of a lieutenant of a whispers
service at the top of a whispers tree or sub-tree, as defined by the
string PARENT-PATH."
  (lambda (extension)
    (if (whispers-configuration? config)
        ((whispers-shepherd-tree parent-path
                                 parent-user
                                 parent-group) config)
        ((service-extension-compute extension) config))))

(define (shepherd-services-lieutenate parent-path parent-user parent-group)
  "Message-passing along the strings PARENT-USER and PARENT-GROUP,
returns a one argument procedure taking a record of the
<whispers-configuration> type and returning a list of <shepherd-service>
type guix records for the lieutenants of a whispers service at the top
of a whispers tree or sub-tree, as defined by the string PARENT-PATH."
  (lambda (lieutenant)
    (map (shepherd-service-lieutenate parent-path
                                      parent-user
                                      parent-group
                                      (service-value lieutenant))
         (filter (lambda (extension)
                   (equal? (service-extension-target extension)
                           shepherd-root-service-type))
                 (service-type-extensions (service-kind lieutenant))))))

(define (lieutenants-list parent-path
                          parent-user
                          parent-group
                          config)
  (apply append
         (apply append
                (map (shepherd-services-lieutenate parent-path
                                                   parent-user
                                                   parent-group)
                     (whispers-configuration-lieutenants config)))))

(define (shepherd-configuration-file parent-path
                                     parent-user
                                     parent-group
                                     config)
  "Returns a guix store shepherd configuration file for a whispers
shepherd service at the root of a whispers tree or sub-tree, as defined
by the string PARENT-PATH, message-passing along the strings PARENT-USER
and PARENT-PATH, configurable by CONFIG, a record of the
<whispers-configuration> type."
  ;; copied and modified from guix's gnu/services/shepherd.scm
  (let* ((lieutenants (lieutenants-list parent-path
                                        parent-user
                                        parent-group
                                        config))
         (files (map shepherd-service-file lieutenants)))
    (define shepherd-config
      #~(begin (unless (null? '#$files)
                 (apply register-services (map load '#$files)))
               (map apply
                    (map (lambda whatever start-in-the-background)
                         '#$(map shepherd-service-provision
                                 (filter shepherd-service-auto-start?
                                         lieutenants)))
                    '#$(map list (map shepherd-service-provision
                                      (filter shepherd-service-auto-start?
                                              lieutenants))))))
    (scheme-file (string-append
                  (symbol->string (whispers-configuration-name config))
                  ".conf")
                 shepherd-config)))

(define (whispers-shepherd-tree parent-path parent-user parent-group)
  "Returns a list of one <shepherd-service> type guix record defining
the shepherd service at the top of a shepherd tree of sub-tree, equipped
with a shepherd configuration file defining shepherd services for the
lieutenants of the returned serivce.

It takes the following parameters:
 - The string PARENT-PATH is the location of the shepherd service
daemonizing the returned whispers service in the top-level whispers tree
of the OS.
 - The string PARENT-USER is the user name of the user as which runs the
shepherd service daemonizing the returned whispers service in the
top-level whispers tree of the OS.
 - The string PARENT-GROUP is the group name of the group as which runs
the shepherd service daemonizing the returned whispers service in the
top-level whispers tree of the OS."
  (lambda (config)
    (list
     (let* ((name-sym (whispers-configuration-name config))
            (name-str (symbol->string name-sym))
            (user (whispers-configuration-user config))
            (group (whispers-configuration-group config))
            (timeout (whispers-configuration-timeout config))
            (lieutenants (lieutenants-list parent-path
                                           parent-user
                                           parent-group
                                           config))
            (lieutenants-names-sym (map car
                                        (map shepherd-service-provision
                                             lieutenants)))
            (lieutenants-names-str (map symbol->string
                                        lieutenants-names-sym))
            (lieutenants-path (string-append parent-path
                                             name-str
                                             "/"))
            (requires (whispers-configuration-requires config))
            (parent-runtime-dir (string-append "/run"
                                               parent-path))
            (runtime-dir (string-append parent-runtime-dir
                                        name-str))
            (pid-file (string-append runtime-dir
                                     "/"
                                     name-str
                                     ".pid"))
            (unix-socket-dir (string-append runtime-dir
                                            "/"
                                            "unix-sockets"))
            (unix-socket (string-append unix-socket-dir
                                        "/"
                                        name-str
                                        ".sock"))
            (superior-runtime-dir (dirname parent-runtime-dir))
            (superior-unix-socket-dir (string-append superior-runtime-dir
                                                     "/"
                                                     "unix-sockets"))
            (superior-unix-socket (string-append superior-unix-socket-dir
                                                 "/"
                                                 (basename
                                                  superior-runtime-dir)
                                                 ".sock"))
            (parent-log-dir (string-append "/var/log"
                                           parent-path))
            (log-dir (string-append parent-log-dir
                                    name-str))
            (log-file (string-append log-dir
                                     "/"
                                     name-str
                                     ".log"))
            (echo-package (whispers-configuration-coreutils-package config))
            (rmdir-package echo-package)
            (mount-pkg (whispers-configuration-util-linux-package config))
            (pre-start? (whispers-configuration-pre-start-action? config))
            (post-stop? (whispers-configuration-post-stop-action? config))
            (extra-actions (whispers-configuration-extra-actions config)))
       (shepherd-service
        (documentation "Shepherd controllable from the root shepherd.")
        (provision `(,name-sym))
        (requirement requires)
        (modules (append '((shepherd comm)
                           (shepherd support)
                           (ice-9 match)
                           (ice-9 ftw)
                           (ice-9 regex))
                         %default-modules))
        (start #~(lambda whatever
                   (perform-service-action (lookup-service '#$name-sym)
                                           'make-tmpfs
                                           #$runtime-dir
                                           #$user
                                           #$group
                                           #$(number->string #o755 8))
                   (perform-service-action (lookup-service '#$name-sym)
                                           'make-tmpfs
                                           #$unix-socket-dir
                                           #$user
                                           #$group
                                           #$(number->string #o700 8))
                   (perform-service-action (lookup-service '#$name-sym)
                                           'make-directory
                                           #$log-dir
                                           #$user
                                           #$group
                                           #$(number->string #o755 8))
                   (when (file-exists? #$unix-socket)
                     (delete-file #$unix-socket))
                   (when #$pre-start?
                     (perform-service-action (lookup-service '#$name-sym)
                                             'pre-start))
                   ((make-forkexec-constructor
                     (list "/run/current-system/profile/bin/shepherd"
                           (string-append
                            "--config="
                            #$(shepherd-configuration-file lieutenants-path
                                                           user
                                                           group
                                                           config))
                           (string-append "--pid="
                                          #$pid-file)
                           "-l"
                           #$log-file
                           "-s"
                           #$unix-socket)
                     #:user #$(if (equal? user parent-user)
                                  #f
                                  user)
                     #:group #$(if (equal? group parent-group)
                                   #f
                                   group)
                     #:pid-file #$pid-file
                     #:pid-file-timeout #$timeout))))
        (actions
         (append
          extra-actions
          (list
           (shepherd-action
            (name 'make-directory)
            (documentation "Create a directory at the string PATH
if it is not exiting. Set the uid of the sting USER, the gid of the
string GROUP and set the string MODE converted to an octal number as the
directory's permission bits.")
            (procedure
             #~(lambda (running path user group mode)
                 (unless (file-exists? path)
                   (display "Directory ")
                   (display path)
                   (display " not existing, creating.")
                   (display "\n")
                   (mkdir path))
                 (let ((uid (passwd:uid (getpwnam user)))
                       (gid (group:gid (getgrnam group))))
                   (chown path uid gid))
                 (chmod path (string->number mode 8)))))
           (shepherd-action
            (name 'make-tmpfs)
            (documentation "After creating a directory at the mount point if
necessary, mount a filesystem of type tmpfs at the mount point defined
by the string PATH if it is not already mounted, owned by the uid of the
string USER and with group set at the gid of the string GROUP, and mount
point permissions set to the string MODE taken as an octal number.")
            (procedure
             #~(lambda (running path user group mode)
                 (let ((uid (number->string (passwd:uid (getpwnam user))))
                       (gid (number->string (group:gid (getgrnam group)))))
                   (perform-service-action (lookup-service '#$name-sym)
                                           'clear-tmpfs
                                           path)
                   (perform-service-action (lookup-service '#$name-sym)
                                           'make-directory
                                           path
                                           user
                                           group
                                           mode)
                   ((make-system-constructor
                     #$(file-append mount-pkg "/bin/findmnt")
                     " "
                     path
                     " "
                     "&&"
                     " "
                     #$(file-append echo-package "/bin/echo")
                     " "
                     "tmpfs at"
                     " "
                     path
                     " "
                     "already mounted, aborting make-tmpfs action."
                     " "
                     "||"
                     " "
                     #$(file-append mount-pkg "/bin/mount")
                     " "
                     "-t"
                     " "
                     "tmpfs"
                     " "
                     "-o"
                     " "
                     (string-append "rw,nosuid,nodev,relatime"
                                    ",size=1633420k,nr_inodes=408355"
                                    ",mode="
                                    mode
                                    ",uid="
                                    uid
                                    ",gid="
                                    gid)
                     " "
                     "tmpfs"
                     " "
                     path))))))
           (shepherd-action
            (name 'subdirs-list)
            (documentation "Return the list of non-trivial
subdirectories of the directory whose path is the string PATH.")
            (procedure
             #~(lambda (running path)
                 (if (scandir path)
                     (let* ((dir? (lambda (file-name)
                                    (equal? 'directory
                                            (stat:type (stat file-name)))))
                            (subdir? (lambda (file-name)
                                       (and (dir? file-name)
                                            (not (equal? file-name
                                                         (string-append
                                                          path
                                                          "/"
                                                          ".")))
                                            (not (equal? file-name
                                                         (string-append
                                                          path
                                                          "/"
                                                          ".."))))))
                            (absolutes (map string-append
                                            (map (lambda (whatever)
                                                   (string-append path
                                                                  "/"))
                                                 (scandir path))
                                            (scandir path))))
                       (filter subdir? absolutes))
                     '()))))
           (shepherd-action
            (name 'clear-tmpfs)
            (documentation "Unmount a filesystem of type tmpfs at the
mount point defined by the string PATH if it is mounted. Delete the
mount point after unmounting.")
            (procedure
             #~(lambda (running path)
                 ;; It may be necessary to 'clear-tmpfs down the
                 ;; directory tree when a lieutenant is stopped using its
                 ;; internal stop root action instead of being stopped by
                 ;; its stop action in its controlling shepherd. Possibly
                 ;; also necessary in case a whispers shepherd process
                 ;; unexpectedly dies.
                 (let ((serv-obj (lookup-service '#$name-sym)))
                   (map (lambda (subdir-path)
                          (perform-service-action serv-obj
                                                  'clear-tmpfs
                                                  subdir-path))
                        (perform-service-action serv-obj
                                                'subdirs-list
                                                path)))
                 ((make-system-constructor
                   #$(file-append mount-pkg "/bin/findmnt")
                   " "
                   path
                   " "
                   "&&"
                   " "
                   #$(file-append echo-package "/bin/echo")
                   " "
                   "tmpfs at"
                   " "
                   path
                   " "
                   "mounted, proceeding with clear-tmpfs action."
                   " "
                   "&&"
                   " "
                   #$(file-append mount-pkg "/bin/umount")
                   " "
                   "-t"
                   " "
                   "tmpfs"
                   " "
                   path
                   " "
                   "&&"
                   " "
                   #$(file-append rmdir-package "/bin/rmdir")
                   " "
                   path)))))
           (shepherd-action
            (name 'socket)
            (documentation "Return a string containing the path to the
socket file of the shepherd daemon daemonized by this service.")
            (procedure
             #~(lambda (running)
                 #$unix-socket)))
           (shepherd-action
            (name 'display-socket)
            (documentation "Display to standard output a string containing
the path to the socket file of the shepherd daemon daemonized by this
service.")
            (procedure
             #~(lambda (running)
                 (let ((serv-obj (lookup-service '#$name-sym)))
                   (local-output (perform-service-action serv-obj
                                                         'socket))))))
           (shepherd-action
            (name 'superior-socket)
            (documentation "Return a string containing the path to the
socket file of the shepherd daemon daemonized by the whispers superior
of this service.")
            (procedure
             #~(lambda (running)
                 #$superior-unix-socket)))
           (shepherd-action
            (name 'display-superior-socket)
            (documentation "Display to standard output a string containing
the path to the socket file of the shepherd daemon daemonized by the
whispers superior of this service.")
            (procedure
             #~(lambda (running)
                 (let ((serv-obj (lookup-service '#$name-sym))
                       (sup 'superior-socket))
                   (local-output (perform-service-action serv-obj
                                                         sup))))))
           (shepherd-action
            (name 'display-load-path)
            (documentation "For debugging purposes, display the
guile load path that is enforced in this action's prodedure scope.")
            (procedure
             #~(lambda (running)
                 (display %load-path)
                 (display "\n"))))
           (shepherd-action
            (name 'display-load-compiled-path)
            (documentation "For debugging purposes, display the
guile compiled load path that is enforced in this action's prodedure
scope.")
            (procedure
             #~(lambda (running)
                 (display %load-compiled-path)
                 (display "\n"))))
           (shepherd-action
            (name 'display-lieutenant-action)
            (documentation "Perform the action named by the string
ACTION-STR of the service providing the string SERVICE-STR of the
shepherd daemon daemonized by this whispers service. The arguement
strings ARGS are passed to the action. For debugging purposes, display
the return value of the aforementioned lieutenant service's action.")
            (procedure
             #~(lambda (running action-str service-str . args)
                 (display (apply perform-service-action
                                 (append (list '#$name-sym
                                               'lieutenant-action
                                               action-str
                                               service-str)
                                         args)))
                 (display "\n"))))
           ;; FIXME?: there's problems with this? Maybe risky.
           (shepherd-action
            (name 'lieutenant-action)
            (documentation "Perform the action named by the string
ACTION-STR of the service providing the string SERVICE-STR of the
shepherd daemon daemonized by this whispers service. The arguement
strings ARGS are passed to the action. Return the return value of
the aforementioned lieutenant service's action.")
            (procedure
             #~(lambda (running action-str service-str . args)
                 ;; inspired by (shepherd scripts herd).
                 (define lieutenant-port
                   (let ((serv-obj (lookup-service '#$name-sym)))
                     (open-connection (perform-service-action serv-obj
                                                              'socket))))
                 (let ((action-sym (string->symbol action-str))
                       (service-sym (string->symbol service-str)))
                   (write-command (shepherd-command action-sym
                                                    service-sym
                                                    #:arguments
                                                    args)
                                  lieutenant-port))
                 (define ret
                   (match (read lieutenant-port)
                     (('reply ('version 0)
                              ('result result) ('error #f)
                              ('messages messages))
                      (unless (null? messages)
                        (for-each (lambda (message)
                                    (display message)
                                    (display "\n"))
                                  messages))
                      (if (pair? result)
                          (car result)
                          #f))))
                 (close-port lieutenant-port)
                 ret)))
           ;; FIXME: do not use: bad hangs (bidirectional communication?)
           (shepherd-action
            (name 'superior-action)
            (documentation "Perform the action named by the string
ACTION-STR of the service providing the string SERVICE-STR of the
shepherd daemon daemonizing the shepherd daemon of the whispers superior
of this whispers service. The arguement strings ARGS are passed to the
action. Return the return value of the aforementioned superior shepherd's
action.")
            (procedure
             #~(lambda (running action-str service-str . args)
                                        ; inspired by (shepherd scripts herd)
                 (define superior-port
                   (open-connection (car (perform-service-action
                                          (lookup-service '#$name-sym)
                                          'superior-socket))))
                 (let ((action-sym (string->symbol action-str))
                       (service-sym (string->symbol service-str)))
                   (write-command (shepherd-command action-sym
                                                    service-sym
                                                    #:arguments
                                                    args)
                                  superior-port))
                 (define ret
                   (match (read superior-port)
                     (('reply ('version 0)
                              ('result result) ('error #f)
                              ('messages messages))
                      (unless (null? messages)
                        (for-each (lambda (message)
                                    (display message)
                                    (display "\n"))
                                  messages))
                      (if (pair? result)
                          (car result)
                          #f))))
                 (close-port superior-port)
                 ret))))))
        (stop #~(lambda (pid)
                  (map (lambda (lieutenant-name)
                         (perform-service-action (lookup-service '#$name-sym)
                                                 'lieutenant-action
                                                 "stop"
                                                 lieutenant-name))
                       '#$lieutenants-names-str)
                  (define ret ((make-kill-destructor) pid))
                  (when #$post-stop?
                    (perform-service-action (lookup-service '#$name-sym)
                                            'post-stop))
                  (perform-service-action (lookup-service '#$name-sym)
                                          'clear-tmpfs
                                          #$unix-socket-dir)
                  (perform-service-action (lookup-service '#$name-sym)
                                          'clear-tmpfs
                                          #$runtime-dir)
                  ret))
        (auto-start? (whispers-configuration-auto-start? config)))))))

(define (whispers-service-type? service)
  "Returns a predicate which is true if SERVICE, a service object, is a
service of type whispers-service-type"
  (equal? (service-kind service) whispers-service-type))

(define (whispers-tree-log-files parent-path)
  "Returns a one argument procedure taking a record of the
<whispers-configuration> type as its argement and returning the list of
log files from the whispers-service-type services located under the
string PARENT-PATH in the whispers service top-level tree or sub-tree
configured by the aforementioned configuration record."
  (lambda (config)
    (let* ((name-sym (whispers-configuration-name config))
           (name-str (symbol->string name-sym))
           (lieutenants (whispers-configuration-lieutenants config)))
      (append `(,(string-append "/var/log"
                                parent-path
                                "/"
                                name-str
                                ".log"))
              (apply append
                     (map (whispers-tree-log-files (string-append parent-path
                                                                  "/"
                                                                  name-str))
                          (map service-value
                               (filter whispers-service-type?
                                       lieutenants))))))))

(define (whispers-log-rotation config)
  "Returns a record of the <log-rotation> type specifying the log
rotations of the whispers-service-type type services contained inside
the whispers tree of a top-level service of the whisper-service-type
type, configurable by CONFIG, a record of the <whispers-configuration>
type."
  (list (log-rotation (frequency 'daily)
                      (files ((whispers-tree-log-files "") config)))))

(define (whispers-user-accounts config)
  "Returns a list of group and user records needed to support a whispers
service tree, configuration by CONFIG, a record of the
<whispers-configuration> type."
  (let* ((user (whispers-configuration-user config))
         (extend-user? (whispers-configuration-extend-user? config))
         (group (whispers-configuration-group config))
         (extend-group? (whispers-configuration-extend-group? config))
         (lieutenants (whispers-configuration-lieutenants config))
         (whispers-lieutenants (filter whispers-service-type? lieutenants)))
    (append (if extend-group?
                (list (user-group (name group)
                                  (system? #t)))
                (list))
            (if extend-user?
                (list (user-account (name user)
                                    (group group)
                                    (create-home-directory? #f)
                                    (system? #t)))
                (list))
            (apply append
                   (map whispers-user-accounts
                        (map service-value
                             whispers-lieutenants))))))

(define (collect-compute-r service-type-target)
  "Return a one argument procedure taking a service object as its single
argument and returning a list appending outputs of the compute
procedures of all the extensions of target SERVICE-TYPE-TARGET from the
services which are not themselves of type whispers-service-type from a
whispers top-level tree or sub-tree defined by the service given as its
argument."
  (lambda (service)
    (if (whispers-service-type? service)
        (let* ((config (service-value service))
               (lieutenants (whispers-configuration-lieutenants config)))
          (apply append
                 (map (collect-compute-r service-type-target)
                      lieutenants)))
        (let* ((kind (service-kind service))
               (exts (filter (lambda (extension)
                               (equal? (service-extension-target extension)
                                       service-type-target))
                             (service-type-extensions kind)))
               (computes (map service-extension-compute exts)))
          (apply append
                 (map (lambda (compute)
                        (compute (service-value service)))
                      computes))))))

(define (collect-compute service-type-target)
  "Return a one argument procedure taking a whispers-configuration type
guix record as its single argument and returning a list appending
outputs of the compute procedures of all the extensions of target
SERVICE-TYPE-TARGET from the services which are not themselves of type
whispers-service-type from a whispers top-level tree defined by the
service given as its argument."
  (lambda (config)
    (let ((lieutenants (whispers-configuration-lieutenants config)))
      (apply append (map (collect-compute-r service-type-target)
                         lieutenants)))))

(define whispers-service-type
  (let ((coreutils-package whispers-configuration-coreutils-package)
        (util-linux-package whispers-configuration-util-linux-package)
        (whispers-pkg whispers-configuration-whispers-package)
        (extra-packages whispers-configuration-extra-packages)
        (get-lieutenants whispers-configuration-lieutenants))
    (service-type
     (name 'whispers)
     (description "Shepherd process controllable from the root shepherd.")
     (extensions
      (list (service-extension shepherd-root-service-type
                               (whispers-shepherd-tree "/" "root" "root"))
            (service-extension rottlog-service-type
                               whispers-log-rotation)
            (service-extension account-service-type
                               whispers-user-accounts)
            (service-extension profile-service-type
                               (lambda (config)
                                 (append (list (coreutils-package config)
                                               (util-linux-package config)
                                               (whispers-pkg config))
                                         (extra-packages config))))
            (service-extension profile-service-type
                               (collect-compute profile-service-type))
            (service-extension rottlog-service-type
                               (collect-compute rottlog-service-type))
            (service-extension rottlog-service-type
                               (collect-compute account-service-type))
            (service-extension mcron-service-type
                               (collect-compute mcron-service-type))))
     (compose concatenate)
     (extend (lambda (config lieutenants-new)
               (whispers-configuration
                (inherit config)
                (lieutenants (append (get-lieutenants config)
                                     lieutenants-new)))))
     (default-value (whispers-configuration)))))