diff options
Diffstat (limited to 'whispers/services/whispers/vpn.scm')
| -rw-r--r-- | whispers/services/whispers/vpn.scm | 3424 |
1 files changed, 3424 insertions, 0 deletions
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)))) |