diff options
Diffstat (limited to 'whispers/services/whispers.scm')
| -rw-r--r-- | whispers/services/whispers.scm | 760 |
1 files changed, 760 insertions, 0 deletions
diff --git a/whispers/services/whispers.scm b/whispers/services/whispers.scm new file mode 100644 index 0000000..e61d647 --- /dev/null +++ b/whispers/services/whispers.scm @@ -0,0 +1,760 @@ +;;; 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 boolean value + (log-rotation? whispers-configuration-log-rotation? + (default #t)) + ;; 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 (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 (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) + (append (whispers-configuration-lieutenants config) + (if (whispers-configuration-log-rotation? + config) + (list (service log-rotation-service-type)) + (list))))))) + +(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))) + (start-in-the-background + '#$(map car + (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-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 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 account-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))))) |