diff options
Diffstat (limited to 'whispers/services/ssh-tunneler.scm')
| -rw-r--r-- | whispers/services/ssh-tunneler.scm | 904 |
1 files changed, 904 insertions, 0 deletions
diff --git a/whispers/services/ssh-tunneler.scm b/whispers/services/ssh-tunneler.scm new file mode 100644 index 0000000..18cb4f3 --- /dev/null +++ b/whispers/services/ssh-tunneler.scm @@ -0,0 +1,904 @@ +;;; Whispers --- Stealth VPN and ssh tunnelerq +;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org> +;;; +;;; This file is part of Whispers. +;;; +;;; Whispers is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Whispers is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Whispers. If not, see <http://www.gnu.org/licenses/>. + +(define-module (whispers services ssh-tunneler) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu services admin) + #:use-module (gnu services mcron) + #:use-module (whispers services whispers) + #:use-module (gnu packages base) + #:use-module (gnu packages admin) + #:use-module (gnu packages linux) + #:use-module (gnu packages ssh) + #:use-module (whispers packages doc) + #:use-module (gnu home services) + #:use-module (gnu home services shepherd) + #:export (ssh-connection-configuration + make-ssh-connection-configuration + ssh-connection-configuration? + this-ssh-connection-configuration + ssh-connection-configuration-forwards + ssh-forward-configuration + this-ssh-forward-configuration + ssh-forward-configuration? + make-ssh-forward-configuration + ssh-forward-configuration-entry-port + socks-proxy-configuration + this-socks-proxy-configuration + socks-proxy-configuration? + make-socks-proxy-configuration + dynamic-forward-configuration + port-forward-configuration + reverse-port-forward-configuration + tunnel-forward-configuration + persistent-ssh-name + persistent-ssh-service-type + home-persistent-ssh-service-type)) + +(define-record-type* <ssh-connection-configuration> + ssh-connection-configuration make-ssh-connection-configuration + ssh-connection-configuration? + this-ssh-connection-configuration + ;; A file-like object. + (shepherd-package ssh-connection-configuration-shepherd-package + (default shepherd)) + ;; A file-like object. + (ssh-package ssh-connection-configuration-ssh-package + (default openssh)) + ;; A file-like object. + (netcat-package ssh-connection-configuration-netcat-package + (default netcat-openbsd)) + ;; A file-like object. + (sshpass-package ssh-connection-configuration-sshpass-package + (default sshpass)) + ;; A file-like object. + (ineutils-package ssh-connection-configuration-inetutils-package + (default inetutils)) + ;; A file-like object. + (procps-package ssh-connection-configuration-procps-package + (default procps)) + ;; A guix record of type <socks-proxy-configuration>. + (socks-proxy-config ssh-connection-configuration-socks-proxy-config + (default (socks-proxy-configuration))) + ;; A boolean value. + (agent? ssh-connection-configuration-agent? + (default #f)) + (agent-socket ssh-connection-configuration-agent-socket + (default "")) + ;; A boolean value. + ;; A string. + ;; It is thinked so that the use-agent? switch of + ;; <whispers-forwardings> binds both agent? and is-rea-file in + ;; opposite states, without exposing this detail to the user. + (id-rsa-file? ssh-connection-configuration-id-rsa-file? + (default (not + (ssh-connection-configuration-agent? + this-ssh-connection-configuration))) + (thunked)) + ;; A string. + (id-rsa-file ssh-connection-configuration-id-rsa-file + (default "/root/.ssh/id_rsa")) + ;; A boolean value. + (clear-password? ssh-connection-configuration-clear-password? + (default #f)) + ;; A string. + (sshd-user-password ssh-connection-configuration-sshd-user-password + (default "none")) + ;; A string. + (sshd-user ssh-connection-configuration-sshd-user + (default "root")) + ;; A string. + (sshd-host ssh-connection-configuration-sshd-host + (default "127.0.0.1")) + ;; An integer. + (sshd-port ssh-connection-configuration-sshd-port + (default 22)) + ;; A boolean value. + (gateway-ports? ssh-connection-configuration-gateway-ports? + (default #t)) + ;; A list of strings. + (known-hosts-files ssh-connection-configuration-known-hosts-files + (default (list "~/.ssh/known_hosts" + "~/.ssh/known_hosts2"))) + ;; A string. + (strict-check ssh-connection-configuration-strict-check + (default "yes")) + ;; An integer. + (server-alive-interval ssh-connection-configuration-server-alive-interval + (default 30)) + ;; An integer. + (server-alive-count-max ssh-connection-configuration-server-alive-count-max + (default 6)) + ;; A string. + (name-prefix ssh-connection-configuration-name-prefix + (default "ssh-forwards")) + ;; A boolean value. + (suffix-name? ssh-connection-configuration-suffix-name? + (default #t)) + ;; A list of strings. + (special-options ssh-connection-configuration-special-options + (default (list))) + ;; A list of <ssh-forward-configuration> records. + (forwards ssh-connection-configuration-forwards + (default '())) + ;; A boolean value. + (exit-forward-failure? ssh-connection-configuration-exit-forward-failure? + (default #t)) + ;; An integer. + (connection-attempts ssh-connection-configuration-connection-attempts + (default 1)) + ;; A boolean value. + (local-command? ssh-connection-configuration-local-command? + (default (ssh-connection-configuration-pid-file? + this-ssh-connection-configuration)) + (thunked)) + ;; A list of strings + (extra-local-commands ssh-connection-configuration-extra-local-commands + (default '())) + ;; A boolean value. + (require-networking? ssh-connection-configuration-require-networking? + (default #t)) + ;; A list of symbols. + (extra-requires ssh-connection-configuration-extra-requires + (default '())) + ;; A boolean value. + (elogind? ssh-connection-configuration-elogind? + (default #f)) + ;; A boolean value. + (lieutenant? ssh-connection-configuration-lieutenant? + (default #f)) + ;; A string. + (lieutenant-path ssh-connection-configuration-lieutenant-path + (default "")) + ;; A boolean value. + (pid-file? ssh-connection-configuration-pid-file? + (default #t)) + ;; A boolean value. + (pid-folder-override? ssh-connection-configuration-pid-folder-override? + (default #f)) + ;; A string. + (pid-folder-override ssh-connection-configuration-pid-folder-override + (default "/var/run")) + ;; A boolean value. + (timeout-override? ssh-connection-configuration-timeout-override? + (default #f)) + ;; An integer. + (timeout-override ssh-connection-configuration-timeout-override + (default 5)) + ;; A boolean value. + (dedicated-log-file? ssh-connection-configuration-dedicated-log-file? + (default #f)) + ;; A boolean value. + (log-rotate? ssh-connection-configuration-log-rotate? + (default #f)) + ;; A boolean value. + (log-folder-override? ssh-connection-configuration-log-folder-override? + (default #f)) + ;; A string. + (log-folder-override ssh-connection-configuration-log-folder-override + (default "/var/run")) + ;; An integer between 0 and 3, both included. + (verbosity ssh-connection-configuration-verbosity + (default 0)) + ;; A boolean value. + (command? ssh-connection-configuration-command? + (default #f)) + ;; A string. + (command ssh-connection-configuration-command + (default '())) + ;; A quoted cron job time specification. + (resurrect-time-spec ssh-connection-configuration-resurrect-time-spec + (default ''(next-minute '(47)))) + ;; A boolean value. + (flat-resurrect? ssh-connection-configuration-flat-resurrect? + (default #f)) + ;; A quoted cron job time specification. + (force-resurrect-time-spec + ssh-connection-configuration-force-resurrect-time-spec + (default ''(next-hour '(3)))) + ;; A boolean value. + (flat-force-resurrect? ssh-connection-configuration-flat-force-resurrect? + (default #f)) + ;; A boolean value. + (%cron-resurrect? ssh-connection-configuration-cron-resurrect? + (default #f)) + ;; A boolean value. + (%cron-force-resurrect? ssh-connection-configuration-cron-force-resurrect? + (default #f)) + ;; A boolean value. + (%auto-start? ssh-connection-configuration-auto-start? + (default #f))) + +(define-record-type* <ssh-forward-configuration> + ssh-forward-configuration make-ssh-forward-configuration + ssh-forward-configuration? + this-ssh-forward-configuration + ;; A symbol which can be 'dynamic, 'port, 'reverse-port or 'tunnel + (forward-type ssh-forward-configuration-forward-type + (default 'dynamic)) + ;; A symbol which can be 'preset or 'any when the 'forward-type field + ;; is 'tunnel, and which can be 'port or 'socket otherwise. It is + ;; ignored when the 'forward-type field is 'dynamic. + (entry-type ssh-forward-configuration-entry-type + (default 'port)) + ;; A symbol which can be 'preset or 'any when the 'forward-type field + ;; is 'tunnel, and which can be 'port or 'socket otherwise. It is + ;; ignored when the 'forward-type field evaluates to 'dynamic. + (exit-type ssh-forward-configuration-exit-type + (default 'port)) + ;; An integer + (entry-port ssh-forward-configuration-entry-port + (default 8971)) + ;; An integer + (exit-port ssh-forward-configuration-exit-port + (default 22)) + ;; A string + (entry-socket ssh-forward-configuration-entry-socket + (default "")) + ;; A string + (exit-socket ssh-forward-configuration-exit-socket + (default "")) + ;; A string + (forward-host ssh-forward-configuration-exit-host + (default "127.0.0.1")) + ;; An integer + (entry-tun ssh-forward-configuration-entry-tun + (default 0)) + ;; An integer + (exit-tun ssh-forward-configuration-exit-tun + (default 0))) + +(define-record-type* <socks-proxy-configuration> + socks-proxy-configuration make-socks-proxy-configuration + socks-proxy-configuration? + this-socks-proxy-configuration + ;; A boolean value + (use-proxy? socks-proxy-configuration-use-proxy? + (default #f)) + ;; A boolean value + (extend? socks-proxy-configuration-extend? + (default (socks-proxy-configuration-use-proxy? + this-socks-proxy-configuration)) + (thunked)) + ;; An integer + (port socks-proxy-configuration-port + (default + (if + (socks-proxy-configuration-extend? + this-socks-proxy-configuration) + (ssh-forward-configuration-entry-port + (car + (ssh-connection-configuration-forwards + (socks-proxy-configuration-dynamic-forward + this-socks-proxy-configuration)))) + 8971)) + (thunked)) + ;; #f, or a guix record returned by a call to + ;; (ssh-connection-configuration + ;; (forwards (list (dynamic-forward-configuration ...))) + ;; ...) + (dynamic-forward socks-proxy-configuration-dynamic-forward + (default #f))) + + +(define-syntax dynamic-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration)) + fields ...)))) + +(define-syntax port-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration (forward-type 'port) + (entry-port 6947))) + fields ...)))) + +(define-syntax reverse-port-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration (forward-type 'reverse-port) + (entry-port 6283))) + fields ...)))) + +(define-syntax tunnel-forward-configuration + (syntax-rules () + ((_ fields ...) + (ssh-forward-configuration + (inherit + (ssh-forward-configuration (forward-type 'tunnel) + (entry-type 'any) + (exit-type 'any))) + fields ...)))) + +(define (persistent-ssh-socks-port config) + "Returns an integer defining the localhost port that a persistent ssh +connection can use to establish itself through a socks proxy, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (socks-proxy-configuration-port + (ssh-connection-configuration-socks-proxy-config config))) + +(define (persistent-ssh-forward-stance forward-conf) + "Returns a string defining one of the forwarding stances of a +persistent ssh connection, configurable by FORWARD-CONF, a record of the +<ssh-forward-configuration> type." + (let* ((forward-type (ssh-forward-configuration-forward-type forward-conf)) + (entry-type (ssh-forward-configuration-entry-type forward-conf)) + (exit-type (ssh-forward-configuration-exit-type forward-conf)) + (entry-port (ssh-forward-configuration-entry-port forward-conf)) + (entry-port-str (number->string entry-port)) + (exit-port (ssh-forward-configuration-exit-port forward-conf)) + (exit-port-str (number->string exit-port)) + (entry-socket (ssh-forward-configuration-entry-socket forward-conf)) + (exit-socket (ssh-forward-configuration-exit-socket forward-conf)) + (exit-host (ssh-forward-configuration-exit-host forward-conf)) + (entry-tun (ssh-forward-configuration-entry-tun forward-conf)) + (entry-tun-str (number->string entry-tun)) + (exit-tun (ssh-forward-configuration-exit-tun forward-conf)) + (exit-tun-str (number->string exit-tun))) + (cond ((equal? forward-type 'dynamic) + (number->string entry-port)) + ((or (equal? forward-type 'port) + (equal? forward-type 'reverse-port)) + (cond ((equal? entry-type 'port) (string-append entry-port-str + ":" + exit-host + ":" + exit-port-str)) + ((equal? entry-type 'socket) (string-append entry-socket + ":" + exit-socket)) + (#t #f))) + ((equal? forward-type 'tunnel) + (string-append (cond ((equal? entry-type 'preset) entry-tun-str) + ((equal? entry-type 'any) "any") + (#t #f)) + ":" + (cond ((equal? exit-type 'preset) exit-tun-str) + ((equal? exit-type 'any) "any") + (#t #f)))) + (#t + #f)))) + +(define (persistent-ssh-forward-switch forward-conf) + "Returns a string defining one of the forwarding switches of a +persistent ssh connection, configurable by FORWARD-CONF, a record of the +<ssh-forward-configuration> type." + (let ((forward-type (ssh-forward-configuration-forward-type forward-conf))) + (cond ((equal? forward-type 'dynamic) "-D") + ((equal? forward-type 'port) "-L") + ((equal? forward-type 'reverse-port) "-R") + ((equal? forward-type 'tunnel) "-w") + (#t #f)))) + +(define (persistent-ssh-forward forward-conf) + "Returns a list of 2 strings containing the switch and stance of one of the +forwardings of a persistent ssh connection, configurable by +FORWARD-CONF, a record of the <ssh-forward-configuration> type." + (list (persistent-ssh-forward-switch forward-conf) + (persistent-ssh-forward-stance forward-conf))) + +(define (persistent-ssh-name-suffix config) + "Returns a string defining the suffix part of the shepherd service +provision of the shepherd service daemonizing a persistent ssh +connection, configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((forwards (ssh-connection-configuration-forwards config)) + (typer ssh-forward-configuration-forward-type) + (typer-str (lambda (forward) + (symbol->string (typer forward)))) + (stancer persistent-ssh-forward-stance) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-resurrect? config))) + (string-append "_" + (string-join (map (lambda (forward) + (string-append (typer-str forward) + "@" + (stancer forward))) + forwards) + "_") + (if use-socks? + (string-append "_proxy-port_" + socks-port-str) + "")))) + +(define (persistent-ssh-name config) + "Returns a symbol defining the shpherd service provision of the +shepherd service daemonizing a persistent ssh connection, configurable +by CONFIG, a record of the <ssh-connection-configuration> type." + (string->symbol + (string-append (ssh-connection-configuration-name-prefix config) + (if (ssh-connection-configuration-suffix-name? config) + (persistent-ssh-name-suffix config) + "")))) + +(define (persistent-ssh-pid-folder config) + "Returns a string defining the path to the folder in which the pid +file of a persistent ssh connection service is stored by default, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (cond ((ssh-connection-configuration-pid-folder-override? config) + (ssh-connection-configuration-pid-folder-override config)) + ((ssh-connection-configuration-elogind? config) + (string-append "/run/user/" (number->string (getuid)))) + (else "/var/run"))) + +(define (persistent-ssh-pid-file-path config) + "Returns a string defining the path to the pid file of a persistent +ssh connection service, configurable by CONFIG, configurable by CONFIG, +a record of the <ssh-connection-configuration> type." + (string-append (persistent-ssh-pid-folder config) + "/" + (symbol->string (persistent-ssh-name config)) + ".pid")) + +(define (persistent-ssh-log-folder config) + "Returns a string defining the path to the folder in which the log +file of a persistent ssh connection service is stored by default, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (cond ((ssh-connection-configuration-log-folder-override? config) + (ssh-connection-configuration-log-folder-override config)) + ((ssh-connection-configuration-elogind? config) + (string-append "/run/user/" (number->string (getuid)))) + (else "/var/run"))) + +(define (persistent-ssh-log-file-path config) + "Returns a string defining the path to the log file of a persistent +ssh connection service, configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (string-append (persistent-ssh-log-folder config) + "/" + (symbol->string (persistent-ssh-name config)) + ".log")) + +(define (persistent-ssh-local-command config) + "Returns a string defining command executed locally after the forwards +of a persistent ssh connection service have been succesfully created, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (let ((procps-package (ssh-connection-configuration-procps-package config)) + (clear-password? (ssh-connection-configuration-clear-password? + config)) + (extra-local-commands + (ssh-connection-configuration-extra-local-commands + config))) + (append (list (file-append procps-package + "/bin/ps") + " --no-header --pid $PPID -o " + (if clear-password? + "ppid" + "pid") + " > " + (persistent-ssh-pid-file-path config)) + (map (lambda (command) + (string-append " && " + command)) + extra-local-commands)))) + +(define (persistent-ssh-requires config) + "Returns a list of symbols defining the other services required as +dependencies by the shepherd service of a persistent ssh connection, +configurable by CONFIG, a record of the <ssh-connection-configuration> +type." + (let* ((req-net? (ssh-connection-configuration-require-networking? config)) + (extra-reqs (ssh-connection-configuration-extra-requires config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-force-resurrect? config))) + (append + (if req-net? + (list 'networking) + (list)) + extra-reqs + (if inferior? + (list (persistent-ssh-name inferior-cnf)) + (if use-socks? + (list (string->symbol + ;; FIXME: this just assumes a possible + ;; default name, not always true and not + ;; even the only possible default. + (string-append "ssh-forwards_dynamic@" + (number->string socks-port)))) + (list)))))) + +(define (persistent-ssh-timeout config) + "Returns an integer setting the pid file timout of the shepherd +service daemonizing a persistent ssh connection, configurable by CONFIG, +a record of the <ssh-connection-configuration> type." + (if (ssh-connection-configuration-timeout-override? config) + (ssh-connection-configuration-timeout-override config) + #~(+ #$(ssh-connection-configuration-connection-attempts config) + (default-pid-file-timeout)))) + +(define (persistent-ssh-constructor-gexp config) + "Returns G-exp to a procedure starting the ssh client process of a +persistent ssh connection, configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((sshpass-pkg (ssh-connection-configuration-sshpass-package config)) + (password (ssh-connection-configuration-sshd-user-password config)) + (ssh-pkg (ssh-connection-configuration-ssh-package config)) + (netcat-pkg (ssh-connection-configuration-netcat-package config)) + (verbosity (ssh-connection-configuration-verbosity config)) + (eff? (ssh-connection-configuration-exit-forward-failure? config)) + (tries (ssh-connection-configuration-connection-attempts config)) + (tries-str (number->string tries)) + (local-com? (ssh-connection-configuration-local-command? config)) + (local-com (persistent-ssh-local-command config)) + (gateway? (ssh-connection-configuration-gateway-ports? config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (command? (ssh-connection-configuration-command? config)) + (command (ssh-connection-configuration-command config)) + (forwards (ssh-connection-configuration-forwards config)) + (sshd-port (ssh-connection-configuration-sshd-port config)) + (sshd-port-str (number->string sshd-port)) + (agent? (ssh-connection-configuration-agent? config)) + (agent-socket (ssh-connection-configuration-agent-socket config)) + (id-rsa? (ssh-connection-configuration-id-rsa-file? config)) + (id-rsa (ssh-connection-configuration-id-rsa-file config)) + (sshd-user (ssh-connection-configuration-sshd-user config)) + (sshd-host (ssh-connection-configuration-sshd-host config)) + (dlf? (ssh-connection-configuration-dedicated-log-file? config)) + (log-file (persistent-ssh-log-file-path config)) + (pid-file? (ssh-connection-configuration-pid-file? config)) + (pid-file (persistent-ssh-pid-file-path config)) + (timeout (persistent-ssh-timeout config)) + (special-opt (ssh-connection-configuration-special-options config)) + (strict-check (ssh-connection-configuration-strict-check config)) + (kh-files (ssh-connection-configuration-known-hosts-files config)) + (sa-int (ssh-connection-configuration-server-alive-interval + config)) + (acount-max (ssh-connection-configuration-server-alive-count-max + config))) + #~(make-forkexec-constructor + (append #$(if (ssh-connection-configuration-clear-password? config) + #~(list #$(file-append sshpass-pkg "/bin/sshpass") + "-p" + #$password) + #~(list)) + (list #$(file-append ssh-pkg "/bin/ssh") + "-o" + "TCPKeepAlive=no" + "-o" + (string-append "ServerAliveInterval=" + #$(number->string sa-int)) + "-o" + (string-append "ServerAliveCountMax=" + #$(number->string acount-max)) + "-o" + (string-append "UserKnownHostsFile=" + #$(string-join kh-files)) + "-o" + (string-append "StrictHostKeyChecking=" #$strict-check) + ;; "-o" + ;; "Tunnel=point-to-point" + "-o" + (string-append "ExitOnForwardFailure=" + #$(if eff? + "yes" + "no")) + "-o" + (string-append "ConnectionAttempts=" + #$tries-str)) + #$(if local-com? + #~(list "-o" + "PermitLocalCommand=yes" + "-o" + (apply string-append + (append (list "LocalCommand=") + #$(append (list 'list) + local-com)))) + #~(list)) + #$(if gateway? + #~(list "-o" + "GatewayPorts=yes") + #~(list)) + #$(if use-socks? + #~(list "-o" + (string-append "ProxyCommand=" + #$netcat-pkg + "/bin/nc" + " -X 5 -x localhost:" + #$socks-port-str + " %h %p")) + #~(list)) + #$(append (list 'list) + special-opt) + (list "-p" + #$sshd-port-str) + #$(if id-rsa? + #~(list "-i" + #$id-rsa) + #~(list)) + #$(cond ((= verbosity 0) #~(list)) + ((= verbosity 1) #~(list "-v")) + ((= verbosity 2) #~(list "-v" "-v")) + ((= verbosity 3) #~(list "-v" "-v" "-v")) + (#t #f)) + #$(if command? + #~(list) + #~(list "-N")) + #$(append (list 'list) + (apply append + (map persistent-ssh-forward + forwards))) + (list (string-append #$sshd-user + "@" + #$sshd-host)) + #$(if command? + #~(list #$command) + #~(list))) + #:log-file + #$(if dlf? + log-file + #f) + #:pid-file + #$(if pid-file? + pid-file + #f) + #:pid-file-timeout + #$timeout + #:environment-variables + '#$(if agent? + (list (string-append "SSH_AUTH_SOCK=" + agent-socket)) + (list (string-append "SSH_AUTH_SOCK=" + "/dev/null")))))) + +(define (persistent-ssh-resurrect-action config) + "Returns a G-exp to a procedure used as the procedure of the +'resurrect action of the shepherd service supporting a persistent ssh +connection , configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((name (persistent-ssh-name config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-resurrect? config))) + #~(lambda (running) + (unless (service-running? (lookup-service '#$name)) + (perform-service-action (lookup-service '#$name) + 'enable) + (unless (or #$flat? + (and (not #$inferior?) + (not #$use-socks?))) + (let ((inferior-name + '#$(if inferior? + (persistent-ssh-name inferior-cnf) + (if use-socks? + (string->symbol + ;; FIXME: this just assumes a possible + ;; default name, not always true and not + ;; even the only possible default. + (string-append "ssh-forwards_dynamic@" + socks-port-str)) + 'not-a-service)))) + (perform-service-action (lookup-service inferior-name) + 'resurrect))) + (start-service (lookup-service '#$name))) + #t))) + +(define (persistent-ssh-force-resurrect-action config) + "Returns a G-exp to a procedure used as the procedure of the +'force-resurrect action of the shepherd service supporting a persistent +ssh connection , configurable by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((name (persistent-ssh-name config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (flat? (ssh-connection-configuration-flat-force-resurrect? config))) + #~(lambda (running) + (perform-service-action (lookup-service '#$name) + 'enable) + (stop-service (lookup-service '#$name)) + (unless (or #$flat? + (and (not #$inferior?) + (not #$use-socks?))) + (let ((inferior-name + '#$(if inferior? + (persistent-ssh-name inferior-cnf) + (if use-socks? + (string->symbol + ;; FIXME: this just assumes a possible + ;; default name, not always true and not + ;; even the only possible default. + (string-append "ssh-forwards_dynamic@" + socks-port-str)) + 'not-a-service)))) + (perform-service-action (lookup-service inferior-name) + 'force-resurrect))) + (start-service (lookup-service '#$name)) + #t))) + +(define (persistent-ssh-shepherd-services config) + "Returns a list of shepherd services handling a ssh client daemon +connection, configured by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((name (persistent-ssh-name config)) + (socks-rec (ssh-connection-configuration-socks-proxy-config config)) + (inferior? (socks-proxy-configuration-extend? socks-rec)) + (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec)) + (use-socks? (socks-proxy-configuration-use-proxy? socks-rec)) + (socks-port (socks-proxy-configuration-port socks-rec)) + (socks-port-str (number->string socks-port)) + (reqs (persistent-ssh-requires config)) + (constructor-gexp (persistent-ssh-constructor-gexp config)) + (res-gexp (persistent-ssh-resurrect-action config)) + (force-res-gexp (persistent-ssh-force-resurrect-action config)) + (auto-start? (ssh-connection-configuration-auto-start? config))) + (append + (if inferior? + (persistent-ssh-shepherd-services inferior-cnf) + (list)) + (list + (shepherd-service + (documentation "Persistent ssh client connection") + (provision `(,name)) + (requirement reqs) + (start constructor-gexp) + (stop #~(make-kill-destructor)) + (actions + (list + (shepherd-action (name 'resurrect) + (documentation + "Resurrect this connection and its +inferiors-proxies if they are stopped or disabled by the Shepherd.") + (procedure res-gexp)) + (shepherd-action (name 'force-resurrect) + (documentation "Enable, stop and restart this +connection and its inferior-proxies , regardless of their current +status.") + (procedure force-res-gexp)))) + (auto-start? auto-start?)))))) + +(define (persistent-ssh-cron-jobs config) + "Returns a list of cron job specifications to extend the mcron service +with scheduled resurrection actions on the persistent ssh connection +port forwards configured by CONFIG, a record of the +<ssh-connection-configuration> type." + (let* ((service-name-str (symbol->string (persistent-ssh-name config))) + (lieutenant? (ssh-connection-configuration-lieutenant? config)) + (lieutenant-path (ssh-connection-configuration-lieutenant-path + config)) + (lieutenant-socket (lieutenant-path->socket-file-path + lieutenant-path)) + (shepherd-pkg + (ssh-connection-configuration-shepherd-package config)) + (cron-resurrect? + (ssh-connection-configuration-cron-resurrect? config)) + (resurrect-time-spec + (ssh-connection-configuration-resurrect-time-spec config)) + (cron-force-resurrect? + (ssh-connection-configuration-cron-force-resurrect? config)) + (force-resurrect-time-spec + (ssh-connection-configuration-force-resurrect-time-spec config))) + (append + (if cron-resurrect? + (list #~(job #$resurrect-time-spec + (lambda () + (apply execl + (append (list (string-append #$shepherd-pkg + "/bin/herd") + "herd") + (if #$lieutenant? + (list "-s" + #$lieutenant-socket) + (list)) + (list "resurrect" + #$service-name-str)))) + (string-append "resurrect " + #$service-name-str))) + (list)) + (if cron-force-resurrect? + (list #~(job #$force-resurrect-time-spec + (lambda () + (apply execl + (append (list (string-append #$shepherd-pkg + "/bin/herd") + "herd") + (if #$lieutenant? + (list "-s" + #$lieutenant-socket) + (list)) + (list "force-resurrect" + #$service-name-str)))) + (string-append "force-resurrect " + #$service-name-str))) + (list))))) + +(define (persistent-ssh-log-rotation config) + "Returns a list of log-rotation records specifying how to rotate the +logs of a persistent ssh connection configurable by CONFIG, a record of +the <ssh-connection-configuration> type." + (if (and (ssh-connection-configuration-dedicated-log-file? config) + (ssh-connection-configuration-log-rotate? config)) + (list + (log-rotation (frequency 'daily) + (files `(,(persistent-ssh-log-file-path config))))) + (list))) + +(define persistent-ssh-service-type + (service-type + (name 'persistent-ssh) + (description "Persistent ssh connection service") + (extensions + (list (service-extension shepherd-root-service-type + persistent-ssh-shepherd-services) + (service-extension mcron-service-type + persistent-ssh-cron-jobs) + (service-extension rottlog-service-type + persistent-ssh-log-rotation) + (service-extension + profile-service-type + (lambda (config) + (list + ssh-tunneler-doc + (ssh-connection-configuration-ssh-package config) + (ssh-connection-configuration-netcat-package config) + (ssh-connection-configuration-sshpass-package config) + (ssh-connection-configuration-procps-package config) + (ssh-connection-configuration-inetutils-package config) + ssh-tunneler-tests))))) + (default-value (ssh-connection-configuration)))) + +(define home-persistent-ssh-service-type + (service-type + (name 'persistent-ssh) + (description "Persistent ssh connection normal user service") + (extensions + (list (service-extension home-shepherd-service-type + persistent-ssh-shepherd-services) + (service-extension + home-profile-service-type + (lambda (config) + (list + ssh-tunneler-doc + (ssh-connection-configuration-ssh-package config) + (ssh-connection-configuration-netcat-package config) + (ssh-connection-configuration-sshpass-package config) + (ssh-connection-configuration-procps-package config) + (ssh-connection-configuration-inetutils-package config)) + ssh-tunneler-tests)))) + (default-value (ssh-connection-configuration)))) |