;;; 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))))