path: root/whispers/services/whispers/ssh.scm

;;; Whispers --- Stealth VPN and ssh tunneler
;;; 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 whispers ssh)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu system shadow)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (whispers services whispers)
  #:use-module (whispers services ssh-agent)
  #:use-module (whispers services ssh-tunneler)
  #:use-module (gnu packages ssh)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages linux)
  #:export (whispers-ssh-service-type
            whispers-ssh-configuration
            whispers-ssh-configuration?
            ssh-user-group-keys-forwards
            ssh-user-group-keys-forwards?
            whispers-forwarding
            whispers-forwarding?))

(define-record-type* <whispers-ssh-configuration>
  whispers-ssh-configuration make-whispers-ssh-configuration
  whispers-ssh-configuration?
  this-whispers-ssh-configuration
  ;; A file-like object
  (ssh-package          whispers-ssh-configuration-ssh-package
                        (default openssh))
  ;; A list of ssh-user-group-keys-forwards records
  (users-groups-keys-forwards
   whispers-ssh-configuration-users-groups-keys-forwards
   (default '())))

(define-record-type* <ssh-user-group-keys-forwards>
  ssh-user-group-keys-forwards make-ssh-user-group-keys-forwards
  ssh-user-group-keys-forwards?
  this-ssh-agents-user-group-keys
  ;; A whispers-user-group record
  (user-and-group       ssh-user-group-keys-forwards-user-and-group
                        (default (whispers-user-group)))
  ;; A boolean value
  (shell-tests?         ssh-user-group-keys-forwards-shell-tests?
                        (default #f))
  ;; A boolean value
  (agent?               ssh-user-group-keys-forwards-agent?
                        (default #t))
  ;; A list of strings
  (keys                 ssh-user-group-keys-forwards-keys
                        (default '()))
  ;; A boolean value
  (tunneler?            ssh-user-group-keys-forwards-tunneler?
                        (default #f))
  ;; A list of <whispers-forwarding> objects
  (forwardings           ssh-user-group-keys-forwards-forwardings
                         (default '())))

(define-record-type* <whispers-forwarding>
  whispers-forwarding make-whispers-forwarding
  whispers-forwarding?
  this-ssh-agents-user-group-keys
  ;; A list of <ssh-forward-configuration> objects
  (forwards               whispers-forwarding-forwards
                          (default '()))
  ;; A string.
  (name-prefix            whispers-forwarding-name-prefix
                          (default "ssh-forwards"))
  ;; A boolean value.
  (suffix-name?           whispers-forwarding-suffix-name?
                          (default #t))
  ;; A boolean value.
  (use-agent?             whispers-forwarding-use-agent?
                          (default #t))
  ;; A boolean value.
  (clear-password?        whispers-forwarding-clear-password?
                          (default #f))
  ;; A string.
  (clear-password         whispers-forwarding-clear-password
                          (default ""))
  ;; A string.
  (sshd-user              whispers-forwarding-sshd-user
                          (default "root"))
  ;; A string.
  (sshd-host              whispers-forwarding-sshd-host
                          (default "127.0.0.1"))
  ;; An integer.
  (sshd-port              whispers-forwarding-sshd-port
                          (default 22))
  ;; A string.
  (strict-check           whispers-forwarding-strict-check
                          (default "yes"))
  ;; A list of strings.
  (known-hosts-files      whispers-forwarding-known-hosts-files
                          (default (list "~/.ssh/known_hosts"
                                         "~/.ssh/known_hosts2")))
  ;; An integer.
  (server-alive-interval  whispers-forwarding-server-alive-interval
                          (default 30))
  ;; An integer.
  (server-alive-count-max whispers-forwarding-server-alive-count-max
                          (default 6))
  ;; A boolean value
  (resurrect?             whispers-forwarding-resurrect?
                          (default #t))
  ;; A quoted cron time job specification
  (resurrect-time-spec    whispers-forwarding-resurrect-time-spec
                          (default ''(next-minute '(47))))
  ;; A boolean value
  (force-resurrect?       whispers-forwarding-force-resurrect?
                          (default #t))
  ;; A quoted cron time job specification
  (force-resurrect-time-spec
   whispers-forwarding-force-resurrect-time-spec
   (default ''(next-hour '(3))))
  ;; An integer
  (timeout                whispers-forwarding-timeout
                          (default 5))
  ;; A boolean value.
  (stealth?               whispers-forwarding-stealth?
                          (default #t))
  ;; A string.
  (stealth-name-prefix    whispers-forwarding-stealth-name-prefix
                          (default "ssh-forwards"))
  ;; A boolean value.
  (stealth-suffix-name?   whispers-forwarding-stealth-suffix-name?
                          (default #t))
  ;; A boolean value.
  (stealth-use-agent?     whispers-forwarding-stealth-use-agent?
                          (default #t))
  ;; A boolean value.
  (stealth-clear-password?
   whispers-forwarding-stealth-clear-password?
   (default #f))
  ;; A string.
  (stealth-clear-password
   whispers-forwarding-stealth-clear-password
   (default ""))
  ;; A string.
  (stealth-sshd-user      whispers-forwarding-stealth-sshd-user
                          (default "root"))
  ;; A string.
  (stealth-sshd-host      whispers-forwarding-stealth-sshd-host
                          (default "127.0.0.1"))
  ;; An integer.
  (stealth-sshd-port      whispers-forwarding-stealth-sshd-port
                          (default 22))
  ;; A string.
  (stealth-strict-check   whispers-forwarding-stealth-strict-check
                          (default "yes"))
  ;; A list of strings.
  (stealth-known-hosts-files
   whispers-forwarding-stealth-known-hosts-files
   (default (list "~/.ssh/known_hosts"
                  "~/.ssh/known_hosts2")))
  ;; An integer.
  (stealth-server-alive-interval
   whispers-forwarding-stealth-server-alive-interval
   (default 30))
  ;; An integer.
  (stealth-server-alive-count-max
   whispers-forwarding-stealth-server-alive-count-max
   (default 6))
  ;; An integer.
  (stealth-timeout        whispers-forwarding-stealth-timeout
                          (default 5))
  ;; An integer.
  (stealth-proxy-port     whispers-forwarding-stealth-proxy-port
                          (default 8585))
  ;; A boolean value.
  (%auto-start?           whispers-forwarding-auto-start?
                          (default #t)))

(define (log-folder-agent user)
  "Return a string naming the path to the folder where the log file of
the ssh agent daemon of the user named by the string USER is stored."
  (string-append "/var/log/whispers/ssh/"
                 (user-container-name user)
                 "/ssh-agent"))

(define (socket-folder-agent user)
  "Return a string naming the path to the folder where the socket file
of the ssh agent daemon of the user named by the string USER is located."
  (string-append "/run/whispers/ssh/"
                 (user-container-name user)
                 "/ssh-agent/unix-sockets"))

(define (log-folder-forwarding user conn)
  "Return a string naming the path to the folder where the log file of
the ssh tunneler of the user named by the string USER is stored."
  (string-append "/var/log/whispers/ssh/"
                 (user-container-name user)
                 "/tunneler/"
                 conn))

(define (base-folder-forwarding user conn)
  "Return a string naming the path to the folder where the pid files
of the ssh tunneler of the persistent ssh connection
described by the string CONN of the user named by the string USER is
located."
  (string-append "/run/whispers/ssh/"
                 (user-container-name user)
                 "/tunneler/"
                 conn))

(define (socket-folder-forwarding user conn)
  "Return a string naming the path to the folder where the socket files
of the ssh tunneler of the persistent ssh connection
described by the string CONN of the user named by the string USER is
located."
  (string-append "/run/whispers/ssh/"
                 (user-container-name user)
                 "/tunneler/"
                 conn
                 "/unix-sockets"))

(define (agent ssh-package user keys)
  "Returns an ssh agent guix service for an ssh agent daemon from the
package SSH-PACKAGE owned by the user named by the string USER and with
the private key files named in the list of string KEYS auto-loaded at
startup."
  (service
   ssh-agent-service-type
   (ssh-agent-configuration (ssh-package ssh-package)
                            (log-folder (log-folder-agent user))
                            (socket-folder (socket-folder-agent user))
                            (auto-added-keys keys))))

(define (forwarding->conn-strings forwarding)
  "Returns a list of strings used to hopefully uniquely identify the
 persistent ssh connections to remote handles of remote hosts,
configured from the fields of FORWARDING, a record of the
<whispers-forwarding> type. The strings are used as sub-folders names
for files relevant to the extended shepherd services. The list contains
two strings if the forwarding is extended with stealth switched on, and
one string otherwise."
  (let ((sshd-user (whispers-forwarding-sshd-user forwarding))
         (host (whispers-forwarding-sshd-host forwarding))
         (port (whispers-forwarding-sshd-port forwarding))
         (stealth? (whispers-forwarding-stealth? forwarding))
         (stealth-sshd-user (whispers-forwarding-stealth-sshd-user
                             forwarding))
         (stealth-host (whispers-forwarding-stealth-sshd-host forwarding))
         (stealth-port (whispers-forwarding-stealth-sshd-port forwarding)))
    (append (list (string-append "ssh-connection_"
                                 sshd-user
                                 "@"
                                 host
                                 ":"
                                 (number->string port)
                                 (if stealth?
                                     (string-append "_proxy_"
                                                    stealth-sshd-user
                                                    "@"
                                                    stealth-host
                                                    ":"
                                                    (number->string
                                                     stealth-port))
                                     "")))
            (if stealth?
                (list (string-append "ssh-connection_"
                                     stealth-sshd-user
                                     "@"
                                     stealth-host
                                     ":"
                                     (number->string stealth-port)))
                (list)))))

(define (tunneler ssh-package
                  user
                  forwarding)
  "Returns a ssh tunneler Guix service using the
package SSH-PACKAGE, owned by the user named by the string USER,
defined by FORWARDING, a record of the <whispers-forwarding> type."
  (let* ((forwards (whispers-forwarding-forwards forwarding))
         (lieutenant-path (string-append "/ssh/"
                                         (user-container-name user)
                                         "/tunneler"))
         (nprefix (whispers-forwarding-name-prefix forwarding))
         (suffix? (whispers-forwarding-suffix-name? forwarding))
         (agent? (whispers-forwarding-use-agent? forwarding))
         (agent-socket (string-append (socket-folder-agent user)
                                      "/ssh-agent.sock"))
         (clear? (whispers-forwarding-clear-password? forwarding))
         (clear (whispers-forwarding-clear-password forwarding))
         (sshd-user (whispers-forwarding-sshd-user forwarding))
         (host (whispers-forwarding-sshd-host forwarding))
         (port (whispers-forwarding-sshd-port forwarding))
         (strict (whispers-forwarding-strict-check forwarding))
         (kh-files (whispers-forwarding-known-hosts-files forwarding))
         (sa-count-max (whispers-forwarding-server-alive-count-max
                        forwarding))
         (sa-int (whispers-forwarding-server-alive-interval forwarding))
         (resurrect? (whispers-forwarding-resurrect? forwarding))
         (resurrect-time (whispers-forwarding-resurrect-time-spec
                          forwarding))
         (force-resurrect? (whispers-forwarding-force-resurrect? forwarding))
         (force-resurrect-time (whispers-forwarding-force-resurrect-time-spec
                                forwarding))
         (timeout (whispers-forwarding-timeout forwarding))
         (stealth? (whispers-forwarding-stealth? forwarding))
         (stealth-prefix (whispers-forwarding-stealth-name-prefix
                          forwarding))
         (stealth-suffix? (whispers-forwarding-stealth-suffix-name?
                           forwarding))
         (stealth-agent? (whispers-forwarding-stealth-use-agent? forwarding))
         (stealth-clear? (whispers-forwarding-stealth-clear-password?
                          forwarding))
         (stealth-clear (whispers-forwarding-stealth-clear-password
                         forwarding))
         (stealth-sshd-user (whispers-forwarding-stealth-sshd-user
                             forwarding))
         (stealth-host (whispers-forwarding-stealth-sshd-host forwarding))
         (stealth-port (whispers-forwarding-stealth-sshd-port forwarding))
         (stealth-timeout (whispers-forwarding-stealth-timeout forwarding))
         (stealth-proxy-port (whispers-forwarding-stealth-proxy-port
                              forwarding))
         (stealth-strict (whispers-forwarding-stealth-strict-check
                          forwarding))
         (stealth-kh-files (whispers-forwarding-stealth-known-hosts-files
                            forwarding))
         (stealth-sa-count-max
          (whispers-forwarding-stealth-server-alive-count-max
           forwarding))
         (stealth-sa-int (whispers-forwarding-stealth-server-alive-interval
                          forwarding))
         (auto? (whispers-forwarding-auto-start? forwarding))
         (conn (forwarding->conn-strings forwarding)))
    (service
     persistent-ssh-service-type
     (ssh-connection-configuration
      (ssh-package ssh-package)
      (lieutenant? #t)
      (lieutenant-path lieutenant-path)
      (name-prefix nprefix)
      (suffix-name? suffix?)
      (agent? agent?)
      (agent-socket agent-socket)
      (clear-password? clear?)
      (sshd-user-password clear)
      (require-networking? #f)
      (pid-folder-override? #t)
      (pid-folder-override (base-folder-forwarding user (car conn)))
      (dedicated-log-file? #t)
      (log-folder-override? #t)
      (log-folder-override (log-folder-forwarding user (car conn)))
      (sshd-user sshd-user)
      (forwards forwards)
      (sshd-host host)
      (sshd-port port)
      (strict-check strict)
      (known-hosts-files kh-files)
      (server-alive-interval sa-int)
      (server-alive-count-max sa-count-max)
      (%cron-resurrect? resurrect?)
      (resurrect-time-spec resurrect-time)
      (%cron-force-resurrect? force-resurrect?)
      (force-resurrect-time-spec force-resurrect-time)
      (timeout-override? #t)
      (timeout-override timeout)
      (socks-proxy-config
       (socks-proxy-configuration
        (use-proxy? stealth?)
        (dynamic-forward
         (if stealth?
             (ssh-connection-configuration
              (ssh-package ssh-package)
              (lieutenant? #t)
              (lieutenant-path lieutenant-path)
              (name-prefix stealth-prefix)
              (suffix-name? stealth-suffix?)
              (agent? stealth-agent?)
              (agent-socket agent-socket)
              (clear-password? stealth-clear?)
              (sshd-user-password stealth-clear)
              (require-networking? #f)
              (pid-folder-override? #t)
              (pid-folder-override (base-folder-forwarding user (cadr conn)))
              (dedicated-log-file? #t)
              (log-folder-override? #t)
              (log-folder-override (log-folder-forwarding user (cadr conn)))
              (sshd-user stealth-sshd-user)
              (forwards
               (list (dynamic-forward-configuration
                      (entry-port stealth-proxy-port))))
              (sshd-host stealth-host)
              (sshd-port stealth-port)
              (strict-check stealth-strict)
              (known-hosts-files stealth-kh-files)
              (server-alive-interval stealth-sa-int)
              (server-alive-count-max stealth-sa-count-max)
              (timeout-override? #t)
              (timeout-override stealth-timeout)
              (%auto-start? auto?))
             #f))))
      (%auto-start? auto?)))))

(define (extra-actions-forwardings user group conn-list)
  "Return a list of <shepherd-action> records for the creation and
destruction of the folders and temporary file systems necessary for the
operation of the ssh tunneler connections owned by the user named by the
string USER to the remote defined by the list of strings
CONN-LIST. Group ownership of the folders and tmpfs goes to the group
named by the string GROUP."
  (list (shepherd-action
         (name 'pre-start)
         (documentation "Create the directories and tmpfs mounts
used by a tunneler connection.")
         (procedure
          #~(lambda (running)
              `#$(map (lambda (conn)
                        (list #~,(action 'tunneler
                                         'make-directory
                                         #$(log-folder-forwarding user
                                                                  conn)
                                         #$user
                                         #$group
                                         #$(number->string #o755
                                                           8))
                              ;; The let form is insuring that the
                              ;; parent folder is created before its
                              ;; sub-folder. Good idea, what could
                              ;; possibly go wrong with this
                              ;; clusterfuck?
                              #~,(let ((dummy
                                        (action 'tunneler
                                                'make-tmpfs
                                                #$(base-folder-forwarding
                                                   user
                                                   conn)
                                                #$user
                                                #$group
                                                #$(number->string #o755
                                                                  8))))
                                   (action 'tunneler
                                           'make-tmpfs
                                           #$(socket-folder-forwarding
                                              user
                                              conn)
                                           #$user
                                           #$group
                                           #$(number->string #o700
                                                             8)))))
                      conn-list))))
        (shepherd-action
         (name 'post-stop)
         (documentation "Unmount the tmpfs mounts used by a tunneler
 connection.")
         (procedure
          #~(lambda (running)
              `#$(map (lambda (conn)
                        ;; The let form is insuring that the parent
                        ;; folder is deleted after its
                        ;; sub-folder. Ditto.
                        (list #~,(let ((dummy
                                        (action 'tunneler
                                                'clear-tmpfs
                                                #$(socket-folder-forwarding
                                                   user
                                                   conn))))
                                   (action 'tunneler
                                           'clear-tmpfs
                                           #$(base-folder-forwarding
                                              user
                                              conn)))))
                      conn-list))))))

(define (tunnelers ssh-package user group forwardings)
  (service
   whispers-service-type
   (whispers-configuration (name 'tunneler)
                           (lieutenants (map (lambda (forwarding)
                                               (tunneler ssh-package
                                                         user
                                                         forwarding))
                                             forwardings))
                           (user user)
                           (group group)
                           (pre-start-action? #t)
                           (post-stop-action? #t)
                           (extra-actions
                            (extra-actions-forwardings
                             user
                             group
                             (apply append
                                    (map forwarding->conn-strings
                                         forwardings)))))))

(define (extra-actions-user user group)
  "Return a list of <shepherd-action> records for the creation and
destruction of the folders and temporary file systems necessary for the
operation of the ssh agent daemon of the user named by the string
USER. Group ownership of the folders and tmpfs goes to the group named
by the string GROUP."
  (let* ((user-str (user-container-name user))
         (user-sym (string->symbol user-str)))
    (list (shepherd-action
           (name 'pre-start)
           (documentation "Create the directories and tmpfs mounts
used by the ssh-agent.")
           (procedure
            #~(lambda (running)
                (action '#$user-sym
                        'make-directory
                        #$(log-folder-agent user-str)
                        #$user
                        #$group
                        #$(number->string #o755 8))
                (action '#$user-sym
                        'make-tmpfs
                        (string-append "/run/whispers/"
                                       "ssh/"
                                       #$user-str
                                       "/ssh-agent/")
                        #$user
                        #$group
                        #$(number->string #o755 8))
                (action '#$user-sym
                        'make-tmpfs
                        #$(socket-folder-agent user)
                        #$user
                        #$group
                        #$(number->string #o700 8)))))
          (shepherd-action
           (name 'post-stop)
           (documentation "Unmount the tmpfs mounts used by the ssh-agent.")
           (procedure
            #~(lambda (running)
                (action '#$user-sym
                        'clear-tmpfs
                        #$(socket-folder-agent user))
                (action '#$user-sym
                        'clear-tmpfs
                        (string-append "/run/whispers/"
                                       "ssh/"
                                       #$user-str
                                       "/ssh-agent"))))))))

(define (user-lieutenant agent?
                         tunneler?
                         user
                         group
                         keys
                         forwardings
                         ssh-package)
  "Returns a whispers sub-tree for a single user's section of a whispers
ssh sub-tree, owned by the user named by the string USER and the group
named by the string GROUP, at the tips of which a ssh agent service
rendering availbale the private keys defined by the list of strings KEYS
is daemonized when AGENT? evaluates to a true value, and/or ssh forwards
as defined by the <whispers-forwarding> type record FORWARDINGS are
daemonized when TUNNELER? evaluates to a true value. Those services are
provided by the programs of the package SSH-PACKAGE."
  (service whispers-service-type
           (whispers-configuration
            (name (string->symbol (user-container-name user)))
            (lieutenants (append (if agent?
                                     (list (agent ssh-package
                                                  user
                                                  keys))
                                     (list))
                                 (if tunneler?
                                     (list (tunnelers ssh-package
                                                      user
                                                      group
                                                      forwardings))
                                     (list))))
            (user user)
            (group group)
            (pre-start-action? #t)
            (post-stop-action? #t)
            (extra-actions (extra-actions-user user
                                               group)))))

(define (whispers-ssh-tree config)
  "Returns a whispers service tree for a whispers ssh sub-tree,
configurable by CONFIG, a record of the <whispers-ssh-configuration>
type."
  (let* ((ssh-package (whispers-ssh-configuration-ssh-package config))
         (ugks (whispers-ssh-configuration-users-groups-keys-forwards
                config))
         (user-group ssh-user-group-keys-forwards-user-and-group)
         (user (lambda (ugk)
                 (whispers-user-group-user (user-group ugk))))
         (group (lambda (ugk)
                  (whispers-user-group-group (user-group ugk))))
         (ag? (lambda (ugk)
                (ssh-user-group-keys-forwards-agent? ugk)))
         (keys (lambda (ugk)
                 (ssh-user-group-keys-forwards-keys ugk)))
         (tun? (lambda (ugk)
                 (ssh-user-group-keys-forwards-tunneler? ugk)))
         (fwds (lambda (ugk)
                 (ssh-user-group-keys-forwards-forwardings ugk))))
    (list (service whispers-service-type
                   (whispers-configuration
                    (name 'ssh)
                    (lieutenants (map (lambda (ugk)
                                        (user-lieutenant (ag? ugk)
                                                         (tun? ugk)
                                                         (user ugk)
                                                         (group ugk)
                                                         (keys ugk)
                                                         (fwds ugk)
                                                         ssh-package))
                                      ugks)))))))

(define whispers-ssh-service-type
  (service-type
   (name '(whispers-ssh))
   (description "Daemonized per-user ssh agents and ssh forwards")
   (extensions (list (service-extension whispers-service-type
                                        whispers-ssh-tree)))
   (default-value (whispers-ssh-configuration))))