aboutsummaryrefslogtreecommitdiff
path: root/whispers/services/whispers.scm
diff options
context:
space:
mode:
authorRunciter2024-10-28 02:19:54 +0800
committerRunciter2024-10-28 02:19:54 +0800
commitaf5bbe630cb990daf9f29b307572f965ee9fa099 (patch)
tree86baaba3b27b4eec62cb8ec40692812854901a3f /whispers/services/whispers.scm
downloadwhispers-af5bbe630cb990daf9f29b307572f965ee9fa099.tar.gz
Initial.
A .guix-authorizations A .guix-channel A COPYING A README A whispers/packages/dict.scm A whispers/packages/doc.scm A whispers/packages/pdf.scm A whispers/packages/sh.scm A whispers/packages/whispers.scm A whispers/services/console.scm A whispers/services/dict.scm A whispers/services/finance.scm A whispers/services/gps.scm A whispers/services/proton.scm A whispers/services/ssh-agent.scm A whispers/services/ssh-tunneler.scm A whispers/services/whispers.scm A whispers/services/whispers/finance.scm A whispers/services/whispers/gps.scm A whispers/services/whispers/mail.scm A whispers/services/whispers/ssh.scm A whispers/services/whispers/vpn.scm A whispers/services/whispers/xdg.scm A whispers/tests/ssh-tunneler.scm
Diffstat (limited to 'whispers/services/whispers.scm')
-rw-r--r--whispers/services/whispers.scm792
1 files changed, 792 insertions, 0 deletions
diff --git a/whispers/services/whispers.scm b/whispers/services/whispers.scm
new file mode 100644
index 0000000..bd2d7f5
--- /dev/null
+++ b/whispers/services/whispers.scm
@@ -0,0 +1,792 @@
+;;; 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)))))