;;; 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)))))
