;;; Whispers --- Stealth VPN and ssh tunneler ;;; Copyright © 2023 Runciter ;;; ;;; 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 . (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 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 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 type, returns a one argument procedure taking a root shepherd service extension as its single parameter and returning a 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 type and returning a list of 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 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 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 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 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 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 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)))))