diff options
Diffstat (limited to 'whispers/services')
| -rw-r--r-- | whispers/services/console.scm | 89 | ||||
| -rw-r--r-- | whispers/services/dict.scm | 146 | ||||
| -rw-r--r-- | whispers/services/finance.scm | 283 | ||||
| -rw-r--r-- | whispers/services/gps.scm | 102 | ||||
| -rw-r--r-- | whispers/services/proton.scm | 117 | ||||
| -rw-r--r-- | whispers/services/ssh-agent.scm | 153 | ||||
| -rw-r--r-- | whispers/services/ssh-tunneler.scm | 904 | ||||
| -rw-r--r-- | whispers/services/whispers.scm | 792 | ||||
| -rw-r--r-- | whispers/services/whispers/finance.scm | 331 | ||||
| -rw-r--r-- | whispers/services/whispers/gps.scm | 100 | ||||
| -rw-r--r-- | whispers/services/whispers/mail.scm | 174 | ||||
| -rw-r--r-- | whispers/services/whispers/ssh.scm | 629 | ||||
| -rw-r--r-- | whispers/services/whispers/vpn.scm | 3424 | ||||
| -rw-r--r-- | whispers/services/whispers/xdg.scm | 81 |
14 files changed, 7325 insertions, 0 deletions
diff --git a/whispers/services/console.scm b/whispers/services/console.scm new file mode 100644 index 0000000..bb72a22 --- /dev/null +++ b/whispers/services/console.scm @@ -0,0 +1,89 @@ +;;; Whispers --- Stealth VPN and ssh tunneler +;;; Copyright © 2024 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 console) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu packages linux) + #:export (console-blank-configuration + console-blank-configuration? + make-console-blank-configuration + this-console-blank-configuration + console-blank-service-type)) + +(define-record-type* <console-blank-configuration> + console-blank-configuration make-console-blank-configuration + console-blank-configuration? + this-console-blank-configuration + ;; A file-like object + (util-linux-package console-blank-configuration-util-linux-package + (default util-linux)) + ;; An integer + (blank-time console-blank-configuration-blank-time + (default 10)) + ;; An integer + (powerdown-time console-blank-configuration-powerdown-time + (default 10))) + +(define (console-blank-shepherd-services config) + "Return a list of one shepherd services setting up Linux console screen +blanking and powerdown times, configurable by CONFIG, a record of the +<console-blank-configuration> type." + (let ((util-linux (console-blank-configuration-util-linux-package config)) + (blank (number->string + (console-blank-configuration-blank-time config))) + (powerdown (number->string + (console-blank-configuration-powerdown-time config)))) + (list + (shepherd-service + (documentation "Setup Linux console screen blanking and powerdown.") + (provision (list 'console-blank)) + + ;; Start after mingetty has been started on tty1 + (requirement (list 'term-tty1 'console-font-tty1)) + + (start #~(lambda _ + (case (status:exit-val + (system + (string-append #$(file-append util-linux + "/bin/setterm") + " --blank=" + #$blank + " --powerdown=" + #$powerdown + " </dev/tty1 >/dev/tty1"))) + ((0) #t) + (else #f)))) + (stop #~(const #f)) + (respawn? #f))))) + +(define console-blank-service-type + (service-type + (name 'console-blank) + (description "Setup screen blanking and powerdown on the Linux console") + (extensions + (list (service-extension shepherd-root-service-type + console-blank-shepherd-services) + (service-extension + profile-service-type + (lambda (config) + (list + (console-blank-configuration-util-linux-package config)))))) + (default-value (console-blank-configuration)))) diff --git a/whispers/services/dict.scm b/whispers/services/dict.scm new file mode 100644 index 0000000..8c481f5 --- /dev/null +++ b/whispers/services/dict.scm @@ -0,0 +1,146 @@ +;;; Whispers --- Stealth VPN and ssh tunneler +;;; Copyright © 2024 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 dict) + #:use-module (guix gexp) + #:use-module (gnu services dict) + #:use-module (whispers packages dict) + #:export (%dictorg-handler + freedict-dictorg-database + %freedict-dictorg-databases + %cedict-dictorg-databases)) + +(define %dictorg-handler + (dicod-handler (name "dictorg") + (module "dictorg") + (options (list #~(string-append "dbdir=/"))))) + +(define (freedict-dictorg-database dict-name) + "Return a record of type @code{<dicod-database>} that configures a +database for the freedict multilingual dictionary named by the string +DICT-NAME." + (dicod-database (name (string-append "freedict-" + dict-name)) + (complex? #t) + (handler "dictorg") + (options (list #~(string-append "database=" + #$freedict-dictionaries + "/share/dictd/" + #$dict-name))))) +(define %freedict-dictorg-databases + (map freedict-dictorg-database (list "afr-deu" + "afr-eng" + "ara-eng" + "bre-fra" + "ces-eng" + "ckb-kmr" + "cym-eng" + "dan-eng" + "deu-ita" + "deu-kur" + "deu-nld" + "deu-por" + "deu-tur" + "eng-afr" + "eng-ara" + "eng-ces" + "eng-cym" + "eng-dan" + "eng-ell" + "eng-fra" + "eng-gle" + "eng-hin" + "eng-hrv" + "eng-hun" + "eng-ita" + "eng-lat" + "eng-lit" + "eng-nld" + "eng-pol" + "eng-por" + "eng-rom" + "eng-rus" + "eng-spa" + "eng-srp" + "eng-swh" + "eng-tur" + "fra-bre" + "fra-eng" + "fra-nld" + "gla-deu" + "gle-eng" + "gle-pol" + "hrv-eng" + "hun-eng" + "isl-eng" + "ita-deu" + "ita-eng" + "jpn-deu" + "jpn-eng" + "jpn-fra" + "jpn-rus" + "kha-deu" + "kha-eng" + "kur-deu" + "kur-eng" + "kur-tur" + "lat-deu" + "lat-eng" + "lit-eng" + "mkd-bul" + "nld-deu" + "nld-eng" + "nld-fra" + "nno-nob" + "oci-cat" + "pol-gle" + "por-deu" + "por-eng" + "san-deu" + "slk-eng" + "slv-eng" + "spa-ast" + "spa-eng" + "spa-por" + "srp-eng" + "swe-eng" + "swh-eng" + "swh-pol" + "tur-deu" + "tur-eng" + "wol-fra"))) + +(define (cedict-dictorg-database variant) + "Return a record of type @code{<dicod-database>} that configures a +database for the CC-CEDICT chinese-english multilingual dictionary +variant described by the string VARIANT." + (dicod-database (name (string-append "cedict-" + variant)) + (complex? #t) + (handler "dictorg") + (options (list #~(string-append "database=" + #$cc-cedict + "/share/cc-cedict/cedict-" + #$variant))))) + +(define %cedict-dictorg-databases + (map cedict-dictorg-database (list "bare" + "numb" + "pinyin" + "smpl" + "trad"))) diff --git a/whispers/services/finance.scm b/whispers/services/finance.scm new file mode 100644 index 0000000..dd20248 --- /dev/null +++ b/whispers/services/finance.scm @@ -0,0 +1,283 @@ +;;; 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 finance) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services admin) + #:use-module (gnu packages finance) + #:export (bitcoin-configuration + bitcoin-service-type + bitcoin-configuration? + bitcoin-service-type + monero-configuration + monero-service-type + monero-configuration? + monero-service-type)) + +(define-record-type* <bitcoin-configuration> + bitcoin-configuration make-bitcoin-configuration + bitcoin-configuration? + this-bitcoin-configuration + ;; A file-like object + (bitcoin-package bitcoin-configuration-bitcoin-package + (default bitcoin-core)) + ;; A string + (user bitcoin-configuration-user + (default "johndoe")) + ;; A boolean value + (walletdir-opt? bitcoin-configuration-walletdir-opt? + (default #f)) + ;; A string + (walletdir bitcoin-configuration-walletdir + (default "")) + ;; A boolean value + (proxy-opt? bitcoin-configuration-proxy-opt? + (default #f)) + ;; A string + (proxy bitcoin-configuration-proxy + (default "")) + ;; A string + (pid bitcoin-configuration-pid + (default "")) + ;; A string + (log-folder bitcoin-configuration-log-folder + (default "/var/run")) + ;; A string + (log-file-name bitcoin-configuration-log-file-name + (default "bitcoin.log")) + ;; A boolean value + (%auto-start? bitcoin-configuration-auto-start? + (default #t))) + +(define-record-type* <monero-configuration> + monero-configuration make-monero-configuration + monero-configuration? + this-monero-configuration + ;; A file-like object + (monero-package monero-configuration-monero-package + (default monero)) + ;; A string + (user monero-configuration-user + (default "johndoe")) + ;; A boolean value + (proxy-opt? monero-configuration-proxy-opt? + (default #f)) + ;; A string + (proxy monero-configuration-proxy + (default "")) + ;; A boolean value + (tx-proxy-opt? monero-configuration-tx-proxy-opt? + (default #f)) + ;; A string + (tx-proxy monero-configuration-tx-proxy + (default "")) + ;; A boolean value + (prune-blockchain-opt? monero-configuration-prune-blockchain-opt? + (default #f)) + ;; A string + (pidfile monero-configuration-pidfile + (default "")) + ;; An integer + (pid-file-timeout monero-configuration-pid-file-timeout + (default 5)) + ;; A string + (log-folder monero-configuration-log-folder + (default "/var/run")) + ;; A string + (stdout-log-file-name monero-configuration-stdout-log-file-name + (default "monero.log")) + ;; A string + (monero-log-file-name monero-configuration-monero-log-file-name + (default "bitmonero.log")) + ;; A boolean value + (%auto-start? monero-configuration-auto-start? + (default #t))) + +(define (bitcoin-log-file-path config) + "Returns a string specifying the path to the log file of a bitcoin +node service configurable by CONFIG, a record of the +<bitcoin-configuration> type." + (string-append (bitcoin-configuration-log-folder config) + "/" + (bitcoin-configuration-log-file-name config))) + +(define (bitcoin-log-rotation config) + "Returns a list of log-rotation records specifying how to rotate the +logs of a bitvoin node service configurable by CONFIG, a record of the +<bitcoin-configuration> type." + (list (log-rotation (frequency 'daily) + (files `(,(bitcoin-log-file-path config)))))) + +(define (bitcoin-constructor-gexp config) + "Returns a G-exp to a procedure starting a bitcoin node daemon, +configurable by CONFIG, a record of the <bitcoin-configuration> type." + (let ((bitcoin-package (bitcoin-configuration-bitcoin-package config)) + (user (bitcoin-configuration-user config)) + (walletdir-opt? (bitcoin-configuration-walletdir-opt? config)) + (walletdir (bitcoin-configuration-walletdir config)) + (proxy-opt? (bitcoin-configuration-proxy-opt? config)) + (proxy (bitcoin-configuration-proxy config)) + (pid-file-path (bitcoin-configuration-pid config)) + (log-file-path (bitcoin-log-file-path config))) + #~(make-forkexec-constructor + (append (list #$(file-append bitcoin-package + "/bin/bitcoind") + (string-append "-datadir=" + (passwd:dir (getpwnam #$user)) + "/.bitcoin")) + (if #$walletdir-opt? + (list (string-append "-walletdir=" + #$walletdir)) + (list)) + (if #$proxy-opt? + (list (string-append "-proxy=" + #$proxy)) + (list)) + (list (string-append "-pid=" + #$pid-file-path))) + #:pid-file + #$pid-file-path + #:log-file + #$log-file-path))) + +(define (bitcoin-shepherd-services config) + "Returns a list of shepherd services handling a bitcoin node +configured by CONFIG, a record of the <bitcoin-configuration> type." + (let ((auto-start? (bitcoin-configuration-auto-start? config))) + (list + (shepherd-service + (documentation "Bitcoin node") + (provision '(bitcoin)) + (requirement '()) + (start (bitcoin-constructor-gexp config)) + (stop #~(make-kill-destructor)) + (auto-start? auto-start?))))) + +(define bitcoin-service-type + (service-type + (name 'bitcoin) + (description "Bitcoin node service") + (extensions + (list (service-extension shepherd-root-service-type + bitcoin-shepherd-services) + (service-extension rottlog-service-type + bitcoin-log-rotation) + (service-extension + profile-service-type + (lambda (config) + (list (bitcoin-configuration-bitcoin-package config)))))) + (default-value (bitcoin-configuration)))) + +(define (stdout-monero-log-file-path config) + "Returns a string specifying the path to the log file of the standard +output of a monero node service configurable by CONFIG, a record of the +<monero-configuration> type." + (string-append (monero-configuration-log-folder config) + "/" + (monero-configuration-stdout-log-file-name config))) + +(define (monero-log-file-path config) + "Returns a string specifying the path to the log file of a monero node +service configurable by CONFIG, a record of the <monero-configuration> +type." + (string-append (monero-configuration-log-folder config) + "/" + (monero-configuration-monero-log-file-name config))) + +(define (monero-log-rotation config) + "Returns a list of log-rotation records specifying how to rotate the +logs of a monero node service configurable by CONFIG, a record of +the <monero-configuration> type." + (list (log-rotation (frequency 'daily) + (files `(,(monero-log-file-path config)))) + (log-rotation (frequency 'daily) + (files `(,(stdout-monero-log-file-path config)))))) + +(define (monero-constructor-gexp config) + "Returns a G-exp to a procedure starting a monero node daemon, +configurable by CONFIG, a record of the <monero-configuration> type." + (let ((monero-package (monero-configuration-monero-package config)) + (user (monero-configuration-user config)) + (proxy-opt? (monero-configuration-proxy-opt? config)) + (proxy (monero-configuration-proxy config)) + (tx-proxy-opt? (monero-configuration-tx-proxy-opt? config)) + (tx-proxy (monero-configuration-tx-proxy config)) + (pid-file-path (monero-configuration-pidfile config)) + (prune? (monero-configuration-prune-blockchain-opt? config)) + (pid-file-timeout (monero-configuration-pid-file-timeout config)) + (log-file-path ( monero-log-file-path config)) + (stdout-log-file-path (stdout-monero-log-file-path config))) + #~(make-forkexec-constructor + (append (list #$(file-append monero-package + "/bin/monerod") + "--data-dir" + (string-append (passwd:dir (getpwnam #$user)) + "/.bitmonero")) + (if #$proxy-opt? + (list "--proxy" + #$proxy) + (list)) + (if #$tx-proxy-opt? + (list "--tx-proxy" + #$tx-proxy) + (list)) + (if #$prune? + (list "--prune-blockchain") + (list)) + (list "--detach" + "--pid" + #$pid-file-path + "--log-file" + #$log-file-path)) + #:pid-file + #$pid-file-path + #:pid-file-timeout + #$pid-file-timeout + #:log-file + #$stdout-log-file-path))) + +(define (monero-shepherd-services config) + "Returns a list of shepherd services handling a monero node +configured by CONFIG, a record of the <monero-configuration> type." + (let ((auto-start? (monero-configuration-auto-start? config))) + (list + (shepherd-service + (documentation "Monero node") + (provision '(monero)) + (requirement '()) + (start (monero-constructor-gexp config)) + (stop #~(make-kill-destructor)) + (auto-start? auto-start?))))) + +(define monero-service-type + (service-type + (name 'monero) + (description "Monero node service") + (extensions + (list (service-extension shepherd-root-service-type + monero-shepherd-services) + (service-extension rottlog-service-type + monero-log-rotation) + (service-extension + profile-service-type + (lambda (config) + (list (monero-configuration-monero-package config)))))) + (default-value (monero-configuration)))) diff --git a/whispers/services/gps.scm b/whispers/services/gps.scm new file mode 100644 index 0000000..5c1b33f --- /dev/null +++ b/whispers/services/gps.scm @@ -0,0 +1,102 @@ +;;; Whispers --- Stealth VPN and ssh tunneler +;;; Copyright © 2024 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 gps) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services admin) + #:use-module (gnu packages gps) + #:export (gpsd-configuration + gpsd-configuration? + gpsd-service-type)) + +(define-record-type* <gpsd-configuration> + gpsd-configuration make-gpsd-configuration + gpsd-configuration? + this-gpsd-configuration + ;; A file-like object + (gpsd-package gpsd-configuration-gpsd-package + (default gpsd)) + ;; A symbol + (provision gpsd-configuration-provision + (default (string->symbol + (string-append + "gpsd-" + (number->string + (gpsd-configuration-port + this-gpsd-configuration))))) + (thunked)) + ;; A string + (source gpsd-configuration-source + (default "/dev/ttyUSB0")) + ;; An integer + (port gpsd-configuration-port + (default 2947)) + ;; An integer + (listen-any? gpsd-configuration-listen-any? + (default #f)) + ;; A boolean value + (%auto-start? gpsd-configuration-auto-start? + (default #t))) + +(define (constructor-gexp config) + "Returns a G-exp to start a gpsd shepherd service, configurable by +CONFIG, a record of the <gpsd-configuration> type." + (let ((gpsd-package (gpsd-configuration-gpsd-package config)) + (listen-any? (gpsd-configuration-listen-any? config)) + (port (gpsd-configuration-port config)) + (source (gpsd-configuration-source config))) + #~(make-forkexec-constructor (append (list #$(file-append gpsd-package + "/sbin/gpsd") + "-N" + "-P" + #$(number->string port)) + (if #$listen-any? + (list "-G") + (list)) + (list #$source))))) + +(define (gpsd-shepherd-services config) + "Returns a list of shepherd services handling a gpsd daemon +configured by CONFIG, a record of the <gpsd-configuration> +type." + (let ((auto-start? (gpsd-configuration-auto-start? config))) + (list + (shepherd-service + (documentation (string-append "gpsd service.")) + (provision (list (gpsd-configuration-provision config))) + (requirement '()) + (start (constructor-gexp config)) + (stop #~(make-kill-destructor)) + (auto-start? auto-start?))))) + +(define gpsd-service-type + (service-type + (name 'gpsd) + (description "gpsd service") + (extensions + (list (service-extension shepherd-root-service-type + gpsd-shepherd-services) + (service-extension + profile-service-type + (lambda (config) + (list + (gpsd-configuration-gpsd-package config)))))) + (default-value (gpsd-configuration)))) diff --git a/whispers/services/proton.scm b/whispers/services/proton.scm new file mode 100644 index 0000000..41bf197 --- /dev/null +++ b/whispers/services/proton.scm @@ -0,0 +1,117 @@ +;;; Whispers --- Stealth VPN and ssh tunneler +;;; Copyright © 2024 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 proton) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services admin) + #:use-module (gnu packages mail) + #:export (hydroxide-configuration + hydroxide-service-type + hydroxide-configuration? + hydroxide-service-type)) + +(define-record-type* <hydroxide-configuration> + hydroxide-configuration make-hydroxide-configuration + hydroxide-configuration? + this-hydroxide-configuration + ;; A file-like object + (hydroxide-package hydroxide-configuration-hydroxide-package + (default hydroxide)) + ;; A string + (user hydroxide-configuration-user + (default "johndoe")) + ;; A boolean value + (https-proxy? hydroxide-configuration-https-proxy? + (default #f)) + ;; A string + (https-proxy hydroxide-configuration-https-proxy + (default "socks5://localhost:8971")) + ;; A boolean value + (imap? hydroxide-configuration-imap? + (default #t)) + ;; A boolean value + (smtp? hydroxide-configuration-smtp? + (default #t)) + ;; A boolean value + (carddav? hydroxide-configuration-carddav? + (default #t)) + ;; A boolean value + (%auto-start? hydroxide-configuration-auto-start? + (default #t))) + +(define (hydroxide-constructor-gexp config) + "Returns a G-exp to a procedure starting an hydroxide server +configurable by CONFIG, a record of the <hydroxide-configuration> type." + (let ((hydroxide-package (hydroxide-configuration-hydroxide-package + config)) + (user (hydroxide-configuration-user config)) + (https-proxy? (hydroxide-configuration-https-proxy? config)) + (https-proxy (hydroxide-configuration-https-proxy config)) + (imap? (hydroxide-configuration-imap? config)) + (carddav? (hydroxide-configuration-carddav? config)) + (smtp? (hydroxide-configuration-smtp? config))) + #~(make-forkexec-constructor + (append (list #$(file-append hydroxide-package + "/bin/hydroxide")) + (if #$imap? + (list) + (list "--disable-imap")) + (if #$carddav? + (list) + (list "--disable-carddav")) + (if #$smtp? + (list) + (list "--disable-smtp")) + (list "serve")) + #:environment-variables + (append (list (string-append "XDG_CONFIG_HOME=" + (passwd:dir (getpwnam #$user)) + "/.config")) + #$(if https-proxy? + #~(list (string-append "https_proxy=" + #$https-proxy)) + #~(list)))))) + +(define (hydroxide-shepherd-services config) + "Returns a list of shepherd services handling an hydroxide server +configured by CONFIG, a record of the <hydroxide-configuration> type." + (let ((auto-start? (hydroxide-configuration-auto-start? config))) + (list + (shepherd-service + (documentation "Hydroxide service") + (provision '(hydroxide)) + (requirement '()) + (start (hydroxide-constructor-gexp config)) + (stop #~(make-kill-destructor)) + (auto-start? auto-start?))))) + +(define hydroxide-service-type + (service-type + (name 'hydroxide) + (description "Hydroxide node service") + (extensions + (list (service-extension shepherd-root-service-type + hydroxide-shepherd-services) + (service-extension + profile-service-type + (lambda (config) + (list (hydroxide-configuration-hydroxide-package config)))))) + (default-value (hydroxide-configuration)))) diff --git a/whispers/services/ssh-agent.scm b/whispers/services/ssh-agent.scm new file mode 100644 index 0000000..834b36a --- /dev/null +++ b/whispers/services/ssh-agent.scm @@ -0,0 +1,153 @@ +;;; 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 ssh-agent) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services admin) + #:use-module (gnu packages ssh) + #:export (ssh-agent-configuration + ssh-agent-configuration? + ssh-agent-service-type)) + +(define-record-type* <ssh-agent-configuration> + ssh-agent-configuration make-ssh-agent-configuration + ssh-agent-configuration? + this-ssh-agent-configuration + ;; A file-like object + (ssh-package ssh-agent-configuration-ssh-package + (default openssh)) + ;; A string + (socket-folder ssh-agent-configuration-socket-folder + (default "/var/run/ssh-agent")) + ;; A string + (socket-file-name ssh-agent-configuration-socket-file-name + (default "ssh-agent.sock")) + ;; A string + (log-folder ssh-agent-configuration-log-folder + (default "/var/log")) + ;; A string + (log-file-name ssh-agent-configuration-log-file-name + (default "ssh-agent.log")) + ;; A list of strings + (auto-added-keys ssh-agent-configuration-auto-added-keys + (default '())) + ;; A boolean value + (%auto-start? ssh-agent-configuration-auto-start? + (default #t))) + +(define (socket-file-path config) + "Returns a string specifying the path to the log file of an ssh agent +service configurable by CONFIG, a record of the +<ssh-agent-configuration> type." + (string-append (ssh-agent-configuration-socket-folder config) + "/" + (ssh-agent-configuration-socket-file-name config))) + +(define (log-file-path config) + "Returns a string specifying the path to the log file of an ssh agent +service configurable by CONFIG, a record of the +<ssh-agent-configuration> type." + (string-append (ssh-agent-configuration-log-folder config) + "/" + (ssh-agent-configuration-log-file-name config))) + +(define (ssh-agent-log-rotation config) + "Returns a list of log-rotation records specifying how to rotate the +logs of as ssh aggent service configurable by CONFIG, a record of +the <ssh-agent-configuration> type." + (list (log-rotation (frequency 'daily) + (files `(,(log-file-path config)))))) + +(define (add-key-procedure config) + "Returns a G-exp to a procedure adding a private key to a running ssh +agent daemon, configurable by CONFIG, a record of the +<ssh-agent-configuration> type." + (let ((ssh-package (ssh-agent-configuration-ssh-package config))) + #~(lambda (running key-path) + ((make-system-constructor + (string-append "SSH_AUTH_SOCK=" + #$(socket-file-path config) + " " + #$(file-append ssh-package + "/bin/ssh-add") + " " + key-path)))))) + +(define (constructor-gexp config) + "Returns a G-exp to a procedure adding a private key to a running ssh +agent daemon, configurable by CONFIG, a record of the +<ssh-agent-configuration> type." + (let ((ssh-package (ssh-agent-configuration-ssh-package config)) + (auto-added-keys (ssh-agent-configuration-auto-added-keys config)) + (socket-file-path (socket-file-path config)) + (log-file-path (log-file-path config))) + #~(lambda whatever + (let ((ret ((make-forkexec-constructor + (list #$(file-append ssh-package + "/bin/ssh-agent") + "-d" + "-a" + #$socket-file-path) + #:log-file + #$log-file-path)))) + (map (lambda (key) + (action 'ssh-agent 'add-key key)) + '#$auto-added-keys) + ret)))) + +(define (ssh-agent-shepherd-services config) + "Returns a list of shepherd services handling an ssh agent daemon +configured by CONFIG, a record of the <ssh-agent-configuration> +type." + (let ((auto-start? (ssh-agent-configuration-auto-start? config))) + (list + (shepherd-service + (documentation (string-append "Ssh agent service, socket file can +be found at " + (socket-file-path config) + ".")) + (provision '(ssh-agent)) + (requirement '()) + (start (constructor-gexp config)) + (stop #~(make-kill-destructor)) + (actions + (list + (shepherd-action (name 'add-key) + (documentation "Add the private key found at at +the path KEY-PATH to a started ssh-agent daemon.") + (procedure (add-key-procedure config))))) + (auto-start? auto-start?))))) + +(define ssh-agent-service-type + (service-type + (name 'ssh-agent) + (description "Ssh agent service") + (extensions + (list (service-extension shepherd-root-service-type + ssh-agent-shepherd-services) + (service-extension rottlog-service-type + ssh-agent-log-rotation) + (service-extension + profile-service-type + (lambda (config) + (list + (ssh-agent-configuration-ssh-package config)))))) + (default-value (ssh-agent-configuration)))) diff --git a/whispers/services/ssh-tunneler.scm b/whispers/services/ssh-tunneler.scm new file mode 100644 index 0000000..18cb4f3 --- /dev/null +++ b/whispers/services/ssh-tunneler.scm @@ -0,0 +1,904 @@ +;;; Whispers --- Stealth VPN and ssh tunnelerq +;;; 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 ssh-tunneler) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services admin) + #:use-module (gnu services mcron) + #:use-module (whispers services whispers) + #:use-module (gnu packages base) + #:use-module (gnu packages admin) + #:use-module (gnu packages linux) + #:use-module (gnu packages ssh) + #:use-module (whispers packages doc) + #:use-module (gnu home services) + #:use-module (gnu home services shepherd) + #:export (ssh-connection-configuration + make-ssh-connection-configuration + ssh-connection-configuration? + this-ssh-connection-configuration + ssh-connection-configuration-forwards + ssh-forward-configuration + this-ssh-forward-configuration + ssh-forward-configuration? + make-ssh-forward-configuration + ssh-forward-configuration-entry-port + socks-proxy-configuration + this-socks-proxy-configuration + socks-proxy-configuration? + make-socks-proxy-configuration + dynamic-forward-configuration + port-forward-configuration + reverse-port-forward-configuration + tunnel-forward-configuration + persistent-ssh-name + persistent-ssh-service-type + home-persistent-ssh-service-type)) + +(define-record-type* <ssh-connection-configuration> + ssh-connection-configuration make-ssh-connection-configuration + ssh-connection-configuration? + this-ssh-connection-configuration + ;; A file-like object. + (shepherd-package ssh-connection-configuration-shepherd-package + (default shepherd)) + ;; A file-like object. + (ssh-package ssh-connection-configuration-ssh-package + (default openssh)) + ;; A file-like object. + (netcat-package ssh-connection-configuration-netcat-package + (default netcat-openbsd)) + ;; A file-like object. + (sshpass-package ssh-connection-configuration-sshpass-package + (default sshpass)) + ;; A file-like object. + (ineutils-package ssh-connection-configuration-inetutils-package + (default inetutils)) + ;; A file-like object. + (procps-package ssh-connection-configuration-procps-package + (default procps)) + ;; A guix record of type <socks-proxy-configuration>. + (socks-proxy-config ssh-connection-configuration-socks-proxy-config + (default (socks-proxy-configuration))) + ;; A boolean value. + (agent? ssh-connection-configuration-agent? + (default #f)) + (agent-socket ssh-connection-configuration-agent-socket + (default "")) + ;; A boolean value. + ;; A string. + ;; It is thinked so that the use-agent? switch of + ;; <whispers-forwardings> binds both agent? and is-rea-file in + ;; opposite states, without exposing this detail to the user. + (id-rsa-file? ssh-connection-configuration-id-rsa-file? + (default (not + (ssh-connection-configuration-agent? + this-ssh-connection-configuration))) + (thunked)) + ;; A string. + (id-rsa-file ssh-connection-configuration-id-rsa-file + (default "/root/.ssh/id_rsa")) + ;; A boolean value. + (clear-password? ssh-connection-configuration-clear-password? + (default #f)) + ;; A string. + (sshd-user-password ssh-connection-configuration-sshd-user-password + (default "none")) + ;; A string. + (sshd-user ssh-connection-configuration-sshd-user + (default "root")) + ;; A string. + (sshd-host ssh-connection-configuration-sshd-host + (default "127.0.0.1")) + ;; An integer. + (sshd-port ssh-connection-configuration-sshd-port + (default 22)) + ;; A boolean value. + (gateway-ports? ssh-connection-configuration-gateway-ports? + (default #t)) + ;; A list of strings. + (known-hosts-files ssh-connection-configuration-known-hosts-files + (default (list "~/.ssh/known_hosts" + "~/.ssh/known_hosts2"))) + ;; A string. + (strict-check ssh-connection-configuration-strict-check + (default "yes")) + ;; An integer. + (server-alive-interval ssh-connection-configuration-server-alive-interval + (default 30)) + ;; An integer. + (server-alive-count-max ssh-connection-configuration-server-alive-count-max + (default 6)) + ;; A string. + (name-prefix ssh-connection-configuration-name-prefix + (default "ssh-forwards")) + ;; A boolean value. + (suffix-name? ssh-connection-configuration-suffix-name? + (default #t)) + ;; A list of strings. + (special-options ssh-connection-configuration-special-options + (default (list))) + ;; A list of <ssh-forward-configuration> records. + (forwards ssh-connection-configuration-forwards + (default '())) + ;; A boolean value. + (exit-forward-failure? ssh-connection-configuration-exit-forward-failure? + (default #t)) + ;; An integer. + (connection-attempts ssh-connection-configuration-connection-attempts + (default 1)) + ;; A boolean value. + (local-command? ssh-connection-configuration-local-command? + (default (ssh-connection-configuration-pid-file? + this-ssh-connection-configuration)) + (thunked)) + ;; A list of strings + (extra-local-commands ssh-connection-configuration-extra-local-commands + (default '())) + ;; A boolean value. + (require-networking? ssh-connection-configuration-require-networking? + (default #t)) + ;; A list of symbols. + (extra-requires ssh-connection-configuration-extra-requires + (default '())) + ;; A boolean value. + (elogind? ssh-connection-configuration-elogind? + (default #f)) + ;; A boolean value. + (lieutenant? ssh-connection-configuration-lieutenant? + (default #f)) + ;; A string. + (lieutenant-path ssh-connection-configuration-lieutenant-path + (default "")) + ;; A boolean value. + (pid-file? ssh-connection-configuration-pid-file? + (default #t)) + ;; A boolean value. + (pid-folder-override? ssh-connection-configuration-pid-folder-override? + (default #f)) + ;; A string. + (pid-folder-override ssh-connection-configuration-pid-folder-override + (default "/var/run")) + ;; A boolean value. + (timeout-override? ssh-connection-configuration-timeout-override? + (default #f)) + ;; An integer. + (timeout-override ssh-connection-configuration-timeout-override + (default 5)) + ;; A boolean value. + (dedicated-log-file? ssh-connection-configuration-dedicated-log-file? + (default #f)) + ;; A boolean value. + (log-rotate? ssh-connection-configuration-log-rotate? + (default #f)) + ;; A boolean value. + (log-folder-override? ssh-connection-configuration-log-folder-override? + (default #f)) + ;; A string. + (log-folder-override ssh-connection-configuration-log-folder-override + (default "/var/run")) + ;; An integer between 0 and 3, both included. + (verbosity ssh-connection-configuration-verbosity + (default 0)) + ;; A boolean value. + (command? ssh-connection-configuration-command? + (default #f)) + ;; A string. + (command ssh-connection-configuration-command + (default '())) + ;; A quoted cron job time specification. + (resurrect-time-spec ssh-connection-configuration-resurrect-time-spec + (default ''(next-minute '(47)))) + ;; A boolean value. + (flat-resurrect? ssh-connection-configuration-flat-resurrect? + (default #f)) + ;; A quoted cron job time specification. + (force-resurrect-time-spec + ssh-connection-configuration-force-resurrect-time-spec + (default ''(next-hour '(3)))) + ;; A boolean value. + (flat-force-resurrect? ssh-connection-configuration-flat-force-resurrect? + (default #f)) + ;; A boolean value. + (%cron-resurrect? ssh-connection-configuration-cron-resurrect? + (default #f)) + ;; A boolean value. + (%cron-force-resurrect? ssh-connection-configuration-cron-force-resurrect? + (default #f)) + ;; A boolean value. + (%auto-start? ssh-connection-configuration-auto-start? + (default #f))) + +(define-record-type* <ssh-forward-configuration> + ssh-forward-configuration make-ssh-forward-configuration + ssh-forward-configuration? + this-ssh-forward-configuration + ;; A symbol which can be 'dynamic, 'port, 'reverse-port or 'tunnel + (forward-type ssh-forward-configuration-forward-type + (default 'dynamic)) + ;; A symbol which can be 'preset or 'any when the 'forward-type field + ;; is 'tunnel, and which can be 'port or 'socket otherwise. It is + ;; ignored when the 'forward-type field is 'dynamic. + (entry-type ssh-forward-configuration-entry-type + (default 'port)) + ;; A symbol which can be 'preset or 'any when the 'forward-type field + ;; is 'tunnel, and which can be 'port or 'socket otherwise. It is + ;; ignored when the 'forward-type field evaluates to 'dynamic. + (exit-type ssh-forward-configuration-exit-type + (default 'port)) + ;; An integer + (entry-port ssh-forward-configuration-entry-port + (default 8971)) + ;; An integer + (exit-port ssh-forward-configuration-exit-port + (default 22)) + ;; A string + (entry-socket ssh-forward-configuration-entry-socket + (default "")) + ;; A string + (exit-socket ssh-forward-configuration-exit-socket + (default "")) + ;; A string + (forward-host ssh-forward-configuration-exit-host + (default "127.0.0.1")) + ;; An integer + (entry-tun ssh-forward-configuration-entry-tun + (default 0)) + ;; An integer + (exit-tun ssh-forward-configuration-exit-tun + (default 0))) + +(define-record-type* <socks-proxy-configuration> + socks-proxy-configuration make-socks-proxy-configuration + socks-proxy-configuration? + this-socks-proxy-configuration + ;; A boolean value + (use-proxy? socks-proxy-configuration-use-proxy? + (default #f)) + ;; A boolean value + (extend? socks-proxy-configuration-extend? + (default (socks-proxy-configuration-use-proxy? + this-socks-proxy-configuration)) + (thunked)) + ;; An integer + (port socks-proxy-configuration-port + (default + (if + (socks-proxy-configuration-extend? + this-socks-proxy-configuration) + (ssh-forward-configuration-entry-port + (car + (ssh-connection-configuration-forwards + (socks-proxy-configuration-dynamic-forward + this-socks-proxy-configuration)))) + 8971)) + (thunked)) + ;; #f, or a guix record returned by a call to + ;; (ssh-connection-configuration + ;; (forwards (list (dynamic-forward-configuration ...))) + ;; ...) + (dynamic-forward socks-proxy-configuration-dynamic-forward + (default #f))) + + +(define-syntax dynamic-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration)) + fields ...)))) + +(define-syntax port-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration (forward-type 'port) + (entry-port 6947))) + fields ...)))) + +(define-syntax reverse-port-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration (forward-type 'reverse-port) + (entry-port 6283))) + fields ...)))) + +(define-syntax tunnel-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration (forward-type 'tunnel) + (entry-type 'any) + (exit-type 'any))) + fields ...)))) + +(define (persistent-ssh-socks-port config) + "Returns an integer defining the localhost port that a persistent ssh +connection can use to establish itself through a socks proxy, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (socks-proxy-configuration-port + (ssh-connection-configuration-socks-proxy-config config))) + +(define (persistent-ssh-forward-stance forward-conf) + "Returns a string defining one of the forwarding stances of a +persistent ssh connection, configurable by FORWARD-CONF, a record of the +<ssh-forward-configuration> type." + (let* ((forward-type (ssh-forward-configuration-forward-type forward-conf)) + (entry-type (ssh-forward-configuration-entry-type forward-conf)) + (exit-type (ssh-forward-configuration-exit-type forward-conf)) + (entry-port (ssh-forward-configuration-entry-port forward-conf)) + (entry-port-str (number->string entry-port)) + (exit-port (ssh-forward-configuration-exit-port forward-conf)) + (exit-port-str (number->string exit-port)) + (entry-socket (ssh-forward-configuration-entry-socket forward-conf)) + (exit-socket (ssh-forward-configuration-exit-socket forward-conf)) + (exit-host (ssh-forward-configuration-exit-host forward-conf)) + (entry-tun (ssh-forward-configuration-entry-tun forward-conf)) + (entry-tun-str (number->string entry-tun)) + (exit-tun (ssh-forward-configuration-exit-tun forward-conf)) + (exit-tun-str (number->string exit-tun))) + (cond ((equal? forward-type 'dynamic) + (number->string entry-port)) + ((or (equal? forward-type 'port) + (equal? forward-type 'reverse-port)) + (cond ((equal? entry-type 'port) (string-append entry-port-str + ":" + exit-host + ":" + exit-port-str)) + ((equal? entry-type 'socket) (string-append entry-socket + ":" + exit-socket)) + (#t #f))) + ((equal? forward-type 'tunnel) + (string-append (cond ((equal? entry-type 'preset) entry-tun-str) + ((equal? entry-type 'any) "any") + (#t #f)) + ":" + (cond ((equal? exit-type 'preset) exit-tun-str) + ((equal? exit-type 'any) "any") + (#t #f)))) + (#t + #f)))) + +(define (persistent-ssh-forward-switch forward-conf) + "Returns a string defining one of the forwarding switches of a +persistent ssh connection, configurable by FORWARD-CONF, a record of the +<ssh-forward-configuration> type." + (let ((forward-type (ssh-forward-configuration-forward-type forward-conf))) + (cond ((equal? forward-type 'dynamic) "-D") + ((equal? forward-type 'port) "-L") + ((equal? forward-type 'reverse-port) "-R") + ((equal? forward-type 'tunnel) "-w") + (#t #f)))) + +(define (persistent-ssh-forward forward-conf) + "Returns a list of 2 strings containing the switch and stance of one of the +forwardings of a persistent ssh connection, configurable by +FORWARD-CONF, a record of the <ssh-forward-configuration> type." + (list (persistent-ssh-forward-switch forward-conf) + (persistent-ssh-forward-stance forward-conf))) + +(define (persistent-ssh-name-suffix config) + "Returns a string defining the suffix part of the shepherd service +provision of the shepherd service daemonizing a persistent ssh +connection, configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((forwards (ssh-connection-configuration-forwards config)) + (typer ssh-forward-configuration-forward-type) + (typer-str (lambda (forward) + (symbol->string (typer forward)))) + (stancer persistent-ssh-forward-stance) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-resurrect? config))) + (string-append "_" + (string-join (map (lambda (forward) + (string-append (typer-str forward) + "@" + (stancer forward))) + forwards) + "_") + (if use-socks? + (string-append "_proxy-port_" + socks-port-str) + "")))) + +(define (persistent-ssh-name config) + "Returns a symbol defining the shpherd service provision of the +shepherd service daemonizing a persistent ssh connection, configurable +by CONFIG, a record of the <ssh-connection-configuration> type." + (string->symbol + (string-append (ssh-connection-configuration-name-prefix config) + (if (ssh-connection-configuration-suffix-name? config) + (persistent-ssh-name-suffix config) + "")))) + +(define (persistent-ssh-pid-folder config) + "Returns a string defining the path to the folder in which the pid +file of a persistent ssh connection service is stored by default, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (cond ((ssh-connection-configuration-pid-folder-override? config) + (ssh-connection-configuration-pid-folder-override config)) + ((ssh-connection-configuration-elogind? config) + (string-append "/run/user/" (number->string (getuid)))) + (else "/var/run"))) + +(define (persistent-ssh-pid-file-path config) + "Returns a string defining the path to the pid file of a persistent +ssh connection service, configurable by CONFIG, configurable by CONFIG, +a record of the <ssh-connection-configuration> type." + (string-append (persistent-ssh-pid-folder config) + "/" + (symbol->string (persistent-ssh-name config)) + ".pid")) + +(define (persistent-ssh-log-folder config) + "Returns a string defining the path to the folder in which the log +file of a persistent ssh connection service is stored by default, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (cond ((ssh-connection-configuration-log-folder-override? config) + (ssh-connection-configuration-log-folder-override config)) + ((ssh-connection-configuration-elogind? config) + (string-append "/run/user/" (number->string (getuid)))) + (else "/var/run"))) + +(define (persistent-ssh-log-file-path config) + "Returns a string defining the path to the log file of a persistent +ssh connection service, configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (string-append (persistent-ssh-log-folder config) + "/" + (symbol->string (persistent-ssh-name config)) + ".log")) + +(define (persistent-ssh-local-command config) + "Returns a string defining command executed locally after the forwards +of a persistent ssh connection service have been succesfully created, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (let ((procps-package (ssh-connection-configuration-procps-package config)) + (clear-password? (ssh-connection-configuration-clear-password? + config)) + (extra-local-commands + (ssh-connection-configuration-extra-local-commands + config))) + (append (list (file-append procps-package + "/bin/ps") + " --no-header --pid $PPID -o " + (if clear-password? + "ppid" + "pid") + " > " + (persistent-ssh-pid-file-path config)) + (map (lambda (command) + (string-append " && " + command)) + extra-local-commands)))) + +(define (persistent-ssh-requires config) + "Returns a list of symbols defining the other services required as +dependencies by the shepherd service of a persistent ssh connection, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (let* ((req-net? (ssh-connection-configuration-require-networking? config)) + (extra-reqs (ssh-connection-configuration-extra-requires config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-force-resurrect? config))) + (append + (if req-net? + (list 'networking) + (list)) + extra-reqs + (if inferior? + (list (persistent-ssh-name inferior-cnf)) + (if use-socks? + (list (string->symbol + ;; FIXME: this just assumes a possible + ;; default name, not always true and not + ;; even the only possible default. + (string-append "ssh-forwards_dynamic@" + (number->string socks-port)))) + (list)))))) + +(define (persistent-ssh-timeout config) + "Returns an integer setting the pid file timout of the shepherd +service daemonizing a persistent ssh connection, configurable by CONFIG, +a record of the <ssh-connection-configuration> type." + (if (ssh-connection-configuration-timeout-override? config) + (ssh-connection-configuration-timeout-override config) + #~(+ #$(ssh-connection-configuration-connection-attempts config) + (default-pid-file-timeout)))) + +(define (persistent-ssh-constructor-gexp config) + "Returns G-exp to a procedure starting the ssh client process of a +persistent ssh connection, configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((sshpass-pkg (ssh-connection-configuration-sshpass-package config)) + (password (ssh-connection-configuration-sshd-user-password config)) + (ssh-pkg (ssh-connection-configuration-ssh-package config)) + (netcat-pkg (ssh-connection-configuration-netcat-package config)) + (verbosity (ssh-connection-configuration-verbosity config)) + (eff? (ssh-connection-configuration-exit-forward-failure? config)) + (tries (ssh-connection-configuration-connection-attempts config)) + (tries-str (number->string tries)) + (local-com? (ssh-connection-configuration-local-command? config)) + (local-com (persistent-ssh-local-command config)) + (gateway? (ssh-connection-configuration-gateway-ports? config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (command? (ssh-connection-configuration-command? config)) + (command (ssh-connection-configuration-command config)) + (forwards (ssh-connection-configuration-forwards config)) + (sshd-port (ssh-connection-configuration-sshd-port config)) + (sshd-port-str (number->string sshd-port)) + (agent? (ssh-connection-configuration-agent? config)) + (agent-socket (ssh-connection-configuration-agent-socket config)) + (id-rsa? (ssh-connection-configuration-id-rsa-file? config)) + (id-rsa (ssh-connection-configuration-id-rsa-file config)) + (sshd-user (ssh-connection-configuration-sshd-user config)) + (sshd-host (ssh-connection-configuration-sshd-host config)) + (dlf? (ssh-connection-configuration-dedicated-log-file? config)) + (log-file (persistent-ssh-log-file-path config)) + (pid-file? (ssh-connection-configuration-pid-file? config)) + (pid-file (persistent-ssh-pid-file-path config)) + (timeout (persistent-ssh-timeout config)) + (special-opt (ssh-connection-configuration-special-options config)) + (strict-check (ssh-connection-configuration-strict-check config)) + (kh-files (ssh-connection-configuration-known-hosts-files config)) + (sa-int (ssh-connection-configuration-server-alive-interval + config)) + (acount-max (ssh-connection-configuration-server-alive-count-max + config))) + #~(make-forkexec-constructor + (append #$(if (ssh-connection-configuration-clear-password? config) + #~(list #$(file-append sshpass-pkg "/bin/sshpass") + "-p" + #$password) + #~(list)) + (list #$(file-append ssh-pkg "/bin/ssh") + "-o" + "TCPKeepAlive=no" + "-o" + (string-append "ServerAliveInterval=" + #$(number->string sa-int)) + "-o" + (string-append "ServerAliveCountMax=" + #$(number->string acount-max)) + "-o" + (string-append "UserKnownHostsFile=" + #$(string-join kh-files)) + "-o" + (string-append "StrictHostKeyChecking=" #$strict-check) + ;; "-o" + ;; "Tunnel=point-to-point" + "-o" + (string-append "ExitOnForwardFailure=" + #$(if eff? + "yes" + "no")) + "-o" + (string-append "ConnectionAttempts=" + #$tries-str)) + #$(if local-com? + #~(list "-o" + "PermitLocalCommand=yes" + "-o" + (apply string-append + (append (list "LocalCommand=") + #$(append (list 'list) + local-com)))) + #~(list)) + #$(if gateway? + #~(list "-o" + "GatewayPorts=yes") + #~(list)) + #$(if use-socks? + #~(list "-o" + (string-append "ProxyCommand=" + #$netcat-pkg + "/bin/nc" + " -X 5 -x localhost:" + #$socks-port-str + " %h %p")) + #~(list)) + #$(append (list 'list) + special-opt) + (list "-p" + #$sshd-port-str) + #$(if id-rsa? + #~(list "-i" + #$id-rsa) + #~(list)) + #$(cond ((= verbosity 0) #~(list)) + ((= verbosity 1) #~(list "-v")) + ((= verbosity 2) #~(list "-v" "-v")) + ((= verbosity 3) #~(list "-v" "-v" "-v")) + (#t #f)) + #$(if command? + #~(list) + #~(list "-N")) + #$(append (list 'list) + (apply append + (map persistent-ssh-forward + forwards))) + (list (string-append #$sshd-user + "@" + #$sshd-host)) + #$(if command? + #~(list #$command) + #~(list))) + #:log-file + #$(if dlf? + log-file + #f) + #:pid-file + #$(if pid-file? + pid-file + #f) + #:pid-file-timeout + #$timeout + #:environment-variables + '#$(if agent? + (list (string-append "SSH_AUTH_SOCK=" + agent-socket)) + (list (string-append "SSH_AUTH_SOCK=" + "/dev/null")))))) + +(define (persistent-ssh-resurrect-action config) + "Returns a G-exp to a procedure used as the procedure of the +'resurrect action of the shepherd service supporting a persistent ssh +connection , configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((name (persistent-ssh-name config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-resurrect? config))) + #~(lambda (running) + (unless (service-running? (lookup-service '#$name)) + (perform-service-action (lookup-service '#$name) + 'enable) + (unless (or #$flat? + (and (not #$inferior?) + (not #$use-socks?))) + (let ((inferior-name + '#$(if inferior? + (persistent-ssh-name inferior-cnf) + (if use-socks? + (string->symbol + ;; FIXME: this just assumes a possible + ;; default name, not always true and not + ;; even the only possible default. + (string-append "ssh-forwards_dynamic@" + socks-port-str)) + 'not-a-service)))) + (perform-service-action (lookup-service inferior-name) + 'resurrect))) + (start-service (lookup-service '#$name))) + #t))) + +(define (persistent-ssh-force-resurrect-action config) + "Returns a G-exp to a procedure used as the procedure of the +'force-resurrect action of the shepherd service supporting a persistent +ssh connection , configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((name (persistent-ssh-name config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-force-resurrect? config))) + #~(lambda (running) + (perform-service-action (lookup-service '#$name) + 'enable) + (stop-service (lookup-service '#$name)) + (unless (or #$flat? + (and (not #$inferior?) + (not #$use-socks?))) + (let ((inferior-name + '#$(if inferior? + (persistent-ssh-name inferior-cnf) + (if use-socks? + (string->symbol + ;; FIXME: this just assumes a possible + ;; default name, not always true and not + ;; even the only possible default. + (string-append "ssh-forwards_dynamic@" + socks-port-str)) + 'not-a-service)))) + (perform-service-action (lookup-service inferior-name) + 'force-resurrect))) + (start-service (lookup-service '#$name)) + #t))) + +(define (persistent-ssh-shepherd-services config) + "Returns a list of shepherd services handling a ssh client daemon +connection, configured by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((name (persistent-ssh-name config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (reqs (persistent-ssh-requires config)) + (constructor-gexp (persistent-ssh-constructor-gexp config)) + (res-gexp (persistent-ssh-resurrect-action config)) + (force-res-gexp (persistent-ssh-force-resurrect-action config)) + (auto-start? (ssh-connection-configuration-auto-start? config))) + (append + (if inferior? + (persistent-ssh-shepherd-services inferior-cnf) + (list)) + (list + (shepherd-service + (documentation "Persistent ssh client connection") + (provision `(,name)) + (requirement reqs) + (start constructor-gexp) + (stop #~(make-kill-destructor)) + (actions + (list + (shepherd-action (name 'resurrect) + (documentation + "Resurrect this connection and its +inferiors-proxies if they are stopped or disabled by the Shepherd.") + (procedure res-gexp)) + (shepherd-action (name 'force-resurrect) + (documentation "Enable, stop and restart this +connection and its inferior-proxies , regardless of their current +status.") + (procedure force-res-gexp)))) + (auto-start? auto-start?)))))) + +(define (persistent-ssh-cron-jobs config) + "Returns a list of cron job specifications to extend the mcron service +with scheduled resurrection actions on the persistent ssh connection +port forwards configured by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((service-name-str (symbol->string (persistent-ssh-name config))) + (lieutenant? (ssh-connection-configuration-lieutenant? config)) + (lieutenant-path (ssh-connection-configuration-lieutenant-path + config)) + (lieutenant-socket (lieutenant-path->socket-file-path + lieutenant-path)) + (shepherd-pkg + (ssh-connection-configuration-shepherd-package config)) + (cron-resurrect? + (ssh-connection-configuration-cron-resurrect? config)) + (resurrect-time-spec + (ssh-connection-configuration-resurrect-time-spec config)) + (cron-force-resurrect? + (ssh-connection-configuration-cron-force-resurrect? config)) + (force-resurrect-time-spec + (ssh-connection-configuration-force-resurrect-time-spec config))) + (append + (if cron-resurrect? + (list #~(job #$resurrect-time-spec + (lambda () + (apply execl + (append (list (string-append #$shepherd-pkg + "/bin/herd") + "herd") + (if #$lieutenant? + (list "-s" + #$lieutenant-socket) + (list)) + (list "resurrect" + #$service-name-str)))) + (string-append "resurrect " + #$service-name-str))) + (list)) + (if cron-force-resurrect? + (list #~(job #$force-resurrect-time-spec + (lambda () + (apply execl + (append (list (string-append #$shepherd-pkg + "/bin/herd") + "herd") + (if #$lieutenant? + (list "-s" + #$lieutenant-socket) + (list)) + (list "force-resurrect" + #$service-name-str)))) + (string-append "force-resurrect " + #$service-name-str))) + (list))))) + +(define (persistent-ssh-log-rotation config) + "Returns a list of log-rotation records specifying how to rotate the +logs of a persistent ssh connection configurable by CONFIG, a record of +the <ssh-connection-configuration> type." + (if (and (ssh-connection-configuration-dedicated-log-file? config) + (ssh-connection-configuration-log-rotate? config)) + (list + (log-rotation (frequency 'daily) + (files `(,(persistent-ssh-log-file-path config))))) + (list))) + +(define persistent-ssh-service-type + (service-type + (name 'persistent-ssh) + (description "Persistent ssh connection service") + (extensions + (list (service-extension shepherd-root-service-type + persistent-ssh-shepherd-services) + (service-extension mcron-service-type + persistent-ssh-cron-jobs) + (service-extension rottlog-service-type + persistent-ssh-log-rotation) + (service-extension + profile-service-type + (lambda (config) + (list + ssh-tunneler-doc + (ssh-connection-configuration-ssh-package config) + (ssh-connection-configuration-netcat-package config) + (ssh-connection-configuration-sshpass-package config) + (ssh-connection-configuration-procps-package config) + (ssh-connection-configuration-inetutils-package config) + ssh-tunneler-tests))))) + (default-value (ssh-connection-configuration)))) + +(define home-persistent-ssh-service-type + (service-type + (name 'persistent-ssh) + (description "Persistent ssh connection normal user service") + (extensions + (list (service-extension home-shepherd-service-type + persistent-ssh-shepherd-services) + (service-extension + home-profile-service-type + (lambda (config) + (list + ssh-tunneler-doc + (ssh-connection-configuration-ssh-package config) + (ssh-connection-configuration-netcat-package config) + (ssh-connection-configuration-sshpass-package config) + (ssh-connection-configuration-procps-package config) + (ssh-connection-configuration-inetutils-package config)) + ssh-tunneler-tests)))) + (default-value (ssh-connection-configuration)))) 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))))) diff --git a/whispers/services/whispers/finance.scm b/whispers/services/whispers/finance.scm new file mode 100644 index 0000000..1ce7e5b --- /dev/null +++ b/whispers/services/whispers/finance.scm @@ -0,0 +1,331 @@ +;;; 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 finance) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (whispers services whispers) + #:use-module (whispers services finance) + #:use-module (gnu packages finance) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) + #:export (whispers-finance-service-type + whispers-finance-configuration + whispers-finance-configuration? + crypto-user-group-nodes + crypto-user-group-nodes? + nodes-configuration + nodes-configuration? + bitcoin-node-configuration + bitcoin-node-configuration? + monero-node-configuration + monero-node-configuration?)) + +(define-record-type* <whispers-finance-configuration> + whispers-finance-configuration make-finance-configuration + whispers-finance-configuration? + this-whispers-finance-configuration + ;; A list of crypto-user-group-nodes records + (users-groups-nodes whispers-finance-configuration-users-groups-nodes + (default '()))) + +(define-record-type* <crypto-user-group-nodes> + crypto-user-group-nodes make-crypto-user-group-nodes + crypto-user-group-nodes? + this-crypto-user-group-nodes + ;; A whispers-user-group record + (user-and-group crypto-user-group-nodes-user-and-group + (default (whispers-user-group))) + ;; A <nodes-configuration record> + (nodes crypto-user-group-nodes-nodes + (default '(nodes-configuration)))) + +(define-record-type* <nodes-configuration> + nodes-configuration make-nodes-configuration + nodes-configuration? + this-nodes-configuration + ;; A boolean value. + (bitcoin? nodes-configuration-bitcoin? + (default #f)) + ;; A <bitcoin-node-configuration> record + (btc-node nodes-configuration-btc-node + (default (bitcoin-node-configuration))) + ;; A boolean value + (monero? nodes-configuration-monero? + (default #f)) + ;; A <monero-node-configuration> record + (xmr-node nodes-configuration-xmr-node + (default (monero-node-configuration)))) + +(define-record-type* <bitcoin-node-configuration> + bitcoin-node-configuration make-bitcoin-node-configuration + bitcoin-node-configuration? + this-bitcoin-node-configuration + ;; A file-like object + (bitcoin-package bitcoin-node-configuration-bitcoin-package + (default bitcoin-core)) + ;; A boolean value + (walletdir-opt? bitcoin-node-configuration-walletdir-opt? + (default #f)) + ;; A string + (walletdir bitcoin-node-configuration-walletdir + (default "")) + ;; A boolean value + (proxy-opt? bitcoin-node-configuration-proxy-opt? + (default #f)) + ;; A string + (proxy bitcoin-node-configuration-proxy + (default "")) + ;; A boolean value + (%auto-start? bitcoin-node-configuration-auto-start? + (default #t))) + +(define-record-type* <monero-node-configuration> + monero-node-configuration make-monero-node-configuration + monero-node-configuration? + this-monero-node-configuration + ;; A file-like object + (monero-package monero-node-configuration-monero-package + (default monero)) + ;; A boolean value + (proxy-opt? monero-node-configuration-proxy-opt? + (default #f)) + ;; A string + (proxy monero-node-configuration-proxy + (default "")) + ;; A boolean value + (tx-proxy-opt? monero-node-configuration-tx-proxy-opt? + (default #f)) + ;; A boolean value + (prune-blockchain-opt? monero-node-configuration-prune-blockchain-opt? + (default #f)) + ;; A string + (tx-proxy monero-node-configuration-tx-proxy + (default "")) + ;; A boolean value + (%auto-start? monero-node-configuration-auto-start? + (default #t))) + +(define (log-folder user) + "Return a string naming the path to the folder where the log file of +the bitcoin node daemon of the user named by the string USER is stored." + (string-append "/var/log/whispers/finance/" + (user-container-name user) + "/bitcoin")) + +(define (rightwing-log-folder user) + "Return a string naming the path to the folder where the log file of +the monero node daemon of the user named by the string USER is stored." + (string-append "/var/log/whispers/finance/" + (user-container-name user) + "/monero")) + +(define (pid-folder user) + "Return a string naming the path to the folder where the pid file of +the bitcoin node daemon of the user named by the string USER is +located." + (string-append "/run/whispers/finance/" + (user-container-name user) + "/bitcoin")) + +(define (rightwing-pid-folder user) + "Return a string naming the path to the folder where the pid file of +the monero node daemon of the user named by the string USER is +located." + (string-append "/run/whispers/finance/" + (user-container-name user) + "/monero")) + +(define (btc-node user wal) + "Returns a bitcoin node guix service for a bitcoin node daemon from +the package BITCOIN-PACKAGE owned by the user named by the string USER +and with the wallet parameters configured by WAL, a record of the +<bitcoin-node-configuration> type." + (let ((bitcoin-package (bitcoin-node-configuration-bitcoin-package wal)) + (walletdir-opt? (bitcoin-node-configuration-walletdir-opt? wal)) + (walletdir (bitcoin-node-configuration-walletdir wal)) + (proxy-opt? (bitcoin-node-configuration-proxy-opt? wal)) + (proxy (bitcoin-node-configuration-proxy wal)) + (auto-start? (bitcoin-node-configuration-auto-start? wal))) + (service + bitcoin-service-type + (bitcoin-configuration (bitcoin-package bitcoin-package) + (user user) + (log-folder (log-folder user)) + (pid (string-append (pid-folder user) + "/" + "bitcoin.pid")) + (walletdir-opt? walletdir-opt?) + (walletdir walletdir) + (proxy-opt? proxy-opt?) + (proxy proxy) + (%auto-start? auto-start?))))) + +(define (rightwing-node user node) + "Returns a monero node guix service for a monero node daemon from the +package MONERO-PACKAGE owned by the user named by the string USER and +with the node parameters configured by NODE, a record of the +<monero-node-configuration> type." + (let ((monero-package (monero-node-configuration-monero-package node)) + (proxy-opt? (monero-node-configuration-proxy-opt? node)) + (proxy (monero-node-configuration-proxy node)) + (tx-proxy-opt? (monero-node-configuration-tx-proxy-opt? node)) + (tx-proxy (monero-node-configuration-tx-proxy node)) + (prune? (monero-node-configuration-prune-blockchain-opt? node)) + (auto-start? (monero-node-configuration-auto-start? node))) + (service + monero-service-type + (monero-configuration (monero-package monero-package) + (user user) + (log-folder (rightwing-log-folder user)) + (pidfile + (string-append (rightwing-pid-folder user) + "/" + "monero.pid")) + (proxy-opt? proxy-opt?) + (proxy proxy) + (tx-proxy-opt? tx-proxy-opt?) + (tx-proxy tx-proxy) + (prune-blockchain-opt? prune?) + (%auto-start? auto-start?))))) + +(define (extra-actions user group nodes) + "Return a list of <shepherd-action> records for the creation and +destruction of the folders and temporary file systems necessary for the +operation of the bitcoin node daemon of the user named by the string +USER, configuration by NODES, a record of the <nodes-configuration> +type." + (let* ((user-str (user-container-name user)) + (user-sym (string->symbol user-str)) + (bitcoin? (nodes-configuration-bitcoin? nodes)) + (monero? (nodes-configuration-monero? nodes))) + (list (shepherd-action + (name 'pre-start) + (documentation "Create the directories and tmpfs mounts +used by the bitcoin node daemon.") + (procedure + #~(lambda (running) + (unless (not #$bitcoin?) + (action '#$user-sym + 'make-directory + #$(log-folder user-str) + #$user + #$group + #$(number->string #o755 8)) + (action '#$user-sym + 'make-tmpfs + #$(pid-folder user) + #$user + #$group + #$(number->string #o755 8))) + (unless (not #$monero?) + (action '#$user-sym + 'make-directory + #$(rightwing-log-folder user-str) + #$user + #$group + #$(number->string #o755 8)) + (action '#$user-sym + 'make-tmpfs + #$(rightwing-pid-folder user) + #$user + #$group + #$(number->string #o755 8)))))) + (shepherd-action + (name 'post-stop) + (documentation "Unmount the tmpfs mounts used by the bitcoin +node daemon.") + (procedure + #~(lambda (running) + (unless (not #$bitcoin?) + (action '#$user-sym + 'clear-tmpfs + #$(pid-folder user))) + (unless (not #$monero?) + (action '#$user-sym + 'clear-tmpfs + #$(rightwing-pid-folder user))))))))) + +(define (node-lieutenants user nodes) + "Returns a list of zero to two crypto node guix shepherd services +daemonizing a bitcoin and/or a monero node, running as the user USER, +and configured by NODES, a record of the <nodes-configuration> type." + (let* ((user-str (user-container-name user)) + (user-sym (string->symbol user-str)) + (bitcoin? (nodes-configuration-bitcoin? nodes)) + (bitcoin-node (nodes-configuration-btc-node nodes)) + (monero? (nodes-configuration-monero? nodes)) + (monero-node (nodes-configuration-xmr-node nodes))) + (append (if bitcoin? + (list (btc-node user + bitcoin-node)) + (list)) + (if monero? + (list (rightwing-node user + monero-node)) + (list))))) + + +(define (nodes-lieutenant user group nodes) + "Returns an elementary whispers service tree for a single user's +section of whispers finance sub-tree, at the tip of which a bitcoin node +daemon and a monero node can be daemonized owned by the user named by +the string USER and the group named by the string GROUP, with nodes +configured by NODES, a record of the <nodes-configuration> type." + (service whispers-service-type + (whispers-configuration (name (string->symbol + (user-container-name user))) + (lieutenants (node-lieutenants user + nodes)) + (user user) + (group group) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions (extra-actions user + group + nodes))))) + +(define (whispers-finance-tree config) + "Returns a whispers service tree for a whispers bitcoin nodes +sub-tree, configurable by CONFIG, a record of the +<whispers-finance-configuration> type." + (let* ((ugws (whispers-finance-configuration-users-groups-nodes config)) + (user-group crypto-user-group-nodes-user-and-group) + (user (lambda (ugw) (whispers-user-group-user (user-group ugw)))) + (group (lambda (ugw) (whispers-user-group-group (user-group ugw)))) + (nodes (lambda (ugw) + (crypto-user-group-nodes-nodes ugw)))) + (list (service whispers-service-type + (whispers-configuration + (name 'finance) + (lieutenants (map (lambda (ugw) + (nodes-lieutenant (user ugw) + (group ugw) + (nodes ugw))) + ugws))))))) + +(define whispers-finance-service-type + (service-type + (name '(whispers-finance)) + (description "Daemonized per-user cryptocurrency nodes") + (extensions (list (service-extension whispers-service-type + whispers-finance-tree))) + (default-value (whispers-finance-configuration)))) diff --git a/whispers/services/whispers/gps.scm b/whispers/services/whispers/gps.scm new file mode 100644 index 0000000..2e7f71b --- /dev/null +++ b/whispers/services/whispers/gps.scm @@ -0,0 +1,100 @@ +;;; Whispers --- Stealth VPN and ssh tunneler +;;; Copyright © 2024 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 gps) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (gnu services) + #:use-module (whispers services whispers) + #:use-module (whispers services gps) + #:use-module (gnu system shadow) + #:export (whispers-gps-service-type + gps-user-group-configs + gps-user-group-configs?)) + +(define-record-type* <gps-user-group-configs> + gps-user-group-configs make-gps-user-group-configs + gps-user-group-configs? + this-gps-user-group-configs + ;; A <whispers-user-group> record + (user-and-group gps-user-group-configs-user-and-group + (default (whispers-user-group))) + ;; A boolean value + (gpsd? gps-user-group-configs-gpsd? + (default #t)) + ;; A list of <gpsd-configuration> type records + (gpsd-configs gps-user-group-configs-gpsd-configs + (default (list (gpsd-configuration))))) + +(define (user-lieutenant gpsd? + user + group + gpsd-configs) + "Returns a whispers sub-tree for a single user's section of a whispers +gps sub-tree, owned by the user named by the string USER and the group +named by the string GROUP, at the tip of which a list gpsd services is +daemonized when GPSD? evaluates to a true value, configured by +GPSD-CONFIGS, a list of records of the <gpsd-configuration> type." + (service whispers-service-type + (whispers-configuration + (name (string->symbol (user-container-name user))) + (lieutenants + (if gpsd? + (list (service whispers-service-type + (whispers-configuration + (name 'gpsd) + (lieutenants + (map (lambda (config) + (service gpsd-service-type + config)) + gpsd-configs)) + (user user) + (group group)))))) + (user user) + (group group)))) + +(define (whispers-gps-tree configs) + "Returns a whispers service tree for a whispers gps sub-tree, +configurable by CONFIGS, a list of records of the +<gps-user-group-configs> type." + (let* ((user-group gps-user-group-configs-user-and-group) + (user (lambda (ugc) + (whispers-user-group-user (user-group ugc)))) + (group (lambda (ugc) + (whispers-user-group-group (user-group ugc)))) + (gpsd? (lambda (ugc) + (gps-user-group-configs-gpsd? ugc))) + (gpsd-configs (lambda (ugc) + (gps-user-group-configs-gpsd-configs ugc)))) + (list (service whispers-service-type + (whispers-configuration + (name 'gps) + (lieutenants (map (lambda (ugc) + (user-lieutenant (gpsd? ugc) + (user ugc) + (group ugc) + (gpsd-configs ugc))) + configs))))))) + +(define whispers-gps-service-type + (service-type + (name '(whispers-gps)) + (description "Per-user gpsd") + (extensions (list (service-extension whispers-service-type + whispers-gps-tree))) + (default-value '()))) diff --git a/whispers/services/whispers/mail.scm b/whispers/services/whispers/mail.scm new file mode 100644 index 0000000..bd2c177 --- /dev/null +++ b/whispers/services/whispers/mail.scm @@ -0,0 +1,174 @@ +;;; Whispers --- Stealth VPN and ssh tunneler +;;; Copyright © 2024 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 mail) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (whispers services whispers) + #:use-module (whispers services proton) + #:use-module (gnu packages mail) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) + #:export (whispers-mail-service-type + whispers-mail-configuration + whispers-mail-configuration? + mail-user-group-services + mail-user-group-services? + mail-services-configuration + mail-services-configuration? + hydroxide-service-configuration + hydroxide-service-configuration?)) + +(define-record-type* <whispers-mail-configuration> + whispers-mail-configuration make-whispers-mail-configuration + whispers-mail-configuration? + this-whispers-mail-configuration + ;; A list of mail-user-group-services records + (users-groups-services whispers-mail-configuration-users-groups-services + (default '()))) + +(define-record-type* <mail-user-group-services> + mail-user-group-services make-mail-user-group-services + mail-user-group-services? + this-mail-user-group-services + ;; A whispers-user-group record + (user-and-group mail-user-group-services-user-and-group + (default (whispers-user-group))) + ;; A <mail-services-configuration record> + (services mail-user-group-services-services + (default (mail-services-configuration)))) + +(define-record-type* <mail-services-configuration> + mail-services-configuration make-mail-services-configuration + mail-services-configuration? + this-mail-services-configuration + ;; A boolean value. + (hydroxide? mail-services-configuration-hydroxide? + (default #f)) + ;; An <hydroxide-configuration> record + (hydroxide-service mail-services-configuration-hydroxide-service + (default (hydroxid-service-configuration)))) + +(define-record-type* <hydroxide-service-configuration> + hydroxide-service-configuration make-hydroxide-service-configuration + hydroxide-service-configuration? + this-hydroxide-service-configuration + ;; A file-like object + (hydroxide-package hydroxide-service-configuration-hydroxide-package + (default hydroxide)) + ;; A boolean value + (https-proxy? hydroxide-service-configuration-https-proxy? + (default #f)) + ;; A string + (https-proxy hydroxide-service-configuration-https-proxy + (default "socks5://localhost:8971")) + ;; A boolean value + (imap? hydroxide-service-configuration-imap? + (default #t)) + ;; A boolean value + (smtp? hydroxide-service-configuration-smtp? + (default #t)) + ;; A boolean value + (carddav? hydroxide-service-configuration-carddav? + (default #t)) + ;; A boolean value + (%auto-start? hydroxide-service-configuration-auto-start? + (default #t))) + +(define (proton-service user serv) + "Returns an hydroxidce guix service for a server owned by the user named +by the string USER and with the service parameters configured by serv, a +record of the <hydroxide-service-configuration> type." + (let ((hydroxide-package (hydroxide-service-configuration-hydroxide-package + serv)) + (https-proxy? (hydroxide-service-configuration-https-proxy? serv)) + (https-proxy (hydroxide-service-configuration-https-proxy serv)) + (imap? (hydroxide-service-configuration-imap? serv)) + (smtp? (hydroxide-service-configuration-smtp? serv)) + (carddav? (hydroxide-service-configuration-carddav? serv)) + (auto-start? (hydroxide-service-configuration-auto-start? serv))) + (service + hydroxide-service-type + (hydroxide-configuration (hydroxide-package hydroxide-package) + (user user) + (https-proxy? https-proxy?) + (https-proxy https-proxy) + (imap? imap?) + (smtp? smtp?) + (carddav? carddav?) + (%auto-start? auto-start?))))) + +(define (services-lieutenants user services) + "Returns a list of zero to one mail service guix shepherd services +daemonizing an hydroxide server for localhost , running as the user +USER, and configured by SERVICES, a record of the +<mail-services-configuration> type." + (let* ((user-str (user-container-name user)) + (user-sym (string->symbol user-str)) + (hydroxide? (mail-services-configuration-hydroxide? services)) + (hydroxide-service (mail-services-configuration-hydroxide-service + services))) + (if hydroxide? + (list (proton-service user + hydroxide-service)) + (list)))) + + +(define (mail-lieutenant user group services) + "Returns an elementary whispers service tree for a single user's +section of whispers mail sub-tree, at the tip of which an hydroxide +server can be daemonized owned by the user named by the string USER and +the group named by the string GROUP, with services configured by SERVICES, a +record of the <mail-services-configuration> type." + (service whispers-service-type + (whispers-configuration (name (string->symbol + (user-container-name user))) + (lieutenants (services-lieutenants + user + services)) + (user user) + (group group)))) + +(define (whispers-mail-tree config) + "Returns a whispers service tree for a whispers mail sub-tree, +configurable by CONFIG, a record of the <whispers-mail-configuration> +type." + (let* ((ugws (whispers-mail-configuration-users-groups-services config)) + (user-group mail-user-group-services-user-and-group) + (user (lambda (ugw) (whispers-user-group-user (user-group ugw)))) + (group (lambda (ugw) (whispers-user-group-group (user-group ugw)))) + (services (lambda (ugw) (mail-user-group-services-services ugw)))) + (list (service whispers-service-type + (whispers-configuration + (name 'mail) + (lieutenants (map (lambda (ugw) + (mail-lieutenant (user ugw) + (group ugw) + (services ugw))) + ugws))))))) + +(define whispers-mail-service-type + (service-type + (name '(whispers-mail)) + (description "Daemonized per-user hydroxide servers") + (extensions (list (service-extension whispers-service-type + whispers-mail-tree))) + (default-value (whispers-mail-configuration)))) diff --git a/whispers/services/whispers/ssh.scm b/whispers/services/whispers/ssh.scm new file mode 100644 index 0000000..a5ff1d1 --- /dev/null +++ b/whispers/services/whispers/ssh.scm @@ -0,0 +1,629 @@ +;;; 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 ssh) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (whispers services whispers) + #:use-module (whispers services ssh-agent) + #:use-module (whispers services ssh-tunneler) + #:use-module (gnu packages ssh) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) + #:export (whispers-ssh-service-type + whispers-ssh-configuration + whispers-ssh-configuration? + ssh-user-group-keys-forwards + ssh-user-group-keys-forwards? + whispers-forwarding + whispers-forwarding?)) + +(define-record-type* <whispers-ssh-configuration> + whispers-ssh-configuration make-whispers-ssh-configuration + whispers-ssh-configuration? + this-whispers-ssh-configuration + ;; A file-like object + (ssh-package whispers-ssh-configuration-ssh-package + (default openssh)) + ;; A list of ssh-user-group-keys-forwards records + (users-groups-keys-forwards + whispers-ssh-configuration-users-groups-keys-forwards + (default '()))) + +(define-record-type* <ssh-user-group-keys-forwards> + ssh-user-group-keys-forwards make-ssh-user-group-keys-forwards + ssh-user-group-keys-forwards? + this-ssh-agents-user-group-keys + ;; A whispers-user-group record + (user-and-group ssh-user-group-keys-forwards-user-and-group + (default (whispers-user-group))) + ;; A boolean value + (shell-tests? ssh-user-group-keys-forwards-shell-tests? + (default #f)) + ;; A boolean value + (agent? ssh-user-group-keys-forwards-agent? + (default #t)) + ;; A list of strings + (keys ssh-user-group-keys-forwards-keys + (default '())) + ;; A boolean value + (tunneler? ssh-user-group-keys-forwards-tunneler? + (default #f)) + ;; A list of <whispers-forwarding> objects + (forwardings ssh-user-group-keys-forwards-forwardings + (default '()))) + +(define-record-type* <whispers-forwarding> + whispers-forwarding make-whispers-forwarding + whispers-forwarding? + this-ssh-agents-user-group-keys + ;; A list of <ssh-forward-configuration> objects + (forwards whispers-forwarding-forwards + (default '())) + ;; A string. + (name-prefix whispers-forwarding-name-prefix + (default "ssh-forwards")) + ;; A boolean value. + (suffix-name? whispers-forwarding-suffix-name? + (default #t)) + ;; A boolean value. + (use-agent? whispers-forwarding-use-agent? + (default #t)) + ;; A boolean value. + (clear-password? whispers-forwarding-clear-password? + (default #f)) + ;; A string. + (clear-password whispers-forwarding-clear-password + (default "")) + ;; A string. + (sshd-user whispers-forwarding-sshd-user + (default "root")) + ;; A string. + (sshd-host whispers-forwarding-sshd-host + (default "127.0.0.1")) + ;; An integer. + (sshd-port whispers-forwarding-sshd-port + (default 22)) + ;; A string. + (strict-check whispers-forwarding-strict-check + (default "yes")) + ;; A list of strings. + (known-hosts-files whispers-forwarding-known-hosts-files + (default (list "~/.ssh/known_hosts" + "~/.ssh/known_hosts2"))) + ;; An integer. + (server-alive-interval whispers-forwarding-server-alive-interval + (default 30)) + ;; An integer. + (server-alive-count-max whispers-forwarding-server-alive-count-max + (default 6)) + ;; A boolean value + (resurrect? whispers-forwarding-resurrect? + (default #t)) + ;; A quoted cron time job specification + (resurrect-time-spec whispers-forwarding-resurrect-time-spec + (default ''(next-minute '(47)))) + ;; A boolean value + (force-resurrect? whispers-forwarding-force-resurrect? + (default #t)) + ;; A quoted cron time job specification + (force-resurrect-time-spec + whispers-forwarding-force-resurrect-time-spec + (default ''(next-hour '(3)))) + ;; An integer + (timeout whispers-forwarding-timeout + (default 5)) + ;; A boolean value. + (stealth? whispers-forwarding-stealth? + (default #t)) + ;; A string. + (stealth-name-prefix whispers-forwarding-stealth-name-prefix + (default "ssh-forwards")) + ;; A boolean value. + (stealth-suffix-name? whispers-forwarding-stealth-suffix-name? + (default #t)) + ;; A boolean value. + (stealth-use-agent? whispers-forwarding-stealth-use-agent? + (default #t)) + ;; A boolean value. + (stealth-clear-password? + whispers-forwarding-stealth-clear-password? + (default #f)) + ;; A string. + (stealth-clear-password + whispers-forwarding-stealth-clear-password + (default "")) + ;; A string. + (stealth-sshd-user whispers-forwarding-stealth-sshd-user + (default "root")) + ;; A string. + (stealth-sshd-host whispers-forwarding-stealth-sshd-host + (default "127.0.0.1")) + ;; An integer. + (stealth-sshd-port whispers-forwarding-stealth-sshd-port + (default 22)) + ;; A string. + (stealth-strict-check whispers-forwarding-stealth-strict-check + (default "yes")) + ;; A list of strings. + (stealth-known-hosts-files + whispers-forwarding-stealth-known-hosts-files + (default (list "~/.ssh/known_hosts" + "~/.ssh/known_hosts2"))) + ;; An integer. + (stealth-server-alive-interval + whispers-forwarding-stealth-server-alive-interval + (default 30)) + ;; An integer. + (stealth-server-alive-count-max + whispers-forwarding-stealth-server-alive-count-max + (default 6)) + ;; An integer. + (stealth-timeout whispers-forwarding-stealth-timeout + (default 5)) + ;; An integer. + (stealth-proxy-port whispers-forwarding-stealth-proxy-port + (default 8585)) + ;; A boolean value. + (%auto-start? whispers-forwarding-auto-start? + (default #t))) + +(define (log-folder-agent user) + "Return a string naming the path to the folder where the log file of +the ssh agent daemon of the user named by the string USER is stored." + (string-append "/var/log/whispers/ssh/" + (user-container-name user) + "/ssh-agent")) + +(define (socket-folder-agent user) + "Return a string naming the path to the folder where the socket file +of the ssh agent daemon of the user named by the string USER is located." + (string-append "/run/whispers/ssh/" + (user-container-name user) + "/ssh-agent/unix-sockets")) + +(define (log-folder-forwarding user conn) + "Return a string naming the path to the folder where the log file of +the ssh tunneler of the user named by the string USER is stored." + (string-append "/var/log/whispers/ssh/" + (user-container-name user) + "/tunneler/" + conn)) + +(define (base-folder-forwarding user conn) + "Return a string naming the path to the folder where the pid files +of the ssh tunneler of the persistent ssh connection +described by the string CONN of the user named by the string USER is +located." + (string-append "/run/whispers/ssh/" + (user-container-name user) + "/tunneler/" + conn)) + +(define (socket-folder-forwarding user conn) + "Return a string naming the path to the folder where the socket files +of the ssh tunneler of the persistent ssh connection +described by the string CONN of the user named by the string USER is +located." + (string-append "/run/whispers/ssh/" + (user-container-name user) + "/tunneler/" + conn + "/unix-sockets")) + +(define (agent ssh-package user keys) + "Returns an ssh agent guix service for an ssh agent daemon from the +package SSH-PACKAGE owned by the user named by the string USER and with +the private key files named in the list of string KEYS auto-loaded at +startup." + (service + ssh-agent-service-type + (ssh-agent-configuration (ssh-package ssh-package) + (log-folder (log-folder-agent user)) + (socket-folder (socket-folder-agent user)) + (auto-added-keys keys)))) + +(define (forwarding->conn-strings forwarding) + "Returns a list of strings used to hopefully uniquely identify the + persistent ssh connections to remote handles of remote hosts, +configured from the fields of FORWARDING, a record of the +<whispers-forwarding> type. The strings are used as sub-folders names +for files relevant to the extended shepherd services. The list contains +two strings if the forwarding is extended with stealth switched on, and +one string otherwise." + (let ((sshd-user (whispers-forwarding-sshd-user forwarding)) + (host (whispers-forwarding-sshd-host forwarding)) + (port (whispers-forwarding-sshd-port forwarding)) + (stealth? (whispers-forwarding-stealth? forwarding)) + (stealth-sshd-user (whispers-forwarding-stealth-sshd-user + forwarding)) + (stealth-host (whispers-forwarding-stealth-sshd-host forwarding)) + (stealth-port (whispers-forwarding-stealth-sshd-port forwarding))) + (append (list (string-append "ssh-connection_" + sshd-user + "@" + host + ":" + (number->string port) + (if stealth? + (string-append "_proxy_" + stealth-sshd-user + "@" + stealth-host + ":" + (number->string + stealth-port)) + ""))) + (if stealth? + (list (string-append "ssh-connection_" + stealth-sshd-user + "@" + stealth-host + ":" + (number->string stealth-port))) + (list))))) + +(define (tunneler ssh-package + user + forwarding) + "Returns a ssh tunneler Guix service using the +package SSH-PACKAGE, owned by the user named by the string USER, +defined by FORWARDING, a record of the <whispers-forwarding> type." + (let* ((forwards (whispers-forwarding-forwards forwarding)) + (lieutenant-path (string-append "/ssh/" + (user-container-name user) + "/tunneler")) + (nprefix (whispers-forwarding-name-prefix forwarding)) + (suffix? (whispers-forwarding-suffix-name? forwarding)) + (agent? (whispers-forwarding-use-agent? forwarding)) + (agent-socket (string-append (socket-folder-agent user) + "/ssh-agent.sock")) + (clear? (whispers-forwarding-clear-password? forwarding)) + (clear (whispers-forwarding-clear-password forwarding)) + (sshd-user (whispers-forwarding-sshd-user forwarding)) + (host (whispers-forwarding-sshd-host forwarding)) + (port (whispers-forwarding-sshd-port forwarding)) + (strict (whispers-forwarding-strict-check forwarding)) + (kh-files (whispers-forwarding-known-hosts-files forwarding)) + (sa-count-max (whispers-forwarding-server-alive-count-max + forwarding)) + (sa-int (whispers-forwarding-server-alive-interval forwarding)) + (resurrect? (whispers-forwarding-resurrect? forwarding)) + (resurrect-time (whispers-forwarding-resurrect-time-spec + forwarding)) + (force-resurrect? (whispers-forwarding-force-resurrect? forwarding)) + (force-resurrect-time (whispers-forwarding-force-resurrect-time-spec + forwarding)) + (timeout (whispers-forwarding-timeout forwarding)) + (stealth? (whispers-forwarding-stealth? forwarding)) + (stealth-prefix (whispers-forwarding-stealth-name-prefix + forwarding)) + (stealth-suffix? (whispers-forwarding-stealth-suffix-name? + forwarding)) + (stealth-agent? (whispers-forwarding-stealth-use-agent? forwarding)) + (stealth-clear? (whispers-forwarding-stealth-clear-password? + forwarding)) + (stealth-clear (whispers-forwarding-stealth-clear-password + forwarding)) + (stealth-sshd-user (whispers-forwarding-stealth-sshd-user + forwarding)) + (stealth-host (whispers-forwarding-stealth-sshd-host forwarding)) + (stealth-port (whispers-forwarding-stealth-sshd-port forwarding)) + (stealth-timeout (whispers-forwarding-stealth-timeout forwarding)) + (stealth-proxy-port (whispers-forwarding-stealth-proxy-port + forwarding)) + (stealth-strict (whispers-forwarding-stealth-strict-check + forwarding)) + (stealth-kh-files (whispers-forwarding-stealth-known-hosts-files + forwarding)) + (stealth-sa-count-max + (whispers-forwarding-stealth-server-alive-count-max + forwarding)) + (stealth-sa-int (whispers-forwarding-stealth-server-alive-interval + forwarding)) + (auto? (whispers-forwarding-auto-start? forwarding)) + (conn (forwarding->conn-strings forwarding))) + (service + persistent-ssh-service-type + (ssh-connection-configuration + (ssh-package ssh-package) + (lieutenant? #t) + (lieutenant-path lieutenant-path) + (name-prefix nprefix) + (suffix-name? suffix?) + (agent? agent?) + (agent-socket agent-socket) + (clear-password? clear?) + (sshd-user-password clear) + (require-networking? #f) + (pid-folder-override? #t) + (pid-folder-override (base-folder-forwarding user (car conn))) + (dedicated-log-file? #t) + (log-folder-override? #t) + (log-folder-override (log-folder-forwarding user (car conn))) + (sshd-user sshd-user) + (forwards forwards) + (sshd-host host) + (sshd-port port) + (strict-check strict) + (known-hosts-files kh-files) + (server-alive-interval sa-int) + (server-alive-count-max sa-count-max) + (%cron-resurrect? resurrect?) + (resurrect-time-spec resurrect-time) + (%cron-force-resurrect? force-resurrect?) + (force-resurrect-time-spec force-resurrect-time) + (timeout-override? #t) + (timeout-override timeout) + (socks-proxy-config + (socks-proxy-configuration + (use-proxy? stealth?) + (dynamic-forward + (if stealth? + (ssh-connection-configuration + (ssh-package ssh-package) + (lieutenant? #t) + (lieutenant-path lieutenant-path) + (name-prefix stealth-prefix) + (suffix-name? stealth-suffix?) + (agent? stealth-agent?) + (agent-socket agent-socket) + (clear-password? stealth-clear?) + (sshd-user-password stealth-clear) + (require-networking? #f) + (pid-folder-override? #t) + (pid-folder-override (base-folder-forwarding user (cadr conn))) + (dedicated-log-file? #t) + (log-folder-override? #t) + (log-folder-override (log-folder-forwarding user (cadr conn))) + (sshd-user stealth-sshd-user) + (forwards + (list (dynamic-forward-configuration + (entry-port stealth-proxy-port)))) + (sshd-host stealth-host) + (sshd-port stealth-port) + (strict-check stealth-strict) + (known-hosts-files stealth-kh-files) + (server-alive-interval stealth-sa-int) + (server-alive-count-max stealth-sa-count-max) + (timeout-override? #t) + (timeout-override stealth-timeout) + (%auto-start? auto?)) + #f)))) + (%auto-start? auto?))))) + +(define (extra-actions-forwardings user group conn-list) + "Return a list of <shepherd-action> records for the creation and +destruction of the folders and temporary file systems necessary for the +operation of the ssh tunneler connections owned by the user named by the +string USER to the remote defined by the list of strings +CONN-LIST. Group ownership of the folders and tmpfs goes to the group +named by the string GROUP." + (list (shepherd-action + (name 'pre-start) + (documentation "Create the directories and tmpfs mounts +used by a tunneler connection.") + (procedure + #~(lambda (running) + `#$(map (lambda (conn) + (list #~,(action 'tunneler + 'make-directory + #$(log-folder-forwarding user + conn) + #$user + #$group + #$(number->string #o755 + 8)) + ;; The let form is insuring that the + ;; parent folder is created before its + ;; sub-folder. Good idea, what could + ;; possibly go wrong with this + ;; clusterfuck? + #~,(let ((dummy + (action 'tunneler + 'make-tmpfs + #$(base-folder-forwarding + user + conn) + #$user + #$group + #$(number->string #o755 + 8)))) + (action 'tunneler + 'make-tmpfs + #$(socket-folder-forwarding + user + conn) + #$user + #$group + #$(number->string #o700 + 8))))) + conn-list)))) + (shepherd-action + (name 'post-stop) + (documentation "Unmount the tmpfs mounts used by a tunneler + connection.") + (procedure + #~(lambda (running) + `#$(map (lambda (conn) + ;; The let form is insuring that the parent + ;; folder is deleted after its + ;; sub-folder. Ditto. + (list #~,(let ((dummy + (action 'tunneler + 'clear-tmpfs + #$(socket-folder-forwarding + user + conn)))) + (action 'tunneler + 'clear-tmpfs + #$(base-folder-forwarding + user + conn))))) + conn-list)))))) + +(define (tunnelers ssh-package user group forwardings) + (service + whispers-service-type + (whispers-configuration (name 'tunneler) + (lieutenants (map (lambda (forwarding) + (tunneler ssh-package + user + forwarding)) + forwardings)) + (user user) + (group group) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions + (extra-actions-forwardings + user + group + (apply append + (map forwarding->conn-strings + forwardings))))))) + +(define (extra-actions-user user group) + "Return a list of <shepherd-action> records for the creation and +destruction of the folders and temporary file systems necessary for the +operation of the ssh agent daemon of the user named by the string +USER. Group ownership of the folders and tmpfs goes to the group named +by the string GROUP." + (let* ((user-str (user-container-name user)) + (user-sym (string->symbol user-str))) + (list (shepherd-action + (name 'pre-start) + (documentation "Create the directories and tmpfs mounts +used by the ssh-agent.") + (procedure + #~(lambda (running) + (action '#$user-sym + 'make-directory + #$(log-folder-agent user-str) + #$user + #$group + #$(number->string #o755 8)) + (action '#$user-sym + 'make-tmpfs + (string-append "/run/whispers/" + "ssh/" + #$user-str + "/ssh-agent/") + #$user + #$group + #$(number->string #o755 8)) + (action '#$user-sym + 'make-tmpfs + #$(socket-folder-agent user) + #$user + #$group + #$(number->string #o700 8))))) + (shepherd-action + (name 'post-stop) + (documentation "Unmount the tmpfs mounts used by the ssh-agent.") + (procedure + #~(lambda (running) + (action '#$user-sym + 'clear-tmpfs + #$(socket-folder-agent user)) + (action '#$user-sym + 'clear-tmpfs + (string-append "/run/whispers/" + "ssh/" + #$user-str + "/ssh-agent")))))))) + +(define (user-lieutenant agent? + tunneler? + user + group + keys + forwardings + ssh-package) + "Returns a whispers sub-tree for a single user's section of a whispers +ssh sub-tree, owned by the user named by the string USER and the group +named by the string GROUP, at the tips of which a ssh agent service +rendering availbale the private keys defined by the list of strings KEYS +is daemonized when AGENT? evaluates to a true value, and/or ssh forwards +as defined by the <whispers-forwarding> type record FORWARDINGS are +daemonized when TUNNELER? evaluates to a true value. Those services are +provided by the programs of the package SSH-PACKAGE." + (service whispers-service-type + (whispers-configuration + (name (string->symbol (user-container-name user))) + (lieutenants (append (if agent? + (list (agent ssh-package + user + keys)) + (list)) + (if tunneler? + (list (tunnelers ssh-package + user + group + forwardings)) + (list)))) + (user user) + (group group) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions (extra-actions-user user + group))))) + +(define (whispers-ssh-tree config) + "Returns a whispers service tree for a whispers ssh sub-tree, +configurable by CONFIG, a record of the <whispers-ssh-configuration> +type." + (let* ((ssh-package (whispers-ssh-configuration-ssh-package config)) + (ugks (whispers-ssh-configuration-users-groups-keys-forwards + config)) + (user-group ssh-user-group-keys-forwards-user-and-group) + (user (lambda (ugk) + (whispers-user-group-user (user-group ugk)))) + (group (lambda (ugk) + (whispers-user-group-group (user-group ugk)))) + (ag? (lambda (ugk) + (ssh-user-group-keys-forwards-agent? ugk))) + (keys (lambda (ugk) + (ssh-user-group-keys-forwards-keys ugk))) + (tun? (lambda (ugk) + (ssh-user-group-keys-forwards-tunneler? ugk))) + (fwds (lambda (ugk) + (ssh-user-group-keys-forwards-forwardings ugk)))) + (list (service whispers-service-type + (whispers-configuration + (name 'ssh) + (lieutenants (map (lambda (ugk) + (user-lieutenant (ag? ugk) + (tun? ugk) + (user ugk) + (group ugk) + (keys ugk) + (fwds ugk) + ssh-package)) + ugks))))))) + +(define whispers-ssh-service-type + (service-type + (name '(whispers-ssh)) + (description "Daemonized per-user ssh agents and ssh forwards") + (extensions (list (service-extension whispers-service-type + whispers-ssh-tree))) + (default-value (whispers-ssh-configuration)))) diff --git a/whispers/services/whispers/vpn.scm b/whispers/services/whispers/vpn.scm new file mode 100644 index 0000000..55847ee --- /dev/null +++ b/whispers/services/whispers/vpn.scm @@ -0,0 +1,3424 @@ +;;; 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 vpn) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (whispers services whispers) + #:use-module (whispers services ssh-tunneler) + #:use-module (gnu packages base) + #:use-module (gnu packages guile) + #:use-module (gnu packages ssh) + #:use-module (gnu packages linux) + #:use-module (gnu packages networking) + #:export (whispers-vpn-service-type + whispers-vpn-configuration + whispers-vpn-configuration?)) + +(define-record-type* <whispers-vpn-configuration> + whispers-vpn-configuration make-whispers-vpn-configuration + whispers-vpn-configuration? + this-whispers-vpn-configuration + ;; A file-like object. + (ssh-package whispers-vpn-configuration-ssh-package + (default openssh)) + ;; A file-like-object. + (procps-package whispers-vpn-configuration-procps-package + (default procps)) + ;; A file-like-object. + (iproute-package whispers-vpn-configuration-iproute-package + (default iproute)) + ;; A file-like-object. + (iptables-package whispers-vpn-configuration-iptables-package + (default iptables)) + ;; A file-like-object. + (sed-package whispers-vpn-configuration-sed-package + (default sed)) + ;; A network-constants record. + (constants whispers-vpn-configuration-constants + (default (network-constants))) + ;; A boolean value. + (masquerade? whispers-vpn-configuration-masquerade? + (default #t)) + ;; A boolean value. + (ipv4-ip-forward? whispers-vpn-configuration-ipv4-ip-forward? + (default #t)) + ;; A boolean value. + (client? whispers-vpn-configuration-client? + (default #f)) + ;; A boolean value. + (manual-physical-if? whispers-vpn-configuration-manual-physical-if? + (default #f)) + ;; A string. + (physical-if-override whispers-vpn-configuration-physical-if-override + (default "eth0")) + ;; A boolean value. + (manual-phy-gateway? whispers-vpn-configuration-manual-phy-gateway? + (default #f)) + ;; A string. + (phy-gateway-override whispers-vpn-configuration-phy-gateway-override + (default "192.168.1.1")) + ;; An integer + (client-tun-device whispers-vpn-configuration-client-tun-device + (default 0)) + ;; A string. + (server-sshd-host whispers-vpn-configuration-server-sshd-host + (default "127.0.0.1")) + ;; An integer. + (server-sshd-port whispers-vpn-configuration-server-sshd-port + (default 22)) + ;; A string. + (proxy-sshd-user whispers-vpn-configuration-proxy-sshd-user + (default "root")) + ;; A string. + (proxy-sshd-host whispers-vpn-configuration-proxy-sshd-host + (default "127.0.0.1")) + ;; An integer. + (proxy-sshd-port whispers-vpn-configuration-proxy-sshd-port + (default 22)) + ;; An integer. + (client-sshd-port whispers-vpn-configuration-client-sshd-port + (default 22)) + ;; A boolean value. + (stealth? whispers-vpn-configuration-stealth? + (default #f)) + ;; An integer. + (stealth-base-port whispers-vpn-configuration-stealth-base-port + (default 31273)) + ;; A boolean value. + (stealth-clear-password? + whispers-vpn-configuration-stealth-clear-password? + (default #f)) + ;; A string. + (stealth-user-password whispers-vpn-configuration-stealth-user-password + (default "none")) + ;; An integer. + (forward-port whispers-vpn-configuration-forward-port + (default 36492)) + ;; An integer. + ;; If there's a NIC, sshd-port can't be used, need an overridable default. + (forward-exit-port whispers-vpn-configuration-forward-exit-port + (default + (whispers-vpn-configuration-server-sshd-port + this-whispers-vpn-configuration)) + (thunked)) + ;; A boolean value. + (vpn-server-clear-password? + whispers-vpn-configuration-vpn-server-clear-password? + (default #f)) + ;; A string. + (vpn-server-user-password + whispers-vpn-configuration-vpn-server-user-password + (default "none")) + ;; A quoted cron job time specification. + (forward-resurrect-time-spec + whispers-vpn-configuration-forward-resurrect-time-spec + (default ''(next-minute '(34)))) + ;; A boolean value. + (client-whispers-user-clear-password? + whispers-vpn-configuration-client-whispers-user-clear-password? + (default #f)) + ;; A string. + (client-whispers-password + whispers-vpn-configuration-client-whispers-password + (default "none")) + ;; A boolean value. + (%auto-register? whispers-vpn-configuration-auto-register? + (default #f)) + ;; A boolean value. + (%auto-connect? whispers-vpn-configuration-auto-connect? + (default #f))) + +(define-record-type* <network-constants> + network-constants make-network-constants + network-constants? + this-network-constants + ;; A string. + (ip-prefix network-constants-ip-prefix + (default "10.0.0")) + ;; An integer. + (lowest-ip network-constants-lowest-ip + (default 10)) + ;; An integer. + (lowest-tun-number network-constants-lowest-tun-number + (default + (quotient + (network-constants-lowest-ip + this-network-constants) + 2)) + (thunked)) + ;; An integer. + (base-port-reverse network-constants-base-port-reverse + (default 37215)) + ;; An integer. + (handshake-port network-constants-handshake-port + (default 38573))) + +(define (stealth-record config stealth-port) + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (sshd-user (whispers-vpn-configuration-proxy-sshd-user config)) + (sshd-host (whispers-vpn-configuration-proxy-sshd-host config)) + (sshd-port (whispers-vpn-configuration-proxy-sshd-port config)) + (forward-port (whispers-vpn-configuration-forward-port config)) + (clear-password? + (whispers-vpn-configuration-stealth-clear-password? config)) + (user-password + (whispers-vpn-configuration-stealth-user-password config)) + (pid-folder "/run/whispers/vpn/ssh-tunneler") + (log-folder "/var/log/whispers/vpn/ssh-tunneler") + (auto-register? (whispers-vpn-configuration-auto-register? config))) + (ssh-connection-configuration (ssh-package ssh-package) + (sshd-user sshd-user) + (sshd-host sshd-host) + (known-hosts-files '("/dev/null")) + (strict-check "no") + (require-networking? #f) + (sshd-port sshd-port) + (forwards + (list (dynamic-forward-configuration + (entry-port stealth-port)))) + (clear-password? clear-password?) + (sshd-user-password user-password) + (pid-folder-override? #t) + (pid-folder-override pid-folder) + (dedicated-log-file? #t) + (log-rotate? #t) + (log-folder-override? #t) + (log-folder-override log-folder) + ;; FIXME: auto registration not working in + ;; the demo script. + (%auto-start? auto-register?)))) + +(define (forward-configuration config) + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (socks-port (whispers-vpn-configuration-stealth-base-port config)) + (stealth-config (stealth-record config socks-port)) + (sshd-user "whispers") + (sshd-host (whispers-vpn-configuration-server-sshd-host config)) + (sshd-port (whispers-vpn-configuration-server-sshd-port config)) + (forward-port (whispers-vpn-configuration-forward-port config)) + (exit-port (whispers-vpn-configuration-forward-exit-port config)) + (clear-password? + (whispers-vpn-configuration-vpn-server-clear-password? config)) + (user-password + (whispers-vpn-configuration-vpn-server-user-password config)) + (pid-folder "/run/whispers/vpn/ssh-tunneler") + (log-folder "/var/log/whispers/vpn/ssh-tunneler") + (auto-register? (whispers-vpn-configuration-auto-register? config))) + (ssh-connection-configuration (ssh-package ssh-package) + (require-networking? #f) + (socks-proxy-config + (socks-proxy-configuration + (use-proxy? stealth?) + (dynamic-forward (if stealth? + stealth-config + #f)))) + (sshd-user sshd-user) + (sshd-host sshd-host) + (sshd-port sshd-port) + (known-hosts-files '("/dev/null")) + (strict-check "no") + (forwards + (list (port-forward-configuration + (forward-type 'port) + (entry-port forward-port) + (exit-port exit-port)))) + (clear-password? clear-password?) + (sshd-user-password user-password) + (pid-folder-override? #t) + (pid-folder-override pid-folder) + (dedicated-log-file? #t) + (log-rotate? #t) + (log-folder-override? log-folder) + (log-folder-override log-folder) + (%auto-start? auto-register?)))) + +(define (handshake-forward-configuration config) + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (base-port (whispers-vpn-configuration-stealth-base-port config)) + (stealth-config (stealth-record config + (+ base-port + 1))) + (sshd-user "whispers") + (sshd-host (whispers-vpn-configuration-server-sshd-host config)) + (sshd-port (whispers-vpn-configuration-server-sshd-port config)) + (constants (whispers-vpn-configuration-constants config)) + (handshake-port (network-constants-handshake-port constants)) + (exit-port (whispers-vpn-configuration-client-sshd-port config)) + (clear-password? + (whispers-vpn-configuration-vpn-server-clear-password? config)) + (user-password + (whispers-vpn-configuration-vpn-server-user-password config)) + (herd-path "/run/current-system/profile/bin/herd") + (handshake (string-append herd-path + " " + "lieutenant-action" + " " + "whispers" + " " + "lieutenant-action" + " " + "vpn" + " " + "complete-handshake" + " " + "network-rw")) + (pid-folder "/run/whispers/vpn/ssh-tunneler") + (log-folder "/var/log/whispers/vpn/ssh-tunneler")) + (ssh-connection-configuration (ssh-package ssh-package) + (require-networking? #f) + (socks-proxy-config + (socks-proxy-configuration + (use-proxy? stealth?) + (dynamic-forward (if stealth? + stealth-config + #f)))) + (sshd-user sshd-user) + (sshd-host sshd-host) + (sshd-port sshd-port) + (known-hosts-files '("/dev/null")) + (strict-check "no") + (forwards + (list (reverse-port-forward-configuration + (forward-type 'reverse-port) + (entry-port handshake-port) + (exit-port exit-port)))) + (clear-password? clear-password?) + (sshd-user-password user-password) + (extra-local-commands `(,handshake)) + (pid-folder-override? #t) + (pid-folder-override pid-folder) + (dedicated-log-file? #t) + (log-rotate? #t) + (log-folder-override? #t) + (log-folder-override log-folder) + (%auto-start? #f)))) + +(define (reverse-stealth-conf config) + (let ((socks-port (whispers-vpn-configuration-stealth-base-port + config))) + (stealth-record config + (+ socks-port + 2)))) + +(define (reverse-forward-configurations config) + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (sshd-user "whispers") + (sshd-host (whispers-vpn-configuration-server-sshd-host config)) + (sshd-port (whispers-vpn-configuration-server-sshd-port config)) + (exit-port (whispers-vpn-configuration-client-sshd-port config)) + (clear-password? + (whispers-vpn-configuration-vpn-server-clear-password? config)) + (user-password + (whispers-vpn-configuration-vpn-server-user-password config)) + (empty-net (empty-network (whispers-vpn-configuration-constants + config))) + (pid-folder "/run/whispers/vpn/ssh-tunneler") + (log-folder "/var/log/whispers/vpn/ssh-tunneler") + (herd-path "/run/current-system/profile/bin/herd") + (tunnel (string-append herd-path + " " + "lieutenant-action" + " " + "whispers" + " " + "lieutenant-action" + " " + "vpn" + " " + "tun-start-dev" + " " + "connecting")) + (net-constants (whispers-vpn-configuration-constants config)) + (empty-net (empty-network net-constants))) + (map (lambda (empty-voucher) + (let* ((entr ((lambda (lst) + (if (null? lst) + #f + (cadr (car lst)))) (filter (lambda (entry) + (equal? + (car entry) + 'reverse-port)) + empty-voucher))) + (dyn (if stealth? + (reverse-stealth-conf config) + #f)) + (forw (list (reverse-port-forward-configuration + (forward-type 'reverse-port) + (entry-port entr) + (exit-port exit-port))))) + (ssh-connection-configuration (ssh-package ssh-package) + (require-networking? #f) + (socks-proxy-config + (socks-proxy-configuration + (use-proxy? stealth?) + (dynamic-forward dyn))) + (sshd-user sshd-user) + (sshd-host sshd-host) + (sshd-port sshd-port) + (known-hosts-files '("/dev/null")) + (strict-check "no") + (forwards forw) + (clear-password? clear-password?) + (sshd-user-password user-password) + (extra-local-commands `(,tunnel)) + (pid-folder-override? #t) + (pid-folder-override pid-folder) + (dedicated-log-file? #t) + (log-rotate? #t) + (log-folder-override? #t) + (log-folder-override log-folder) + (%auto-start? #f)))) + empty-net))) + +(define (tun-stealth-conf config) + (let ((socks-port (whispers-vpn-configuration-stealth-base-port + config))) + (stealth-record config + (+ socks-port + 3)))) + +(define (tun-device-forward-configurations config) + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (socks-port (whispers-vpn-configuration-stealth-base-port config)) + (sshd-user "whispers") + (sshd-host (whispers-vpn-configuration-server-sshd-host config)) + (sshd-port (whispers-vpn-configuration-server-sshd-port config)) + (exit-port (whispers-vpn-configuration-client-sshd-port config)) + (clear-password? + (whispers-vpn-configuration-vpn-server-clear-password? config)) + (user-password + (whispers-vpn-configuration-vpn-server-user-password config)) + (pid-folder "/run/whispers/vpn/ssh-tunneler") + (log-folder "/var/log/whispers/vpn/ssh-tunneler") + (herd-path "/run/current-system/profile/bin/herd") + (tun-int (whispers-vpn-configuration-client-tun-device config)) + (tun-str (number->string tun-int)) + (complete-connect (string-append herd-path + " " + "lieutenant-action" + " " + "whispers" + " " + "lieutenant-action" + " " + "vpn" + " " + "set-connected-knock" + " " + "network-rw" + " " + "&&" + " " + herd-path + " " + "lieutenant-action" + " " + "whispers" + " " + "start-tun" + tun-str + " " + "vpn")) + (net-constants (whispers-vpn-configuration-constants config)) + (empty-net (empty-network net-constants))) + (map (lambda (empty-voucher) + (let* ((entr ((lambda (lst) + (if (null? lst) + #f + (cadr (car lst)))) (filter + (lambda (entry) + (equal? + (car entry) + 'tun-device-number)) + empty-voucher))) + (dyn (if stealth? + (tun-stealth-conf config) + #f)) + (forw (list (tunnel-forward-configuration + (entry-type 'preset) + (exit-type 'preset) + (entry-tun tun-int) + (exit-tun entr))))) + (ssh-connection-configuration (ssh-package ssh-package) + (require-networking? #f) + (socks-proxy-config + (socks-proxy-configuration + (use-proxy? stealth?) + (dynamic-forward dyn))) + (sshd-user sshd-user) + (sshd-host sshd-host) + (sshd-port sshd-port) + (known-hosts-files '("/dev/null")) + (strict-check "no") + (forwards forw) + (clear-password? clear-password?) + (sshd-user-password user-password) + (extra-local-commands + `(,complete-connect)) + (pid-folder-override? #t) + (pid-folder-override pid-folder) + (dedicated-log-file? #t) + (log-rotate? #t) + (log-folder-override? #t) + (log-folder-override log-folder) + (%auto-start? #f)))) + empty-net))) + +(define (int-range start end) + (if (< end start) + '() + (cons start (int-range (+ start 1) end)))) + +(define (empty-network constants) + "Return the network state of an empty network configurabale by +CONSTANTS, a record of tne <network-constants> type." + (let ((ip-concat + (lambda (ip-prefix last-byte) + (string-append ip-prefix + "." + (number->string last-byte))))) + (map (lambda (voucher-index) + (let ((ip-prefix (network-constants-ip-prefix constants)) + (lowest-ip (network-constants-lowest-ip constants)) + (lowest-tun-number (network-constants-lowest-tun-number + constants)) + (lowest-port-number (network-constants-base-port-reverse + constants))) + `((voucher-number ,voucher-index) + (client-hostname #f) + (tun-device-number ,(+ lowest-tun-number voucher-index)) + (reverse-port ,(+ lowest-port-number voucher-index)) + (server-ip ,(ip-concat ip-prefix (+ lowest-ip + (* voucher-index 2)))) + (client-ip ,(ip-concat ip-prefix (+ lowest-ip + (* voucher-index 2) + 1))) + (tun-request? #f) + (connected? #f)))) + (int-range 0 + (- 127 + (quotient (network-constants-lowest-ip constants) + 2)))))) + +(define (tun-dev-str tun-int) + "Returns the string naming a TUN device whose number is the integer +TUN-INT." + (string-append "tun" + (number->string tun-int))) + +(define (tun-dev-sym tun-int) + "Returns a symbol cast from the string naming a TUN device whose +number is the integer TUN-INT." + (string->symbol (tun-dev-str tun-int))) + +(define (ipv4-forward-actions config) + "Returns a list of <shepherd-action> records for the 'ipv4-ip-forward +lieutenant of the 'tcp-ip service, used by the VPN server to turn IPv4 +forwarding on and off on demand as appropriate, configurable by CONFIG, +a record of the <whispers-vpn-configuration> type." + (let* ((procps-pk (whispers-vpn-configuration-procps-package config)) + (sysctl-exec (file-append procps-pk + "/sbin/sysctl"))) + (list (shepherd-action + (name 'pre-start) + (documentation "Turn on IPv4 forwarding for this server.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'ipv4-ip-forward) + 'ipv4-ip-forward-on)))) + (shepherd-action + (name 'post-stop) + (documentation "Turn off IPv4 forwarding for this server.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'ipv4-ip-forward) + 'ipv4-ip-forward-off)))) + (shepherd-action + (name 'ipv4-ip-forward-on) + (documentation "Turn on IPv4 forwarding in the kernel +run-time parameters.") + (procedure + #~(lambda (running) + (fork+exec-command (list #$sysctl-exec + "-w" + "net.ipv4.ip_forward=1"))))) + (shepherd-action + (name 'ipv4-ip-forward-off) + (documentation "Turn off IPv4 forwarding in the kernel +run-time parameters.") + (procedure + #~(lambda (running) + (fork+exec-command (list #$sysctl-exec + "-w" + "net.ipv4.ip_forward=0")))))))) + +(define (masquerade-actions config) + "Returns a list of <shepherd-action> records for the 'masquerade +lieutenant of the 'tcp-ip service, used by the VPN servier to turn NAT +masquerading on and off on demand as appropriate, configurable by +CONFIG, a record of the <whispers-vpn-configuration> type." + (let* ((iptb-pk (whispers-vpn-configuration-iptables-package config)) + (iptables-exec (file-append iptb-pk + "/sbin/iptables")) + (ip-package (whispers-vpn-configuration-iproute-package config)) + (ip-exec (file-append ip-package + "/sbin/ip")) + (sed-package (whispers-vpn-configuration-sed-package + config)) + (sed-exec (file-append sed-package + "/bin/sed")) + (herd-path "/run/current-system/profile/bin/herd") + (socket-path "/run/whispers/vpn/unix-sockets/vpn.sock")) + (list (shepherd-action + (name 'pre-start) + (documentation "Turn on NAT masquerading for this server.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'masquerade) + 'masquerade-on)))) + (shepherd-action + (name 'post-stop) + (documentation "Turn off NAT masquerading for this server.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'masquerade) + 'masquerade-off)))) + (shepherd-action + (name 'masquerade-on) + (documentation "Turn on NAT masquerading.") + (procedure + #~(lambda (running) + (fork+exec-command (list + "/bin/sh" + "-c" + (string-append + #$herd-path + " " + "-s" + " " + #$socket-path + " " + "burn-state" + " " + "physical-dev-rw" + " " + "$(" + #$ip-exec + " route | " + #$sed-exec + " -n '/^default/ " + "s=.*dev \\(.*\\)$=\\1=p'" + ") $(" + #$ip-exec + " route | " + #$sed-exec + " -n '/^default/ " + "s=.*via " + "\\([^ ]\\+\\).*$=\\1=p'" + ")" + " " + "&&" + " " + #$iptables-exec + " " + "-v" + " " + "-t" + " " + "nat" + " " + "-A" + " " + "POSTROUTING" + " " + "-o" + " " + "$(" + #$herd-path + " " + "-s" + " " + #$socket-path + " " + "display-physical-interface-name" + " " + "physical-dev-rw" + ")" + " " + "-j" + " " + "MASQUERADE")))))) + (shepherd-action + (name 'masquerade-off) + (documentation "Turn off NAT masquerading.") + (procedure + #~(lambda (running) + (fork+exec-command (list + "/bin/sh" + "-c" + (string-append + #$iptables-exec + " " + "-v" + " " + "-t" + " " + "nat" + " " + "-D" + " " + "POSTROUTING" + " " + "-o" + " " + "$(" + #$herd-path + " " + "-s" + " " + #$socket-path + " " + "display-physical-interface-name" + " " + "physical-dev-rw" + ")" + " " + "-j" + " " + "MASQUERADE"))))))))) + +(define (server-tun-actions config tun-int server-ip client-ip) + "Returns a list of shepherd actions for the whispers service +reprensenting the tun device of a VPN server whose number is the integer +TUN-INT, whose ip address is the string SERVER-IP and whose peer address +is the string CLIENT-IP, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (let* ((tun-str (tun-dev-str tun-int)) + (tun-sym (tun-dev-sym tun-int)) + (ip-package (whispers-vpn-configuration-iproute-package config)) + (ip-exec (file-append ip-package + "/sbin/ip"))) + (list (shepherd-action + (name 'start-tun) + (documentation (string-append "Start the TUN device service" + tun-str + ".")) + (procedure + #~(lambda (running) + (start '#$tun-sym)))) + (shepherd-action + (name 'stop-tun) + (documentation (string-append "Stop the TUN device service" + tun-str + ".")) + (procedure + #~(lambda (running) + (stop-service (lookup-service '#$tun-sym))))) + (shepherd-action + (name 'pre-start) + (documentation (string-append "Create the TUN device service" + tun-str + ".")) + (procedure + #~(lambda (running) + (fork+exec-command (list "/bin/sh" + "-c" + (string-append #$ip-exec + " " + "tuntap" + " " + "add" + " " + #$tun-str + " " + "mode" + " " + "tun" + " " + "user" + " " + "whispers" + " " + "group" + " " + "whispers" + " " + "&&" + " " + #$ip-exec + " " + "addr" + " " + "add" + " " + #$server-ip + "/32" + " " + "peer" + " " + #$client-ip + " " + "dev" + " " + #$tun-str + " " + "&&" + " " + #$ip-exec + " " + "link" + " " + "set" + " " + #$tun-str + " " + "up")))))) + (shepherd-action + (name 'post-stop) + (documentation (string-append "Delete the TUN device service" + tun-str + ".")) + (procedure + #~(lambda (running) + (fork+exec-command (list "/bin/sh" + "-c" + (string-append #$ip-exec + " " + "link" + " " + "set" + " " + #$tun-str + " " + "down" + " " + ";" + " " + #$ip-exec + " " + "addr" + " " + "del" + " " + #$server-ip + "/32" + " " + "peer" + " " + #$client-ip + " " + "dev" + " " + #$tun-str + " " + ";" + " " + #$ip-exec + " " + "tuntap" + " " + "del" + " " + #$tun-str + " " + "mode" + " " + "tun"))))))))) + +(define physical-dev-state-write-actions + (list (shepherd-action + (name 'burn-state) + (documentation "unload the existing instance of the +'physical-dev-state service. Write a physical device state as a new +service with the string PHY-DEV-NAME recorded in its +'physical-interface-name action and the string ROUTER-IP recorded in its +'physical-gateway-ip action.") + (procedure + #~(lambda (running phy-dev-name router-ip) + (perform-service-action (lookup-service 'root) + 'unload + "physical-dev-state") + (display "Burning new 'physical-dev-state service.\n") + (register-services + (make <service> + #:provides '(physical-dev-state) + #:start (lambda whatever #f) + #:stop (lambda whatever #t) + #:actions (make-actions + (physical-interface-name + "Return the name of the physical +interface which supported +the default route when +the VPN was disconnected." + (lambda (running) phy-dev-name)) + (physical-gateway-ip + "Return the ip of the gateway +of the physical interface +which supported the default +route when the VPN was +disconnected." + (lambda (running) router-ip))) + #:docstring "Queryable physical network device +restoration state of a +Whispers VPN." + #:one-shot? #t))))))) + +(define physical-dev-resolve-actions + (list (shepherd-action + (name 'display-physical-interface-name) + (documentation "For debugging purposes, display +the name of the physical +interface which supported +the default route when +the VPN was disconnected.") + (procedure + #~(lambda (running) + (display (perform-service-action (lookup-service + 'physical-dev-rw) + 'physical-interface-name))))) + (shepherd-action + (name 'physical-interface-name) + (documentation "Return the name of the physical +interface which supported +the default route when +the VPN was disconnected.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'physical-dev-state) + 'physical-interface-name)))) + (shepherd-action + (name 'display-physical-gateway-ip) + (documentation "For debugging purposes, display the ip of the +gateway of the physical interface +which supported the default +route when the VPN was +disconnected.") + (procedure + #~(lambda (running) + (display (perform-service-action (lookup-service + 'physical-dev-rw) + 'physical-gateway-ip))))) + (shepherd-action + (name 'physical-gateway-ip) + (documentation "Return the ip of the gateway +of the physical interface +which supported the default +route when the VPN was +disconnected.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'physical-dev-state) + 'physical-gateway-ip)))))) + +(define (physical-dev-guessing-actions config) + "Return a list of shepherd actions used while the VPN is disconnected in +order to guess the name of the default network interface that should +support the VPN tunnel, and the IP address of its +gateway. Afternatively, user configurations are used instead if the user +has overriden the guessing by setting switches in CONFIG, a record of +the <whispers-vpn-configuration> type." + (list (shepherd-action + (name 'guess-interface) + (documentation "Burn strings into the physical-dev-state +service as the guesses of the name and gateway address of the physical +interface which supports the default route when the VPN is +disconnected. Then pass the hand to another shell through the VPN +service to finish routing the connection.") + (procedure + (let* ((client-tun (whispers-vpn-configuration-client-tun-device + config)) + (client-tun-str (tun-dev-str client-tun)) + (phy-override? + (whispers-vpn-configuration-manual-physical-if? config)) + (phy-override + (whispers-vpn-configuration-physical-if-override + config)) + (ip-package (whispers-vpn-configuration-iproute-package + config)) + (ip-exec (file-append ip-package + "/sbin/ip")) + (sed-package (whispers-vpn-configuration-sed-package + config)) + (sed-exec (file-append sed-package + "/bin/sed")) + (herd-path "/run/current-system/profile/bin/herd") + (socket-path "/run/whispers/vpn/unix-sockets/vpn.sock")) + #~(lambda (running) + (if #$phy-override? + #$phy-override + (fork+exec-command + (list "/bin/sh" + "-c" + (string-append #$herd-path + " " + "-s" + " " + #$socket-path + " " + "burn-state" + " " + "physical-dev-rw" + " " + "$(" + #$ip-exec + " route | " + #$sed-exec + " -n '/^default/ " + "s=.*dev \\(.*\\)$=\\1=p'" + ") $(" + #$ip-exec + " route | " + #$sed-exec + " -n '/^default/ " + "s=.*via " + "\\([^ ]\\+\\).*$=\\1=p'" + ")" + " " + "&&" + " " + #$herd-path + " " + "-s" + " " + #$socket-path + " " + "tun-route" + " " + #$client-tun-str)))))))))) + +(define (client-tun-actions config) + "Returns a list of shepherd actions for the whispers service +reprensenting the tun device of a connected client, configurable by +CONFIG, a record of the <whispers-vpn-configuration> type." + (let* ((client-tun (whispers-vpn-configuration-client-tun-device config)) + (client-tun-str (tun-dev-str client-tun)) + (client-tun-sym (tun-dev-sym client-tun)) + (ip-package (whispers-vpn-configuration-iproute-package config)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (proxy-ip (whispers-vpn-configuration-proxy-sshd-host config)) + (server-ip (whispers-vpn-configuration-server-sshd-host + config)) + (via-phy (if stealth? + proxy-ip + server-ip)) + (phys-if #~(perform-service-action (lookup-service 'physical-dev-rw) + 'physical-interface-name)) + (gate #~(perform-service-action (lookup-service 'physical-dev-rw) + 'physical-gateway-ip)) + (ip-exec (file-append ip-package + "/sbin/ip"))) + (list (shepherd-action + (name 'start-tun) + (documentation (string-append "Start the TUN device " + client-tun-str + ".")) + (procedure + #~(lambda (running) + (start '#$client-tun-sym)))) + (shepherd-action + (name 'stop-tun) + (documentation (string-append "Stop the TUN device " + client-tun-str + ".")) + (procedure + #~(lambda (running) + (stop-service (lookup-service '#$client-tun-sym))))) + (shepherd-action + (name 'tun-route) + (documentation "Establish network address and routing rules +for a newly connected client.") + (procedure + #~(lambda (running) + (let* ((client-ip (perform-service-action (lookup-service + 'network-rw) + 'hostname->ip + (gethostname))) + (server-ip (perform-service-action (lookup-service + 'network-rw) + 'hostname->server-ip + (gethostname))) + (server-ip-stripped + (regexp-substitute + #f + (string-match "([0-9]+\\.[0-9]+\\.[0-9]+)\\.[0-9]+" + server-ip) + 1 + ".0"))) + (fork+exec-command + (list "/bin/sh" + "-c" + (string-append #$ip-exec + " " + "route" + " " + "save" + " " + "&&" + " " + #$ip-exec + " " + "addr" + " " + "add" + " " + client-ip + " " + "peer" + " " + server-ip + " " + "dev" + " " + #$client-tun-str + " " + "&&" + " " + #$ip-exec + " " + "link" + " " + "set" + " " + #$client-tun-str + " " + "up" + " " + "&&" + " " + #$ip-exec + " " + "route" + " " + "del" + " " + "default" + " " + "&&" + " " + #$ip-exec + " " + "route" + " " + "add" + " " + #$via-phy + " " + "via" + " " + #$gate + " " + "dev" + " " + #$phys-if + " " + "&&" + " " + #$ip-exec + " " + "route" + " " + "add" + " " + server-ip-stripped + "/24" + " " + "via" + " " + server-ip + " " + "dev" + " " + #$client-tun-str + " " + "&&" + " " + #$ip-exec + " " + "route" + " " + "add" + " " + "default" + " " + "via" + " " + server-ip + " " + "dev" + " " + #$client-tun-str))))))) + (shepherd-action + (name 'pre-start) + (documentation "Burn relevant data about the physical network +interface, then establish network address and routing rules for a newly +connected client.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'physical-dev-rw) + 'guess-interface)))) + (shepherd-action + (name 'post-stop) + (documentation "Restore default routing to its previous +pre-connection state.") + (procedure + #~(lambda (running) + (let ((client-ip (perform-service-action (lookup-service + 'network-rw) + 'hostname->ip + (gethostname))) + (server-ip (perform-service-action (lookup-service + 'network-rw) + 'hostname->server-ip + (gethostname)))) + (fork+exec-command + (list "/bin/sh" + "-c" + (string-append + ;; #$ip-exec + ;; " " + ;; "link" + ;; " " + ;; "set" + ;; " " + ;; #$client-tun-str + ;; " " + ;; "down" + ;; " " + ;; "&&" + ;; " " + ;; #$ip-exec + ;; " " + ;; "addr" + ;; " " + ;; "del" + ;; " " + ;; client-ip + ;; " " + ;; "peer" + ;; " " + ;; server-ip + ;; " " + ;; "dev" + ;; " " + ;; #$client-tun-str + ;; " " + ;; "&&" + ;; " " + ;; #$ip-exec + ;; " " + ;; "route" + ;; " " + ;; "del" + ;; " " + ;; "default" + ;; " " + ;; "&&" + ;; " " + #$ip-exec + " " + "route" + " " + "del" + " " + #$via-phy + " " + "via" + " " + #$gate + " " + "dev" + " " + #$phys-if + " " + "&&" + " " + #$ip-exec + " " + "route" + " " + "add" + " " + "default" + " " + "via" + " " + #$gate + " " + "dev" + " " + #$phys-if)))))))))) + +(define (tcp-ip-actions config) + "Returns a list of shepherd actions for the lieutenants of the 'vpn +service handling tun devices, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (let* ((client? (whispers-vpn-configuration-client? config)) + (empty-net (empty-network (whispers-vpn-configuration-constants + config))) + (client-tun (whispers-vpn-configuration-client-tun-device config)) + (client-tun-sym (tun-dev-sym client-tun)) + (client-tun-str (symbol->string client-tun-sym)) + (voucher->tun-int (lambda (voucher) + (cadar (filter (lambda (field) + (equal? (car field) + 'tun-device-number)) + voucher)))) + (voucher->tun-str (lambda (voucher) + (tun-dev-str (voucher->tun-int voucher)))) + (masquerade? (whispers-vpn-configuration-masquerade? config))) + (if client? + (list (shepherd-action + (name (string->symbol (string-append "start-" + client-tun-str))) + (documentation (string-append "Start the client-side TUN +interface " + client-tun-str + ".")) + (procedure + #~(lambda (running) + (perform-service-action + (lookup-service 'vpn) + 'lieutenant-action + "start-tun" + #$client-tun-str)))) + (shepherd-action + (name (string->symbol + (string-append "stop-" + client-tun-str))) + (documentation (string-append "Stop the client-side TUN +interface " + client-tun-str + ".")) + (procedure + #~(lambda (running) + (perform-service-action + (lookup-service 'vpn) + 'lieutenant-action + "stop-tun" + #$client-tun-str))))) + (append + (map (lambda (voucher) + (shepherd-action + (name (string->symbol + (string-append "start-" + (voucher->tun-str voucher)))) + (documentation (string-append "Start the server-side +TUN interface " + (voucher->tun-str voucher) + ".")) + (procedure + #~(lambda (running) + (perform-service-action + (lookup-service '#$(string->symbol + (voucher->tun-str voucher))) + 'start-tun))))) + empty-net) + (map (lambda (voucher) + (shepherd-action + (name (string->symbol + (string-append "stop-" + (voucher->tun-str voucher)))) + (documentation (string-append "Stop the server-side TUN +interface " + (voucher->tun-str voucher) + ".")) + (procedure + #~(lambda (running) + (perform-service-action + (lookup-service '#$(string->symbol + (voucher->tun-str voucher)))) + 'stop-tun)))) + empty-net))))) + +(define (physical-dev-rw-shepherd-services config) + "Returns a list of one <shepherd-service> object providing actions to +infer, read and write the physical interface device state stored in the +'physical-dev-state service in its scope, configurable by CONFIG, a +record of the <whishpers-vpn-configuration> type. Data about the +physical interface default route is retrievable from this service to +support the establishement of interface addresses and routing rules +during connection and disconnection of a client from the VPN." + (list (shepherd-service + (documentation "Physical-Dev state read and write operations.") + (provision '(physical-dev-rw)) + (requirement '()) + (start #~(lambda config #f)) + (actions (append physical-dev-state-write-actions + physical-dev-resolve-actions + (physical-dev-guessing-actions config))) + (stop #~(lambda config #t)) + (one-shot? #t) + (auto-start? #f)))) + +(define physical-dev-rw-service-type + (service-type + (name 'physical-dev-rw) + (description "Shepherd service used for read and write operations of +the physical-dev state of a Whispers VPN.") + (extensions + (list (service-extension shepherd-root-service-type + physical-dev-rw-shepherd-services))) + (default-value (whispers-vpn-configuration)))) + +(define (physical-dev-state-shepherd-services whatever) + "Returns a list of one <shepherd-service> object doing nothing of +interest in the state in which it is instanciated at guix's system +reconfigure time, not configurable by WHATEVER. While a VPN client will +be connecting at the OS run-time, the characteristics of the physical +network interface will be inferred and burned into a modified +re-instanciated version of this service." + (list (shepherd-service + (documentation "Queryable physical-dev state of a Whispers VPN.") + (provision '(physical-dev-state)) + (requirement '()) + (start #~(lambda whatever #f)) + (actions + (list (shepherd-action + (name 'physical-interface-name) + (documentation "Does not return anything of interest at +this time.") + (procedure #~(lambda (running) "Unknown."))) + (shepherd-action + (name 'physical-gateway-ip) + (documentation "Does not return anything of interest at +this time.") + (procedure #~(lambda (running) "Unknown."))))) + (stop #~(lambda whatever #t)) + (one-shot? #t) + (auto-start? #f)))) + +(define physical-dev-state-service-type + (service-type + (name 'physical-dev-state) + (description "Shepherd service used for storage and retrieval of the +physical-dev state of a Whispers VPN.") + (extensions + (list (service-extension shepherd-root-service-type + physical-dev-state-shepherd-services))) + (default-value 'whatever))) + +(define (server-tcp-ip-lieutenant voucher config) + "Returns a whispers lieutenant handling a VPN-server-side tun device +as defined by the voucher data VOUCHER, configurable by CONFIG, a record +of the <whispers-vpn-configuration> type." + (let* ((tun-int (cadar (filter (lambda (field) + (equal? (car field) + 'tun-device-number)) + voucher))) + (server-ip (cadar (filter (lambda (field) + (equal? (car field) + 'server-ip)) + voucher))) + (client-ip (cadar (filter (lambda (field) + (equal? (car field) + 'client-ip)) + voucher))) + (tun-str (tun-dev-str tun-int)) + (tun-sym (tun-dev-sym tun-int)) + (masquerade? (whispers-vpn-configuration-masquerade? config)) + (ipv4-forw? (whispers-vpn-configuration-ipv4-ip-forward? config))) + (service whispers-service-type + (whispers-configuration + (name tun-sym) + (requires (append (if masquerade? + '(masquerade) + '()) + (if ipv4-forw? + '(ipv4-ip-forward) + '()))) + (extra-packages (list iproute + iptables)) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions (server-tun-actions config + tun-int + server-ip + client-ip)) + (%auto-start? #f))))) + +(define (tcp-ip-lieutenants config) + "Returns a list of lieutenants of the 'vpn service for handling the hair +around tun devices, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (let* ((client? (whispers-vpn-configuration-client? config)) + (client-tun (whispers-vpn-configuration-client-tun-device config)) + (client-dev (tun-dev-sym client-tun)) + (constants (whispers-vpn-configuration-constants config))) + (append (list (service physical-dev-rw-service-type config) + (service physical-dev-state-service-type 'whatever)) + (if client? + (list + (service whispers-service-type + (whispers-configuration + (name client-dev) + (requires '(registered)) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions (client-tun-actions config)) + (%auto-start? #f)))) + (append (map (lambda (voucher) + (server-tcp-ip-lieutenant voucher config)) + (empty-network constants)) + (list (service whispers-service-type + (whispers-configuration + (name 'masquerade) + (requires '()) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions (masquerade-actions + config)) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'ipv4-ip-forward) + (requires '()) + (pre-start-action? #t) + (post-stop-action? #t) + (extra-actions (ipv4-forward-actions + config)) + (%auto-start? #f))))))))) + +(define want-connect-state-write-actions + (list (shepherd-action + (name 'want-connect-on) + (documentation "Activate the connection status wish of a VPN +client by burning a new 'want-connect-state service with a #t action +return value.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'want-connect-rw) + 'burn-state + #t)))) + (shepherd-action + (name 'want-connect-off) + (documentation "Disactivate the connection status wish of a VPN +client by burning a new 'want-connect-state service with a #f action +return value.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'want-connect-rw) + 'burn-state + #f)))) + (shepherd-action + (name 'burn-state) + (documentation "unload the existing instance of the +'want-connect-state service. Write a connection status wish as a new +service with the boolean value WANT? recorded in its 'want-connect? +action.") + (procedure + #~(lambda (running want?) + (when (lookup-service 'want-connect-state) + (perform-service-action (lookup-service 'root) + 'unload + "want-connect-state")) + (display "Burning new 'want-connect-state service.\n") + (register-services + (make <service> + #:provides '(want-connect-state) + #:start (lambda whatever #f) + #:stop (lambda whatever #t) + #:actions (make-actions + (want-connect? + "Return the connection status wish of a +VPN client. The returned boolean value is used only at the end of client +registration, to determine if connection is to be performed +auto-immedately." + (lambda (running) want?))) + #:docstring "Queryable connection status wish state of a +Whispers VPN." + #:one-shot? #t))))))) + +(define want-connect-resolve-actions + (list (shepherd-action + (name 'display-want-connect?) + (documentation "For debugging purposes, display the connection +status wish of a VPN client.") + (procedure + #~(lambda (running) + (display (perform-service-action (lookup-service + 'want-connect-rw) + 'want-connect?))))) + (shepherd-action + (name 'want-connect?) + (documentation "Return the connection status wish of a +VPN client.The returned boolean value is used only at the end of client +registration, to determine if connection is to be performed +auto-immedately.") + (procedure + #~(lambda (running) + (if (lookup-service 'want-connect-state) + (perform-service-action (lookup-service + 'want-connect-state) + 'want-connect?) + #f)))))) + +(define voucher-resolve-actions + (list + (shepherd-action + (name 'field-value->voucher) + (documentation "Returns a voucher whose field symbol FIELD has the +string value VALUE, #f if no voucher is found.") + (procedure + #~(lambda (running field value) + ((lambda (lst) (if (null? lst) #f (car lst))) + (filter (lambda (voucher) + (and (not (null? + (filter (lambda (entry) + (and (equal? (car entry) + field) + (equal? (cadr entry) + value))) + voucher))))) + (perform-service-action (lookup-service 'network-rw) + 'network-state)))))) + (shepherd-action + (name 'voucher-field->value) + (documentation "Returns the string value of the field symbol FIELD +of the voucher list of pairs VOUCHER, or #f if the voucher has no such +field.") + (procedure + #~(lambda (running field voucher) + ((lambda (lst) + (if (null? lst) + #f + (cadr (car lst)))) (filter (lambda (entry) + (equal? (car entry) + field)) + voucher))))) + (shepherd-action + (name 'display-unknown-host?) + (documentation "For debugging purposes, display #f if the host named +by the string HOSTNAME has a booked vouched, #t otherwise.") + (procedure + #~(lambda (running hostname) + (display (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname))))) + (shepherd-action + (name 'unknown-host?) + (documentation "Returns #f if the host named by the string HOSTNAME +has a booked vouched, #t otherwise.") + (procedure + #~(lambda (running hostname) + (not (perform-service-action (lookup-service 'network-rw) + 'field-value->voucher + 'client-hostname + hostname))))) + (shepherd-action + (name 'display-hostname->tun-request?) + (documentation "For debugging purposes, display a predicate true if +the client named by the string HOSTNAME is a known connected client +according to the current network state.") + (procedure + #~(lambda (running hostname) + (display (car (perform-service-action (lookup-service 'network-rw) + 'hostname->tun-request? + hostname)))))) + (shepherd-action + (name 'hostname->tun-request?) + (documentation "Returns a predicate true if the client named by the +string HOSTNAME is a known connected client according to the current +network state.") + (procedure + #~(lambda (running hostname) + (unless (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + (display "known host voucher: ") + (display (perform-service-action (lookup-service 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)) + (display "\n") + (perform-service-action (lookup-service 'network-rw) + 'voucher-field->value + 'tun-request? + (perform-service-action + (lookup-service + 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)))))) + (shepherd-action + (name 'display-hostname->connected?) + (documentation "For debugging purposes, display a predicate true if +the client named by the string HOSTNAME is a known connected client +according to the current network state.") + (procedure + #~(lambda (running hostname) + (display (perform-service-action (lookup-service 'network-rw) + 'hostname->connected? + hostname))))) + (shepherd-action + (name 'hostname->connected?) + (documentation "Returns a predicate true if the client named by the +string HOSTNAME is a known connected client according to the current +network state.") + (procedure + #~(lambda (running hostname) + (unless (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + (display "known host voucher: ") + (display (perform-service-action (lookup-service 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)) + (display "\n") + (perform-service-action (lookup-service 'network-rw) + 'voucher-field->value + 'connected? + (perform-service-action + (lookup-service 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)))))) + (shepherd-action + (name 'display-hostname->ip) + (documentation "Display the client IP address of the host HOSTNAME if +it has booked a voucher, #f otherwise.") + (procedure + #~(lambda (running hostname) + (display (perform-service-action (lookup-service 'network-rw) + 'hostname->ip + hostname))))) + (shepherd-action + (name 'hostname->ip) + (documentation "Returns the client IP address of the host HOSTNAME if +it has booked a voucher, #f otherwise.") + (procedure + #~(lambda (running hostname) + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + #f + (perform-service-action (lookup-service 'network-rw) + 'voucher-field->value + 'client-ip + (perform-service-action + (lookup-service + 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)))))) + (shepherd-action + (name 'display-hostname->server-ip) + (documentation "Display the server IP address of the host HOSTNAME if +it has booked a voucher, #f otherwise.") + (procedure + #~(lambda (running hostname) + (display (perform-service-action (lookup-service 'network-rw) + 'hostname->server-ip + hostname))))) + (shepherd-action + (name 'hostname->server-ip) + (documentation "Returns the server IP address of the host HOSTNAME if +it has booked a voucher, #f otherwise.") + (procedure + #~(lambda (running hostname) + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + #f + (perform-service-action (lookup-service 'network-rw) + 'voucher-field->value + 'server-ip + (perform-service-action + (lookup-service + 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)))))) + (shepherd-action + (name 'hostname->port) + (documentation "Returns the port number of the reverse port +forwarding open to the ssh daemon of the host HOSTNAME if it has booked +a voucher, #f otherwise.") + (procedure + #~(lambda (running hostname) + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + #f + (perform-service-action (lookup-service 'network-rw) + 'voucher-field->value + 'reverse-port + (perform-service-action + (lookup-service + 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)))))) + (shepherd-action + (name 'hostname->tun) + (documentation "Returns the tun device number of the tunnel forward +opened by the ssh daemon of the host HOSTNAME if it has booked a +voucher, #f otherwise.") + (procedure + #~(lambda (running hostname) + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + #f + (perform-service-action (lookup-service 'network-rw) + 'voucher-field->value + 'tun-device-number + (perform-service-action + (lookup-service + 'network-rw) + 'field-value->voucher + 'client-hostname + hostname)))))))) + +(define (client->server-actions config) + "Returns a list of <shepherd-action> records defining actions that the +VPN clients use to execute commands as the unpriviledged whispers user +of the server, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (list + (shepherd-action + (name 'set-disconnected-knock) + (documentation "Set the 'connected? field of the local client's +voucher to #f in the server's network states and knock-knock the +server. The server then propagates to the whole network.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (unpriv-sock (string-append + base-socket-path + "/unpriviledged/unix-sockets/unpriviledged.sock"))) + #~(lambda (running) + (perform-service-action (lookup-service 'network-rw) + 'server-command-knock + (string-append #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "set-disconnected" + " " + "network-rw" + " " + (gethostname))))))) + (shepherd-action + (name 'set-connected-knock) + (documentation "Set the 'connected? field of the local client's +voucher to #t in the server's unpriviledged network state, set the +'tun-request? field of the local client's voucher to #f in the server's +unpriviledged network state, and knock-knock the server. The server then +propagates to the whole network.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (unpriv-sock (string-append + base-socket-path + "/unpriviledged/unix-sockets/unpriviledged.sock"))) + #~(lambda (running) + (perform-service-action (lookup-service 'network-rw) + 'server-command-knock + (string-append #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "set-connected" + " " + "network-rw" + " " + (gethostname) + " " + "&&" + " " + #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "unset-tun-request" + " " + "network-rw" + " " + (gethostname))))))) + (shepherd-action + (name 'set-tun-request-knock) + (documentation "Set the 'tun-request? field of the local client's +voucher to #t in the server's network states, then knock-knock the +server. The server then creates a TUN interface for the local client.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (unpriv-sock (string-append + base-socket-path + "/unpriviledged/unix-sockets/unpriviledged.sock"))) + #~(lambda (running) + (perform-service-action (lookup-service 'network-rw) + 'server-command-knock + (string-append #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "set-tun-request" + " " + "network-rw" + " " + (gethostname))))))) + (shepherd-action + (name 'server-command-knock) + (documentation "Execute the string COMMAND as a shell command as the +unpriviledges whispers user of the server, then knock-knock the server.") + (procedure + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (forward-port (whispers-vpn-configuration-forward-port config)) + (forward-port-str (number->string forward-port)) + (herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (knocker-socket (string-append + base-socket-path + "/knocker/unix-sockets/knocker.sock"))) + #~(lambda (running command) + (fork+exec-command (list #$(file-append ssh-package + "/bin/ssh") + "-o" + "StrictHostKeyChecking=no" + "-o" + "UserKnownHostsFile=/dev/null" + "-p" + #$forward-port-str + "whispers@localhost" + (string-append command + " " + "&&" + " " + #$herd-path + " " + "-s" + " " + #$knocker-socket + " " + "stop" + " " + "root"))))))) + (shepherd-action + (name 'book) + (documentation "Book a voucher for this client's hostname in the +server's unpriviledge network state, then knock-knock the server to +propagate to the whole network.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (unpriv-sock (string-append + base-socket-path + "/unpriviledged/unix-sockets/unpriviledged.sock"))) + #~(lambda (running) + (perform-service-action (lookup-service 'network-rw) + 'server-command-knock + (string-append #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "book-client" + " " + "network-rw" + " " + (gethostname))))))) + (shepherd-action + (name 'free) + (documentation "Free this client's hostname voucher in the server's +unpriviledge network state, then knock-knock the server to propagate to +the whole network.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (unpriv-sock (string-append + base-socket-path + "/unpriviledged/unix-sockets/unpriviledged.sock"))) + #~(lambda (running) + (perform-service-action (lookup-service 'network-rw) + 'server-command-knock + (string-append #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "free-client-booking" + " " + "network-rw" + " " + (gethostname))))))) + (shepherd-action + (name 'complete-handshake) + (documentation "Complete a handshake with the VPN server by +registering, unregistering or disconnecting this machine as a client.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (vpn-sock (string-append + base-socket-path + "/unix-sockets/vpn.sock"))) + #~(lambda (running) + (cond ((service-running? (lookup-service 'registering)) + (perform-service-action (lookup-service 'network-rw) + 'book)) + ((service-running? (lookup-service 'unregistering)) + (perform-service-action (lookup-service 'network-rw) + 'free)) + ((service-running? (lookup-service 'disconnecting)) + (fork+exec-command (list #$herd-path + "-s" + #$vpn-sock + "set-disconnected-knock" + "network-rw")))))))))) + +(define (server->client-actions config) + "Returns a list of <shepherd-action> records defining actions that the +VPN server uses to execute commands as the unpriviledged whispers user +of its clients, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (list + (shepherd-action + (name 'knock-knock-client) + (documentation "Duplicate the server network state in the +unpriviledged vpn/unpriviledged Whispers lieutenant the client defined +by the string CLIENT-SPEC, then knock-knock this client. CLIENT-SPEC is +parsed as follows: +- When CLIENT-SPEC is the string \"in-handshake\", the client is +whichever provisional client has grabbed the handshake port of the +server. Presumably this client has just booked a voucher in the server's +network state. +- When CLIENT-SPEC is a string of the form \"client/HOSTNAME\", the +client is the connected client whose hostname is HOSTNAME. +- Other CLIENT-SPEC strings have no effect") + (procedure + (let* ((ssh-package (whispers-vpn-configuration-ssh-package config)) + (constants (whispers-vpn-configuration-constants config)) + (handshake-port (network-constants-handshake-port constants)) + (handshake-port-str (number->string handshake-port)) + (herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (unpriv-sock (string-append + base-socket-path + "/unpriviledged/unix-sockets/unpriviledged.sock")) + (knocker-socket (string-append + base-socket-path + "/knocker/unix-sockets/knocker.sock"))) + #~(lambda (running client-spec) + (let ((client-reverse-port + (cond ((equal? client-spec "in-handshake") + #$handshake-port-str) + ((equal? (substring client-spec 0 7) + "client/") + (number->string (perform-service-action + (lookup-service + 'network-rw) + 'hostname->port + (substring client-spec + 7)))) + (#t "ssh-please-fail")))) + (let ((new-state (perform-service-action (lookup-service + 'network-rw) + 'print-network-state))) + (fork+exec-command + (list #$(file-append ssh-package + "/bin/ssh") + "-p" + client-reverse-port + "-o" + "StrictHostKeyChecking=no" + "-o" + "UserKnownHostsFile=/dev/null" + "whispers@localhost" + (string-append #$herd-path + " " + "-s" + " " + #$unpriv-sock + " " + "read-network-state" + " " + "network-rw" + " " + "'" + new-state + "'" + " " + "&&" + " " + #$herd-path + " " + "-s" + " " + #$knocker-socket + " " + "stop" + " " + "root"))))))))) + (shepherd-action + (name 'knock-knock-connected-clients) + (documentation "From the server, knock-knock all registered and +connected clients.") + (procedure + #~(lambda (running) + (map (lambda (voucher) + (when (and (perform-service-action (lookup-service + 'network-rw) + 'voucher-field->value + 'client-hostname + voucher) + (perform-service-action (lookup-service + 'network-rw) + 'hostname->connected? + (perform-service-action + (lookup-service + 'network-rw) + 'voucher-field->value + 'client-hostname + voucher))) + (let ((client-host (perform-service-action + (lookup-service + 'network-rw) + 'voucher-field->value + 'client-hostname + voucher))) + (display (string-append "Client " + client-host + " is connected, " + "knock-knock.\n")) + (perform-service-action (lookup-service 'network-rw) + 'knock-knock-client + (string-append "client/" + client-host))))) + (perform-service-action (lookup-service 'network-rw) + 'network-state))))) + (shepherd-action + (name 'knock-knock-clients) + (documentation "From the server, knock-knock the whole accessible +client network from. First knock-knock a prospective client performing a +handshake, then knock-knock all registered and connected clients.") + (procedure + #~(lambda (running) + (display "knock-knock into the handshake reverse forward.\n") + (perform-service-action (lookup-service 'network-rw) + 'knock-knock-client + "in-handshake") + (display "knock-knock all connected clients.\n") + (perform-service-action (lookup-service 'network-rw) + 'knock-knock-connected-clients)))))) + +(define voucher-actions + (list + (shepherd-action + (name 'book-lowest-voucher) + (documentation "Return a list of vouchers in which the string +HOSTNAME has been booked the lowest voucher-number available voucher in +the voucher list VOUCHERS. Using this action interactively can result in +the same client being booked twice.") + (procedure + #~(lambda (running hostname vouchers) + (if (not (null? ((lambda (voucher) + (filter (lambda (entry) + (and (equal? (car entry) + 'client-hostname) + (equal? (cadr entry) + #f))) + voucher)) (car vouchers)))) + (cons (map (lambda (entry) + (if (equal? (car entry) + 'client-hostname) + `(client-hostname ,hostname) + entry)) + (car vouchers)) + (cdr vouchers)) + (cons (car vouchers) + (perform-service-action (lookup-service 'network-rw) + 'book-lowest-voucher + hostname + (cdr vouchers))))))) + (shepherd-action + (name 'add-unbooked-client) + (documentation "Return VOUCHERS if the string HOSTNAME is already +booked in the list of vouchers VOUCHERS. Otherwise, return a list of +vouchers in which HOSTNAME has been booked the lowest voucher-number +available voucher in VOUCHERS.") + (procedure + #~(lambda (running hostname vouchers) + (display "Client: ") + (display hostname) + (display " is requesting a new voucher.\n") + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + (begin (display (string-append + "Booking a new voucher for client " + hostname + ".\n")) + (perform-service-action (lookup-service 'network-rw) + 'book-lowest-voucher + hostname + vouchers)) + (begin (display (string-append + "Client " + hostname + " already booked, not booking.\n")) + vouchers))))) + (shepherd-action + (name 'book-client) + (documentation "Book a new client by burning a new list of vouchers +into a new 'network-state service, where a new voucher has been booked +to HOSTNAME if HOSTNAME is not already booked.") + (procedure + #~(lambda (running hostname) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'add-unbooked-client + hostname + (perform-service-action + (lookup-service 'network-rw) + 'network-state)))))) + (shepherd-action + (name 'free-voucher) + (documentation "Return a list of vouchers in which the voucher +recording HOSTNAME as its 'client-hostname field has been replaced by a +free voucher.") + (procedure + #~(lambda (running hostname vouchers) + (if (not (null? ((lambda (voucher) + (filter (lambda (entry) + (and (equal? (car entry) + 'client-hostname) + (equal? (cadr entry) + hostname))) + voucher)) (car vouchers)))) + (cons (map (lambda (entry) + (if (equal? (car entry) + 'client-hostname) + '(client-hostname #f) + entry)) + (car vouchers)) + (cdr vouchers)) + (cons (car vouchers) + (perform-service-action (lookup-service 'network-rw) + 'free-voucher + hostname + (cdr vouchers))))))) + (shepherd-action + (name 'remove-booked-client) + (documentation "Return VOUCHERS if the string HOSTNAME is not booked +in the list of vouchers VOUCHERS. Otherwise, return a list of vouchers +in which the voucher recording HOSTNAME as its 'client-hostname field +has been replaced by a free voucher.") + (procedure + #~(lambda (running hostname vouchers) + (display "Client: ") + (display hostname) + (display " is requesting freeing his voucher.\n") + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + (begin (display (string-append + "Client " + hostname + " is not booked, not freeing.\n")) + vouchers) + (begin (display (string-append + "Freeing voucher of client " + hostname + ".\n")) + (perform-service-action (lookup-service 'network-rw) + 'free-voucher + hostname + vouchers)))))) + (shepherd-action + (name 'free-client-booking) + (documentation "Burn a new list of vouchers in which the voucher of +the client whose hostname is the string HOSTNAME has been replaced by a +unbooked voucher.") + (procedure + #~(lambda (running hostname) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'remove-booked-client + hostname + (perform-service-action + (lookup-service 'network-rw) + 'network-state)))))) + (shepherd-action + (name 'tun-request!) + (documentation "Return a list of vouchers equal to the list of +vouchers VOUCHERS in which the 'tun-request? field of the voucher of the +client whose hostname is the string HOSTNAME has been set to the boolean +value NEW-STATUS.") + (procedure + #~(lambda (running hostname new-status vouchers) + (if (not (null? ((lambda (voucher) + (filter (lambda (entry) + (and (equal? (car entry) + 'client-hostname) + (equal? (cadr entry) + hostname))) + voucher)) (car vouchers)))) + (cons (map (lambda (entry) + (if (equal? (car entry) + 'tun-request?) + `(tun-request? ,new-status) + entry)) + (car vouchers)) + (cdr vouchers)) + (cons (car vouchers) + (perform-service-action (lookup-service 'network-rw) + 'tun-request! + hostname + new-status + (cdr vouchers))))))) + (shepherd-action + (name 'tun-request!-maybe) + (documentation "Return VOUCHERS if the string HOSTNAME is not booked +in the list of vouchers VOUCHERS. Otherwise, return a list of vouchers +in which the 'tun-request? field of the voucher recording HOSTNAME as its +'client-hostname field has been set to the boolean value NEW-STATUS.") + (procedure + #~(lambda (running hostname new-status vouchers) + (display "Client: ") + (display hostname) + (display " is requesting a change of requestor status.\n") + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + (begin (display (string-append + "Client " + hostname + " is not booked, not proceeding.\n")) + vouchers) + (begin (display (string-append + "Setting requestor status of client " + hostname + " to " + (if new-status "true" "false") + ".\n")) + (perform-service-action (lookup-service 'network-rw) + 'tun-request! + hostname + new-status + vouchers)))))) + (shepherd-action + (name 'set-tun-request) + (documentation "Burn a new list of vouchers in which the +'tun-request? field of the voucher of the client whose hostname is the +string HOSTNAME has been set to #t.") + (procedure + #~(lambda (running hostname) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'tun-request!-maybe + hostname + #t + (perform-service-action + (lookup-service 'network-rw) + 'network-state)))))) + (shepherd-action + (name 'unset-tun-request) + (documentation "Burn a new list of vouchers in which the +'tun-request? field of the voucher of the client whose hostname is the +string HOSTNAME has been set to #f.") + (procedure + #~(lambda (running hostname) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'tun-request!-maybe + hostname + #f + (perform-service-action + (lookup-service 'network-rw) + 'network-state)))))) + (shepherd-action + (name 'connected!) + (documentation "Return a list of vouchers equal to the list of +vouchers VOUCHERS in which the 'connected? field of the voucher of the +client whose hostname is the string HOSTNAME has been set to the boolean +value NEW-STATUS.") + (procedure + #~(lambda (running hostname new-status vouchers) + (if (not (null? ((lambda (voucher) + (filter (lambda (entry) + (and (equal? (car entry) + 'client-hostname) + (equal? (cadr entry) + hostname))) + voucher)) (car vouchers)))) + (cons (map (lambda (entry) + (if (equal? (car entry) + 'connected?) + `(connected? ,new-status) + entry)) + (car vouchers)) + (cdr vouchers)) + (cons (car vouchers) + (perform-service-action (lookup-service 'network-rw) + 'connected! + hostname + new-status + (cdr vouchers))))))) + (shepherd-action + (name 'connected!-maybe) + (documentation "Return VOUCHERS if the string HOSTNAME is not booked +in the list of vouchers VOUCHERS. Otherwise, return a list of vouchers +in which the 'connected? field of the voucher recording HOSTNAME as its +'client-hostname field has been set to the boolean value NEW-STATUS.") + (procedure + #~(lambda (running hostname new-status vouchers) + (display "Client: ") + (display hostname) + (display " is requesting a change of connection status.\n") + (if (perform-service-action (lookup-service 'network-rw) + 'unknown-host? + hostname) + (begin (display (string-append + "Client " + hostname + " is not booked, not proceeding.\n")) + vouchers) + (begin (display (string-append + "Setting connection status of client " + hostname + " to " + (if new-status "true" "false") + ".\n")) + (perform-service-action (lookup-service 'network-rw) + 'connected! + hostname + new-status + vouchers)))))) + (shepherd-action + (name 'set-connected) + (documentation "Burn a new list of vouchers in which the 'conencted? +field of the voucher of the client whose hostname is the string HOSTNAME +has been set to #t.") + (procedure + #~(lambda (running hostname) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'connected!-maybe + hostname + #t + (perform-service-action + (lookup-service + 'network-rw) + 'network-state)))))) + (shepherd-action + (name 'set-disconnected) + (documentation "Burn a new list of vouchers in which the 'connected +field of the voucher of the client whose hostname is the string HOSTNAME +has been set to #f.") + (procedure + #~(lambda (running hostname) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'connected!-maybe + hostname + #f + (perform-service-action + (lookup-service 'network-rw) + 'network-state)))))))) + +(define (knocker-actions config) + "Returns a list of <shepherd-actions> objects for the 'knocker +lieutenant of the 'vpn whispers lieutenant, configurable by CONFIG, a +record of the <whispers-vpn-configuration> type." + (list (shepherd-action + (name 'pre-start) + (documentation "Perform the 'knock-knock action of the 'knocker +service.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'knocker) + 'knock-knock)))) + (shepherd-action + (name 'knock-knock) + (documentation "Burn the network state recorded in lieutenant +service into the 'network-state service at this level of the whispers +tree. Then: +- VPN clients perform the following in order: + - Stop the 'handshake-port-forward persistent ssh connection. + - Check if the client's own hostname has a connected status in the +local network state and perform the following: + - If yes, start the 'connected lieutenant of the 'vpn service +and stop the 'disconnected lieutenant of the 'vpn service. + - if no, start the 'disconnected lieutenant of the 'vpn service +and stop the 'connected lieutenant of the 'vpn service. + - Check if the client's own hostname is a known host in the +local network state and perform the following: + - If yes, start the 'registered lieutenant of the 'vpn service, +stop the 'unregistered lieutenant of the 'vpn service and chain connect +auto-immediately if appropriate per the boolean value recorded in the +'want-connect-state lieutenant. + - if no, start the 'unregistered lieutenant of the 'vpn service +and stop the 'registered lieutenant of the 'vpn service. + - If the local client has no voucher associated to its host name or +if it has a voucher whose 'tun-request? field is value is #f, stop the +'connecting lieutenant of the 'vpn service and stop the 'disconnecting +lieutenant of the 'vpn service. + - If the local client's voucher's 'tun-request? field evaluates to a +true value, start the persistent ssh connection supporting the tunnel +forward of the local client. + - Stop the 'registering and 'unregistering lieutenants +of the 'vpn service. +- The VPN server performs either of the following: + - If the network state contains one or more vouchers whose +'tun-request? field evaluates to a true value, perform either one of the +following for each of the clients whose hostname is resolved by the +aforementioned vouchers: + - If the 'connected? field of the voucher evaluates to a true +value, perform the following in order: + - Destroy the server-side TUN interface of this voucher by +stopping the corresponding lieutenant of the 'vpn service. + - Knock-knock the client of this voucher. + - Set the 'tun-request? field of this voucher to #f in the +network state. + - If the 'connected? field of the voucher evaluates to #f value, +perform the following in order: + - Create the server-side TUN interface of this voucher by +starting the corresponding lieutenant of the 'vpn service. + - Knock-knock the client of this voucher. + - Set the 'tun-request? field of this voucher to #f in the +network state. + - Otherwise, knock-knock all clients, including a prospective +client through the handshake reverse forward.") + (procedure + (let* ((client? (whispers-vpn-configuration-client? config)) + (herd-path "/run/current-system/profile/bin/herd") + (handshake-conf (handshake-forward-configuration config)) + (handshake-name (persistent-ssh-name handshake-conf))) + #~(lambda (running) + (display "Who's there?\n") + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (perform-service-action + (lookup-service 'network-rw) + 'lieutenant-network-state)) + (let* ((state (perform-service-action (lookup-service + 'network-rw) + 'network-state)) + (req-field? (lambda (field) + (equal? (car field) + 'tun-request?))) + (requester? (lambda (voucher) + (cadar (filter req-field? + voucher)))) + (requesters (filter requester? + state)) + (con-field? (lambda (field) + (equal? (car field) + 'connected?))) + (con? (lambda (voucher) + (cadar (filter con-field? + voucher)))) + (host-field? (lambda (field) + (equal? (car field) + 'client-hostname))) + (host (lambda (voucher) + (cadar (filter host-field? + voucher)))) + (tun-num-f? (lambda (field) + (equal? (car field) + 'tun-device-number))) + (tun-num (lambda (voucher) + (cadar (filter tun-num-f? + voucher)))) + (tun-str (lambda (voucher) + (string-append + "tun" + (number->string (tun-num + voucher))))) + (tun-sym (lambda (voucher) + (string->symbol (tun-str + voucher)))) + (tun-act (lambda (voucher) + (if (con? voucher) + 'stop-tun + 'start-tun)))) + (if (not #$client?) + (if (null? requesters) + (perform-service-action (lookup-service + 'network-rw) + 'knock-knock-clients) + (begin (map (lambda (voucher) + (perform-service-action + (lookup-service (tun-sym voucher)) + (tun-act voucher))) + requesters) + (map (lambda (voucher) + (perform-service-action + (lookup-service 'network-rw) + 'knock-knock-client + (string-append "client/" + (host + voucher)))) + requesters) + (map (lambda (voucher) + (perform-service-action + (lookup-service 'network-rw) + 'unset-tun-request + (host voucher))) + requesters))) + (begin (stop-service (lookup-service + '#$handshake-name)) + (if (perform-service-action + (lookup-service 'network-rw) + 'hostname->connected? + (gethostname)) + (begin (start-service (lookup-service + 'connected)) + (stop-service (lookup-service + 'disconnected))) + (begin (start-service (lookup-service + 'disconnected)) + (stop-service (lookup-service + 'connected)))) + (if (perform-service-action (lookup-service + 'network-rw) + 'unknown-host? + (gethostname)) + (begin (start-service (lookup-service + 'unregistered)) + (stop-service (lookup-service + 'registered))) + (begin (start-service (lookup-service + 'registered)) + (stop-service (lookup-service + 'unregistered)) + (perform-service-action + (lookup-service 'registering) + 'maybe-chain-conn))) + (when (or (perform-service-action + (lookup-service 'network-rw) + 'unknown-host? + (gethostname)) + (not (perform-service-action + (lookup-service 'network-rw) + 'hostname->tun-request? + (gethostname)))) + (stop-service (lookup-service 'connecting)) + (stop-service (lookup-service + 'disconnecting))) + (when (and (not (perform-service-action + (lookup-service 'network-rw) + 'unknown-host? + (gethostname))) + (perform-service-action + (lookup-service + 'network-rw) + 'hostname->tun-request? + (gethostname))) + (perform-service-action (lookup-service + 'connecting) + 'tun-start-ssh)) + (stop-service (lookup-service 'registering)) + (stop-service (lookup-service + 'unregistering))))))))))) + +(define network-state-rw-actions + (list (shepherd-action + (name 'burn-state) + (documentation "unload the existing instance of the +'network-state service. Write a network state NEW-STATE as the content +of a new instance of the 'network-state service, from there on queryable +through its 'vouchers action.") + (procedure + #~(lambda (running . new-state) + (perform-service-action (lookup-service 'root) + 'unload + "network-state") + (display "Burning new 'network-state service.\n") + (register-services + (make <service> + #:provides '(network-state) + #:start (lambda whatever #f) + #:stop (lambda whatever #t) + #:actions (make-actions + (vouchers + "Return the network state stored in the +service." + (lambda (running) (car new-state)))) + #:docstring "Queryable network state of a Whispers VPN." + #:one-shot? #t))))) + (shepherd-action + (name 'network-state) + (documentation "Return the list of vouchers returned by the +'vouchers action of the 'network-state service in scope at the current +level of the whispers tree.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'network-state) + 'vouchers)))) + (shepherd-action + (name 'read-network-state) + (documentation "Burn the string NEW-STATE as it is read by the +read syntax as the new network state of the 'network-state service.") + (procedure + #~(lambda (running . new-state) + (perform-service-action (lookup-service 'network-rw) + 'burn-state + (with-input-from-string (car new-state) + read))))) + (shepherd-action + (name 'print-network-state) + (documentation "Return the network state as a string which can +be read by the 'read-network-state action of another shepherd's +'network-rw Whispers lieutenant service's read-network-state action.") + (procedure + #~(lambda (running) + (with-output-to-string (lambda () + (write (perform-service-action + (lookup-service 'network-rw) + 'network-state))))))) + (shepherd-action + (name 'display-network-state) + (documentation "For debugging puposes, display to standard +output the list of vouchers returned by the 'vouchers action of the +'network-state service in scope at current level of the whispers tree.") + (procedure + #~(lambda (running) + (map (lambda (voucher) + (display voucher) + (display "\n")) + (perform-service-action (lookup-service 'network-rw) + 'network-state))))) + (shepherd-action + (name 'lieutenant-network-state) + (documentation "Return the list of vouchers returned by the +'vouchers action of the 'network-state service in scope in scope of the +'unpriviledged lieutenant whispers shepherd.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'unpriviledged) + 'lieutenant-action + "network-state" + "network-rw")))) + (shepherd-action + (name 'display-lieutenant-network-state) + (documentation "For debugging puposes, display to standard +output the list of vouchers returned by the 'vouchers action of the +'network-state service in scope of the 'unpriviledged lieutenant +whispers shepherd.") + (procedure + #~(lambda (running) + (map (lambda (voucher) + (display voucher) + (display "\n")) + (perform-service-action + (display-network-state 'network-rw) + 'lieutenant-network-state))))))) + +(define (want-connect-rw-shepherd-services whatever) + "Returns a list of one <shepherd-service> object providing actions to +read and write the connection status wish of a client under registration. +from a 'want-connect-state service in its scope, not configurable by +WHATEVER." + (list (shepherd-service + (documentation "connection status wish state read and write +operations.") + (provision '(want-connect-rw)) + (requirement '()) + (start #~(lambda whatever #f)) + (actions (append want-connect-state-write-actions + want-connect-resolve-actions)) + (stop #~(lambda whatever #t)) + (one-shot? #t) + (auto-start? #f)))) + +(define want-connect-rw-service-type + (service-type + (name 'want-connect-rw) + (description "Shepherd service used for read and write operations of +the want-connect state of a Whispers VPN.") + (extensions + (list (service-extension shepherd-root-service-type + want-connect-rw-shepherd-services))) + (default-value (whispers-vpn-configuration)))) + +(define (want-connect-state-shepherd-services whatever) + "Returns a list of one <shepherd-service> object doing nothing of +interest in the state in which it is instanciated at guix's system +reconfigure time, not configurable by WHATEVER. While a VPN client will +be registering at the OS run-time, the final connection status wished by +the client (connected or registered only) will be stored in and +retrievable from the service." + (list (shepherd-service + (documentation "Queryable connection status wish state of a +Whispers VPN.") + (provision '(want-connect-state)) + (requirement '()) + (start #~(lambda whatever #f)) + (actions + (list (shepherd-action + (name 'want-connect?) + (documentation "Does not return anything of interest at +this time, nor have any side effects.") + (procedure #~(lambda (running) #f))))) + (stop #~(lambda whatever #t)) + (one-shot? #t) + (auto-start? #f)))) + +(define want-connect-state-service-type + (service-type + (name 'want-connect-state) + (description "Shepherd service used for storage and retrieval of the +current status wish of a VPN client under registration: connected or +registered only.") + (extensions + (list (service-extension shepherd-root-service-type + want-connect-state-shepherd-services))) + (default-value 'whatever))) + +(define (network-rw-shepherd-services config) + "Returns a list of one <shepherd-service> object providing actions to +read and write the network state stored in the 'network-state service in +its scope,configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (let ((client? (whispers-vpn-configuration-client? config))) + (list (shepherd-service + (documentation "Network state read and write operations.") + (provision '(network-rw)) + (requirement '()) + (start #~(lambda whatever #f)) + (actions (append network-state-rw-actions + voucher-resolve-actions + (if client? + (client->server-actions config) + (append voucher-actions + (server->client-actions config))))) + (stop #~(lambda whatever #t)) + (one-shot? #t) + (auto-start? #f))))) + +(define network-rw-service-type + (service-type + (name 'network-rw) + (description "Shepherd service used for read and write operations of +the network state of a Whispers VPN.") + (extensions + (list (service-extension shepherd-root-service-type + network-rw-shepherd-services))) + (default-value (whispers-vpn-configuration)))) + +(define (network-state-shepherd-services network-state) + "Returns a list of one <shepherd-service> object storing the list of +vouchers NETWORK-STATE in the return value of its 'vouchers shepherd +action." + (list (shepherd-service + (documentation "Queryable network state of a Whispers VPN.") + (provision '(network-state)) + (requirement '()) + (start #~(lambda whatever #f)) + (actions + (list (shepherd-action + (name 'vouchers) + (documentation "Return the network state stored in the +service.") + (procedure #~(lambda (running) '#$network-state))))) + (stop #~(lambda whatever #t)) + (one-shot? #t) + (auto-start? #f)))) + +(define network-state-service-type + (service-type + (name 'network-state) + (description "Shepherd service used for storage and retrieval of the +network state of a Whispers VPN.") + (extensions + (list (service-extension shepherd-root-service-type + network-state-shepherd-services))) + (default-value (network-constants)))) + +(define (state-services config) + "Returns a list of 2 shepherd root Guix services which do not +daemonize any process, a service to perform read and write action on a +network state, and a service to store a mutbable network state, +configurable by CONFIG, a record of the <whispers-vpn-configuration> +type." + (list (service network-state-service-type + (empty-network (whispers-vpn-configuration-constants + config))) + (service network-rw-service-type config))) + +(define (vpn-lieutenants config) + "Returns the list of the lieutenants of the 'vpn service sitting at +the top of the whispers sub-tree of a Whispers VPN, configurable by +CONFIG, a record of the <whispers-vpn-configuration> type." + (let* ((client? (whispers-vpn-configuration-client? config)) + (auto-register? (whispers-vpn-configuration-auto-register? config))) + (append + (if client? + (let* ((forward-conf (forward-configuration config)) + (forward-name (persistent-ssh-name forward-conf))) + (append + (map (lambda (service-config) + (service persistent-ssh-service-type service-config)) + (reverse-forward-configurations config)) + (map (lambda (service-config) + (service persistent-ssh-service-type service-config)) + (tun-device-forward-configurations config)) + (list (service persistent-ssh-service-type + (forward-configuration config)) + (service persistent-ssh-service-type + (handshake-forward-configuration config)) + (service whispers-service-type + (whispers-configuration + (name 'registering) + (requires (list forward-name)) + (pre-start-action? #t) + (extra-actions (registering-actions config)) + (%auto-start? auto-register?))) + (service whispers-service-type + (whispers-configuration + (name 'unregistering) + (requires (list forward-name)) + (pre-start-action? #t) + (extra-actions (unregistering-actions config)) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'registered) + (requires (list forward-name)) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'unregistered) + (requires (list forward-name)) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'connecting) + (requires (list forward-name + 'registered)) + (pre-start-action? #t) + (extra-actions + (connecting-actions config)) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'disconnecting) + (requires (list forward-name)) + (pre-start-action? #t) + (extra-actions + (disconnecting-actions config)) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'connected) + (requires (list forward-name + 'registered)) + (extra-actions connected-actions) + (%auto-start? #f))) + (service whispers-service-type + (whispers-configuration + (name 'disconnected) + (requires (list forward-name)) + (%auto-start? #f))) + (service want-connect-rw-service-type + 'whatever) + (service want-connect-state-service-type + 'whatever)))) + (list)) + (state-services config) + (list (service whispers-service-type + (whispers-configuration + (name 'unpriviledged) + (lieutenants (state-services config)) + (user "whispers") + (extend-user? #t) + (group "whispers") + (extend-group? #t))) + (service whispers-service-type + (whispers-configuration + (name 'knocker) + (requires '(unpriviledged)) + (pre-start-action? #t) + (user "whispers") + (group "whispers") + (extra-actions (knocker-actions config))))) + (tcp-ip-lieutenants config)))) + +(define (vpn-actions config) + "Return the list of actions of the 'vpn service, configurable by +CONFIG, a record of the <whispers-vpn-configuration> type." + (append + (list (shepherd-action + (name 'pre-start) + (documentation "Create the directories and tmpfs mounts used +by the persistent ssh connections of the 'vpn service.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'vpn) + 'make-directory + "/var/log/whispers/vpn/ssh-tunneler" + "root" + "root" + #$(number->string #o755 8)) + (perform-service-action (lookup-service 'vpn) + 'make-tmpfs + "/run/whispers/vpn/ssh-tunneler" + "root" + "root" + #$(number->string #o755 8))))) + (shepherd-action + (name 'post-stop) + (documentation "Unmount the tmpfs mounts used by the +persistent ssh connections of the VPN service.") + (procedure + #~(lambda (running) + (perform-service-action (lookup-service 'vpn) + 'clear-tmpfs + "/run/whispers/vpn/ssh-tunneler")))) + (shepherd-action + (name 'register) + (documentation "Register this host in the VPN network.") + (procedure + #~(lambda (running) + (display (string-append "Client " + (gethostname) + " initiating register " + "sequence.\n")) + (if (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "running?" + "connected") + (begin (display "'connected lieutenant is ") + (display "started, register ") + (display "sequence canceled.\n")) + (begin (display "'connected lieutenant is ") + (display "not started, register ") + (display "sequence confirmed.\n") + (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "start-registering" + "registering")))))) + (shepherd-action + (name 'unregister) + (documentation "Unregister this host from the VPN network.") + (procedure + #~(lambda (running) + (display (string-append "Client " + (gethostname) + " initiating unregister " + "sequence.\n")) + (if (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "running?" + "connected") + (begin (display "'connected lieutenant is ") + (display "started, unregister ") + (display "sequence canceled.\n")) + (begin (display "'connected lieutenant is ") + (display "not started, unregister ") + (display "sequence confirmed.\n") + (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "start-unregistering" + "unregistering")))))) + (shepherd-action + (name 'connect) + (documentation "Connect this host in the VPN network.") + (procedure + #~(lambda (running) + (if (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "unknown-host?" + "network-rw" + (gethostname)) + (begin (display (string-append "Client " + (gethostname) + " is not registered.\n" + "Initiating " + "regiseter-connect " + "sequence.\n")) + (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "want-connect-on" + "want-connect-rw") + (perform-service-action (lookup-service 'vpn) + 'register)) + (begin (display (string-append "Client " + (gethostname) + " is already registered.\n" + "Initiating connect " + "sequence.\n")) + (if (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "running?" + "connected") + (begin (display "'connected lieutenant is ") + (display "started, connect ") + (display "sequence canceled.\n")) + (begin (display "'connected lieutenant is ") + (display "not started, connect ") + (display "sequence confirmed.\n") + (perform-service-action + (lookup-service 'vpn) + 'lieutenant-action + "start-connecting" + "connecting")))))))) + (shepherd-action + (name 'disconnect) + (documentation "Disconnect this host from the VPN network.") + (procedure + #~(lambda (running) + (display (string-append "Client " + (gethostname) + " initiating disconnect " + "sequence.\n")) + (if (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "running?" + "connected") + (begin (display "'connected lieutenant is ") + (display "started, disconnect ") + (display "sequence confirmed.\n") + (perform-service-action (lookup-service 'vpn) + 'lieutenant-action + "start-disconnecting" + "disconnecting")) + (begin (display "'connected lieutenant is ") + (display "not started, disconnect ") + (display "sequence canceled.\n"))))))) + (tcp-ip-actions config))) + +(define (registering-actions config) + "Returns the list of actions of the 'registering lieutenant of the +'vpn service, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (list (shepherd-action + (name 'pre-start) + (documentation "Connect the handshake reverse port forward to +the server, book a voucer in the server network state, knock-knock the +server to propagate to the whole network, then terminate the handshake +reverse port forward.") + (procedure + (let* ((handshake-conf (handshake-forward-configuration config)) + (handshake-name (persistent-ssh-name handshake-conf))) + #~(lambda (running) + (start-in-the-background (list '#$handshake-name)))))) + (shepherd-action + (name 'start-registering) + (documentation "Start the 'registering service") + (procedure + #~(lambda (running) + (start-service (lookup-service 'registering))))) + (shepherd-action + (name 'maybe-chain-conn) + (documentation "If the want-connect connection status wish is +#t, reset it to #f and start connecting auto-immediately.") + (procedure + (let* ((herd-path "/run/current-system/profile/bin/herd") + (whisp-sock "/run/whispers/unix-sockets/whispers.sock")) + #~(lambda (running) + (if (or (not (lookup-service 'want-connect-rw)) + (not (perform-service-action + (lookup-service 'want-connect-rw) + 'want-connect?)) + (perform-service-action (lookup-service 'network-rw) + 'hostname->tun-request? + (gethostname))) + (display (string-append "Client " + (gethostname) + " not chain-connecting.\n")) + (begin (display (string-append "Client " + (gethostname) + " chain-connecting.\n")) + (perform-service-action (lookup-service + 'want-connect-rw) + 'want-connect-off) + ;; FIXME: action up the whispers tree, deadlock? + (fork+exec-command (list #$herd-path + "-s" + #$whisp-sock + "connect" + "vpn")))))))))) + +(define (unregistering-actions config) + "Returns the list of actions of the 'unregistering lieutenant of the +'vpn service, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (list (shepherd-action + (name 'pre-start) + (documentation "Connect the handshake reverse port forward to +the server, book a voucer in the server network state, knock-knock the +server to propagate to the whole network, then terminate the handshake +reverse port forward.") + (procedure + (let* ((handshake-conf (handshake-forward-configuration config)) + (handshake-name (persistent-ssh-name handshake-conf))) + + #~(lambda (running) + (start-in-the-background (list '#$handshake-name)))))) + (shepherd-action + (name 'start-unregistering) + (documentation "Start the 'unregistering service") + (procedure + #~(lambda (running) + (start-service (lookup-service 'unregistering))))))) + +(define connected-actions + (list (shepherd-action + (name 'running?) + (documentation "Return #t if the 'connected service is running, +return #f it is stopped.") + (procedure + #~(lambda (running) + (service-running? (lookup-service 'connected))))))) + +(define (connecting-actions config) + "Return the list of actions of the 'connecting lieutenant of the 'vpn +service, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (let* ((herd-path "/run/current-system/profile/bin/herd") + (base-socket-path "/run/whispers/vpn") + (vpn-sock (string-append base-socket-path + "/unix-sockets/vpn.sock")) + (exit-port (whispers-vpn-configuration-client-sshd-port config)) + (exit-str (number->string exit-port)) + (client-tun (whispers-vpn-configuration-client-tun-device config)) + (client-tun-str (number->string client-tun)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (rev-stealth-conf (reverse-stealth-conf config)) + (rev-stealth-forward (car (ssh-connection-configuration-forwards + rev-stealth-conf))) + (rev-stealth-port (ssh-forward-configuration-entry-port + rev-stealth-forward)) + (rev-stealth-port-str (number->string rev-stealth-port)) + (rev-stealth-stance (if stealth? + ;; FIXME: not future-proof + (string-append "_proxy-port_" + rev-stealth-port-str) + "")) + (tun-stealth-conf (tun-stealth-conf config)) + (tun-stealth-forward (car (ssh-connection-configuration-forwards + tun-stealth-conf))) + (tun-stealth-port (ssh-forward-configuration-entry-port + tun-stealth-forward)) + (tun-stealth-port-str (number->string tun-stealth-port)) + (tun-stealth-stance (if stealth? + ;; FIXME: not future-proof + (string-append "_proxy-port_" + tun-stealth-port-str) + ""))) + (list (shepherd-action + (name 'pre-start) + (documentation "Connect the handshake reverse port forward to +the server, book a voucer in the server network state, knock-knock the +server to propagate to the whole network, then terminate the handshake +reverse port forward.") + (procedure + #~(lambda (running) + (let* ((server-port (perform-service-action + (lookup-service 'network-rw) + 'hostname->port + (gethostname))) + (server-port-str (number->string server-port)) + ;; FIXME: not future-proof + (stance (string-append server-port-str + ":" + "127.0.0.1" + ":" + #$exit-str)) + ;; FIXME: not future-proof + (name-str (string-append "ssh-forwards_reverse-port@" + stance + #$rev-stealth-stance)) + (name-sym (string->symbol name-str))) + (display "Starting reverse port forwarding.\n") + (start-in-the-background (list name-sym)))))) + (shepherd-action + (name 'tun-start-dev) + (documentation "Knock-knock the server to create the TUN +network device on the server side.") + (procedure + #~(lambda (running) + (let* ((server-tun (perform-service-action + (lookup-service 'network-rw) + 'hostname->tun + (gethostname))) + (tun-str (number->string server-tun))) + (fork+exec-command (list #$herd-path + "-s" + #$vpn-sock + "set-tun-request-knock" + "network-rw")))))) + (shepherd-action + (name 'tun-start-ssh) + (documentation "Start the ssh persistent connection +supporting the VPN tun device on client and server sides.") + (procedure + #~(lambda (running) + (let* ((server-tun (perform-service-action + (lookup-service 'network-rw) + 'hostname->tun + (gethostname))) + (server-tun-str (number->string server-tun)) + (tun-str (number->string server-tun)) + (stance (string-append #$client-tun-str + ":" + server-tun-str)) + ;; FIXME: not future-proof + (name-str (string-append "ssh-forwards_tunnel@" + stance + #$tun-stealth-stance)) + (name-sym (string->symbol name-str))) + (display (string-append "Starting " + name-str + " in the background.\n")) + (start-in-the-background (list name-sym)))))) + (shepherd-action + (name 'start-connecting) + (documentation "Start the 'connecting service") + (procedure + #~(lambda (running) + (start-service (lookup-service 'connecting)))))))) + +(define (disconnecting-actions config) + "Return the list of actions of the 'disconnecting lieutenant of the +'vpn service, configurable by CONFIG, a record of the +<whispers-vpn-configuration> type." + (let* ((client-tun (whispers-vpn-configuration-client-tun-device config)) + (client-tun-str (number->string client-tun)) + (exit-port (whispers-vpn-configuration-client-sshd-port config)) + (exit-str (number->string exit-port)) + (handshake-conf (handshake-forward-configuration config)) + (handshake-name (persistent-ssh-name handshake-conf)) + (stealth? (whispers-vpn-configuration-stealth? config)) + (rev-stealth-conf (reverse-stealth-conf config)) + (rev-stealth-forward (car (ssh-connection-configuration-forwards + rev-stealth-conf))) + (rev-stealth-port (ssh-forward-configuration-entry-port + rev-stealth-forward)) + (rev-stealth-port-str (number->string rev-stealth-port)) + (rev-stealth-stance (if stealth? + ;; FIXME: not future-proof + (string-append "_proxy-port_" + rev-stealth-port-str) + "")) + (tun-stealth-conf (tun-stealth-conf config)) + (tun-stealth-forward (car (ssh-connection-configuration-forwards + tun-stealth-conf))) + (tun-stealth-port (ssh-forward-configuration-entry-port + tun-stealth-forward)) + (tun-stealth-port-str (number->string tun-stealth-port)) + (tun-stealth-stance (if stealth? + ;; FIXME: not future-proof + (string-append "_proxy-port_" + tun-stealth-port-str) + ""))) + (list (shepherd-action + (name 'pre-start) + (documentation "Stop the 'device-device-forward lieutenant of +the 'vpn service, then set the 'connected? flag of this client's voucher +to #f in the server's unpriviledged network state and knock-knock the +server. The disconnection sequence will complete for this client after +receiving the server's knock-knock.") + (procedure + #~(lambda (running) + (let* ((server-tun (perform-service-action + (lookup-service 'network-rw) + 'hostname->tun + (gethostname))) + (tun-str (number->string server-tun)) + (stance (string-append #$client-tun-str + ":" + tun-str)) + ;; FIXME: not future-proof + (name-str (string-append "ssh-forwards_tunnel@" + stance + #$tun-stealth-stance)) + (name-sym (string->symbol name-str))) + (stop-service (lookup-service name-sym))) + + (start-in-the-background (list '#$handshake-name)) + (let* ((server-port (perform-service-action (lookup-service + 'network-rw) + 'hostname->port + (gethostname))) + (server-port-str (number->string server-port)) + ;; FIXME: not future-proof + (stance (string-append server-port-str + ":" + "127.0.0.1" + ":" + #$exit-str)) + ;; FIXME: not future-proof + (name-str (string-append "ssh-forwards_reverse-port@" + stance + #$rev-stealth-stance)) + (name-sym (string->symbol name-str))) + (stop-service (lookup-service name-sym))) + (perform-service-action (lookup-service '#$(tun-dev-sym + client-tun)) + 'stop-tun)))) + (shepherd-action + (name 'start-disconnecting) + (documentation "Start the 'disconnecting service") + (procedure + #~(lambda (running) + (start-service (lookup-service 'disconnecting)))))))) + +(define (whispers-vpn-tree config) + "Returns a whispers service tree for a whispers VPN sub-tree, +configurable by CONFIG, a record of the <whispers-vpn-configuration> +type." + (let ((client? (whispers-vpn-configuration-client? config))) + (list (service whispers-service-type + (whispers-configuration + (name 'vpn) + (lieutenants (vpn-lieutenants config)) + (pre-start-action? client?) + (post-stop-action? client?) + (extra-actions (vpn-actions config))))))) + +(define whispers-vpn-service-type + (service-type + (name '(whispers-vpn)) + (description "ssh-tttt!!!") + (extensions (list (service-extension whispers-service-type + whispers-vpn-tree))) + (default-value (whispers-vpn-configuration)))) diff --git a/whispers/services/whispers/xdg.scm b/whispers/services/whispers/xdg.scm new file mode 100644 index 0000000..acb0b92 --- /dev/null +++ b/whispers/services/whispers/xdg.scm @@ -0,0 +1,81 @@ +;;; 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 xdg) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (whispers services whispers) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) + #:export (whispers-xdg-service-type + whispers-xdg-configuration + whispers-xdg-configuration? + xdg-user-group + xdg-user-group?)) + +(define-record-type* <whispers-xdg-configuration> + whispers-xdg-configuration make-bitcoin-configuration + whispers-xdg-configuration? + this-whispers-xdg-configuration + ;; A list of xdg-user-group records + (users-groups whispers-xdg-configuration-users-groups + (default '()))) + +(define-record-type* <xdg-user-group> + xdg-user-group make-xdg-user-group + xdg-user-group? + this-xdg-user-group + ;; A whispers-user-group record + (user-and-group xdg-user-group-user-and-group + (default (whispers-user-group)))) + +(define (runtimes-lieutenant user group) + "Returns an elementary whispers service tree for a single user's +section of whispers xdg sub-tree, run by the user named by the string +USER and the group named by the string GROUP." + (service whispers-service-type + (whispers-configuration (name (string->symbol + (user-container-name user))) + (user user) + (group group)))) + +(define (whispers-xdg-tree config) + "Returns a whispers service tree for an xdg whispers sub-tree, +configurable by CONFIG, a record of the <whispers-xdg-configuration> type." + (let* ((ugs (whispers-xdg-configuration-users-groups config)) + (user-group xdg-user-group-user-and-group) + (user (lambda (ug) (whispers-user-group-user (user-group ug)))) + (group (lambda (ug) (whispers-user-group-group (user-group ug))))) + (list (service whispers-service-type + (whispers-configuration + (name 'xdg) + (lieutenants (map (lambda (ug) + (runtimes-lieutenant (user ug) + (group ug))) + ugs))))))) + +(define whispers-xdg-service-type + (service-type + (name '(whispers-xdg)) + (description "Daemonized per-user xdg tmpfs runtime directory.") + (extensions (list (service-extension whispers-service-type + whispers-xdg-tree))) + (default-value (whispers-xdg-configuration)))) |