[bug#64349] [PATH] Guix service for robust and flexible persistent ssh forwarding

[Maze]

Hello Guix!

I have written a Guix service module to daemonize various types of ssh
forwardings. Basic uses should be very easy to configure.

I am a beginner so you guys will probably laugh at my Scheme. But I have
been using this for remote access to my computers and to daemonize socks
proxies on localhost, I'll say it's pretty damned robust even when the
network is extremely slow, and I think port [reverse] forwardings and
dynamic forwardings are things that quite a few users like to have, even
stand-alone. 

Anyway, as the Guix manual recommends I'm just checking if you're
interested to integrate part or all of this into the Guix mainline, or
cannibalize for GNU in any way you see fit. Regardless of outcome, my
goal now is to continue to build another layer on top to turn this into
a full-blown VPN, as zeronconf as these things can get. But at the pace
at which I'm going it's going to be 4 months at the very least before I
have a semi-finished VPN for experimental use. The stand-alone
forwardings of this patch, on the other hand, are working right here
right now.

CONFIGURING FOR ACCESS:

* Your setup better be secure and never allow unauthenticated access to
  the remote server or the local client... If you don't have this in
  place, using this module could take you from bad to worse.

* Don't forget to set GatewayPorts=yes on the sshd if necessary for your
  case! For example in the sshd_config file. Chances are, you probably
  need it if you're looking to evade internet censorship, and it will
  make your life easier if you're looking for remote access to your home
  computer.

* Rarely, and depending on your application it might also be necessary to
  enable gateway ports for the ssh client, there's a configuration switch
  for that in the record which does it on a connection basis.
  
* Currently, for the most default use the local ssh tries to get access
  to the remote sshd as root. But it's better to change from that
  default if you can, like in the basic examples below, unless you need
  to forward a priviledged port of the remote sshd.

* By default access is to be granted by the remote sshd through a rsa
  private key at /root/id_rsa on the local client machine. You can
  change and it might work but you must feed it a file - no agent
  currently. See the record fields for details. As you're probably aware
  if you read this, when the sshd runs under Guix, a very nice facility
  is provided to take care of the public auth keys.

* If you must use a password (don't!), the relevant fields of the
  configuration record should be self-explanatory. 
  
SERVICE RECORD BASIC EXAMPLES:
On the client end, somewhat minimal configuration records might look
something like this:

* For a dynamic forward which can support the client end of a persistent
socks proxy:

(service persistent-ssh-service-type
         (ssh-connection-configuration
          (sshd-user "joe-chip") ; Default is root, better change if you can
          (sshd-host "1.2.3.4") ; Try with an IP address here at first
          (forwards
           (list (dynamic-forward-configuration
                  (entry-port 1234)))))) ; you may want to change from default

* For a port forwarding:

(service persistent-ssh-service-type
         (ssh-connection-configuration
          (sshd-user "joe-chip") ; Default is root, better change if you can
          (sshd-host "1.2.3.4") ; Try with an IP address here at first
          (forwards
           (list (port-forward-configuration
                  (entry-port 1234) ; you may want to change from default
                  (exit-port 22)))))) ; default 22 here, could be what
                                      ; you need or not

* For a reverse port forwarding:

(service persistent-ssh-service-type
         (ssh-connection-configuration
          (sshd-user "joe-chip") ; Default is root, better change if you can
          (sshd-host "1.2.3.4") ; Try with an IP address here at first
          (forwards
           (list (reverse-port-forward-configuration
                  (entry-port 1234) ; you may want to change from default
                  (exit-port 22)))))) ; default 22 here, could be what
                                      ; you need or not

Only the local client needs to use the facilities of the module in this
patch, which means only the client must run Guix to enjoy the below
service. 

STATE OF THE ART:
Features expected to work, from test script and/or my own daily use:

* Dynamic forwards, port to port forwards or reverse forwards, tunnels.

* Opening a forwarding while using a dynamic forward from the same guix
  service extended with this module as the entry point of its socks
  proxy. When using this underneath a tunnel forwarding supporting a VPN
  network, it's a very potent tool to workaround even the most advanced
  nation-state and megacorporation censorship technologies!.. brought to
  you by a dirty recourse to netcat-openbsd (not my original idea
  though, it's a nice little trick which has been floating around for
  some time).
  
* Being wrapped under sshpass. Boooh! As unrecommended as it may be, it
  can be a necessity sometimes such as with some commercial providers of
  the sshd end of a socks proxy...
  
* The resurrect and force-resurrect actions, actionnable from cron
  jobs. Nice when you spend a few days to a few weeks away from home and
  need remote access to your desktops and servers despite a dynamic IP
  and/or an uncooperative phone company.

Available features that might work but are untested:

* I recently added the feature that you can define multiple forwardings
  for a single ssh process. I have not begun testing any ssh connection
  with 2 or more forwardings, but there's a chance it already works
  because I extend the forwardings from basically just mapping a list in
  the configuration record.
  
* Socket-to-socket and port-to-socket [reverse] forwardings are also
  implemented but not yet tested.

* There's still a home shepherd service type available. I used it some
  months ago then I stopped, it may or may not still work.

* It can probably chain an in-practice-arbitrary number of socks
  proxies, but I have not tried yet.

Suspected and known issue:

* The log rotation apparently goes through a system reconfiguration if
  activated in the record, but then I think it does nothing. I probably
  did something incorrect, will look at it when I have time.

* Auto-starting at boot is unreliable. One issue (maybe?) is I don't
  know how to really depend on the physical networking being fully
  established, but I'm not sure that's even the only problem. When I
  change nothing, I notice it's not deterministic at all. By the time I
  get a handle, I can start my failed auto-start connections with herd
  no problem.

* In my own system configuration, I don't know why it seems that some
  forwardings accept a sshd host in the form of a resolvable hostname,
  others will only take an IP address. Not sure, it could be a subtlety
  with ssh or even a mistake in my system configurations file... But for
  the time being, I would recommend using IP addresses not hostnames if
  you trial this module. If it works, you can then shift to trying with
  a hostname and let me know if you experience issues.

Missing:

* I have not started to work on control masters. When one has many
  connections daemonized to the same remote host, there could (should?)
  be a specialized service type extended only to serve as a control
  master for multiple other forwarding services. It's probably not that
  easy to program correctly.

* It only loads a private key directly from file, no ssh agent. I think
  it's probably quite easy to add.

* I haven't even tried to make host knowing configurable the
  slightest. No one is there to input "yes" when it starts, so I just
  hard coded ssh command switches that should completely tame the
  dreaded "SOMEONE MAY BE DOING SOMETHING NASTY!" and its little
  friends. Still, in the event this module would start to have its small
  user base, I might kind of feel bad about this and something would
  preferably have to be done... if that can possibly be practical.
  
* I think it can only do point-to-point tunnels, that is to say tun
  devices. Ssh documentation says it also can do tap devices, what they
  call layer 2, which can support DHCP, but in trials I never could get
  it to spit out a working tap tunnel... By using ssh for the network
  side of the tunnel and tunctl or POSIX or whatever applicable system
  calls from a program for the host sides of the tunnel, maybe it's
  possible to do tap devices. It's hard, probably.

* No documentation as of yet. The author also still has to learn how to
  write actual Texinfo docstrings for procedures, sorry about that.

* I have a test script (not shared here) but it does not plug into the
  build system. Also, it deploys multiples VMs to test forwardings in
  situation, which means it can do some very strong testing but it's too
  heavy for a routine build. And the script does other things which are
  either crazy and/or very badly written. I could never have pulled this
  without my horrible shell script, but still, a simple script which
  plugs into the build system would be more desirable.

---
 gnu/services/ssh-tunneler.scm | 834 ++++++++++++++++++++++++++++++++++
 1 file changed, 834 insertions(+)
 create mode 100644 gnu/services/ssh-tunneler.scm

diff --git a/gnu/services/ssh-tunneler.scm b/gnu/services/ssh-tunneler.scm
new file mode 100644
index 0000000000..0163aa9e65
--- /dev/null
+++ b/gnu/services/ssh-tunneler.scm
@@ -0,0 +1,834 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Maze <maze@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 (gnu 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 (gnu packages base)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages ssh)
+  #: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-forward-configuration
+            this-ssh-forward-configuration
+            ssh-forward-configuration?
+            make-ssh-forward-configuration
+            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-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.
+  (id-rsa-file?           ssh-connection-configuration-id-rsa-file?
+                          (default #t))
+  ;; 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 "localhost"))
+  ;; An integer.
+  (sshd-port              ssh-connection-configuration-sshd-port
+                          (default 22))
+  ;; A boolean value.
+  (gateway-ports?         ssh-connection-configuration-gateway-ports?
+                          (default #t))
+  ;; 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.
+  (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
+  (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
+  (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 #t)))
+
+(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 "localhost"))
+  ;; 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 (if (socks-proxy-configuration-extend?
+                                      this-socks-proxy-configuration)
+                                     (dynamic-forward-configuration)
+                                     #f))
+                        (thunked)))
+
+
+(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 "@"
+                                      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))
+         (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)))
+    #~(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"
+                     "ServerAliveInterval=30"
+                     "-o"
+                     "ServerAliveCountMax=6"
+                     "-o"
+                     "UserKnownHostsFile=/dev/null"
+                     "-o"
+                     "StrictHostKeyChecking=no"
+                     ;; "-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)))
+
+(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."
+  (append
+   (if (ssh-connection-configuration-cron-resurrect? config)
+       (list
+        #~(job #$(ssh-connection-configuration-resurrect-time-spec config)
+               (lambda ()
+                 (execl
+                  (string-append
+                   #$(ssh-connection-configuration-shepherd-package config)
+                   "/bin/herd")
+                  "herd"
+                  "resurrect"
+                  #$(symbol->string (persistent-ssh-name config))))
+               (string-append
+                "resurrect "
+                #$(symbol->string (persistent-ssh-name config)))))
+       (list))
+   (if (ssh-connection-configuration-cron-force-resurrect? config)
+       (list
+        #~(job #$(ssh-connection-configuration-force-resurrect-time-spec
+                  config)
+               (lambda()
+                 (execl
+                  (string-append
+                   #$(ssh-connection-configuration-shepherd-package config)
+                   "/bin/herd")
+                  "herd"
+                  "force-resurrect"
+                  #$(symbol->string (persistent-ssh-name config))))
+               (string-append
+                "force-resurrect "
+                #$(symbol->string (persistent-ssh-name config)))))
+       (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-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))))))
+   (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-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))))))
+   (default-value (ssh-connection-configuration))))
-- 
2.40.1