Initial.

A  .guix-authorizations
A  .guix-channel
A  COPYING
A  README
A  whispers/packages/dict.scm
A  whispers/packages/doc.scm
A  whispers/packages/pdf.scm
A  whispers/packages/sh.scm
A  whispers/packages/whispers.scm
A  whispers/services/console.scm
A  whispers/services/dict.scm
A  whispers/services/finance.scm
A  whispers/services/gps.scm
A  whispers/services/proton.scm
A  whispers/services/ssh-agent.scm
A  whispers/services/ssh-tunneler.scm
A  whispers/services/whispers.scm
A  whispers/services/whispers/finance.scm
A  whispers/services/whispers/gps.scm
A  whispers/services/whispers/mail.scm
A  whispers/services/whispers/ssh.scm
A  whispers/services/whispers/vpn.scm
A  whispers/services/whispers/xdg.scm
A  whispers/tests/ssh-tunneler.scm

Signed-off-by: Runciter <runciter@whispers-vpn.org>

1 files changed, 906 insertions, 0 deletions

diff --git a/whispers/services/ssh-tunneler.scm b/whispers/services/ssh-tunneler.scm
new file mode 100644
index 0000000..505273e
--- /dev/null
+++ b/whispers/services/ssh-tunneler.scm
@@ -0,0 +1,906 @@
+;;; 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 (whispers packages sh)
+  #: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 thunked 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))))