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