gnu/home/services/ssh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu home services ssh)
  20   #:use-module (guix gexp)
  21   #:use-module (guix records)
  22   #:use-module (guix diagnostics)
  23   #:use-module (guix i18n)
  24   #:use-module (gnu services)
  25   #:use-module (gnu services configuration)
  26   #:use-module (guix modules)
  27   #:use-module (gnu home services)
  28   #:use-module ((gnu home services utils)
  29                 #:select (object->camel-case-string))
  30   #:autoload   (gnu packages base) (glibc-utf8-locales)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-35)
  34   #:use-module (ice-9 match)
  35   #:export (home-openssh-configuration
  36             home-openssh-configuration-authorized-keys
  37             home-openssh-configuration-known-hosts
  38             home-openssh-configuration-hosts
  39
  40             openssh-host
  41             openssh-host-host-name
  42             openssh-host-identity-file
  43             openssh-host-name
  44             openssh-host-port
  45             openssh-host-user
  46             openssh-host-forward-x11?
  47             openssh-host-forward-x11-trusted?
  48             openssh-host-forward-agent?
  49             openssh-host-compression?
  50             openssh-host-proxy-command
  51             openssh-host-host-key-algorithms
  52             openssh-host-accepted-key-types
  53             openssh-host-extra-content
  54
  55             home-openssh-service-type))
  56
  57 (define (serialize-field-name name)
  58   (match name
  59     ('accepted-key-types "PubkeyAcceptedKeyTypes")
  60     (_
  61      (let ((name (let ((str (symbol->string name)))
  62                    (if (string-suffix? "?" str)
  63                        (string->symbol (string-drop-right str 1))
  64                        name))))
  65        (object->camel-case-string name 'upper)))))
  66
  67 (define (serialize-string field value)
  68   (string-append "  " (serialize-field-name field)
  69                  " " value "\n"))
  70
  71 (define (address-family? obj)
  72   (memv obj (list AF_INET AF_INET6)))
  73
  74 (define-maybe address-family)
  75
  76 (define (serialize-address-family field family)
  77   (if (maybe-value-set? family)
  78       (string-append "  " (serialize-field-name field) " "
  79                      (cond ((= family AF_INET) "inet")
  80                            ((= family AF_INET6) "inet6")
  81                            ;; The 'else' branch is unreachable.
  82                            (else (raise (condition (&error)))))
  83                      "\n")
  84       ""))
  85
  86 (define (natural-number? obj)
  87   (and (integer? obj) (exact? obj) (> obj 0)))
  88
  89 (define (serialize-natural-number field value)
  90   (string-append "  " (serialize-field-name field) " "
  91                  (number->string value) "\n"))
  92
  93 (define (serialize-boolean field value)
  94   (string-append "  " (serialize-field-name field) " "
  95                  (if value "yes" "no") "\n"))
  96
  97 (define-maybe string)
  98 (define-maybe natural-number)
  99
 100 (define (serialize-raw-configuration-string field value)
 101   (string-append value "\n"))
 102 (define raw-configuration-string? string?)
 103
 104 (define (string-list? lst)
 105   (and (pair? lst) (every string? lst)))
 106 (define (serialize-string-list field lst)
 107   (string-append "  " (serialize-field-name field) " "
 108                  (string-join lst ",") "\n"))
 109
 110 (define-maybe string-list)
 111
 112 (define-configuration openssh-host
 113   (name
 114    (string)
 115    "Name of this host declaration.")
 116   (host-name
 117    maybe-string
 118    "Host name---e.g., @code{\"foo.example.org\"} or @code{\"192.168.1.2\"}.")
 119   (address-family
 120    maybe-address-family
 121    "Address family to use when connecting to this host: one of
 122 @code{AF_INET} (for IPv4 only), @code{AF_INET6} (for IPv6 only).
 123 Additionally, the field can be left unset to allow any address family.")
 124   (identity-file
 125    maybe-string
 126    "The identity file to use---e.g.,
 127 @code{\"/home/charlie/.ssh/id_ed25519\"}.")
 128   (port
 129    maybe-natural-number
 130    "TCP port number to connect to.")
 131   (user
 132    maybe-string
 133    "User name on the remote host.")
 134   (forward-x11?
 135    (boolean #f)
 136    "Whether to forward remote client connections to the local X11 graphical
 137 display.")
 138   (forward-x11-trusted?
 139    (boolean #f)
 140    "Whether remote X11 clients have full access to the original X11 graphical
 141 display.")
 142   (forward-agent?
 143    (boolean #f)
 144    "Whether the authentication agent (if any) is forwarded to the remote
 145 machine.")
 146   (compression?
 147    (boolean #f)
 148    "Whether to compress data in transit.")
 149   (proxy-command
 150    maybe-string
 151    "The command to use to connect to the server.  As an example, a command
 152 to connect via an HTTP proxy at 192.0.2.0 would be: @code{\"nc -X
 153 connect -x 192.0.2.0:8080 %h %p\"}.")
 154   (host-key-algorithms
 155    maybe-string-list
 156    "The list of accepted host key algorithms---e.g.,
 157 @code{'(\"ssh-ed25519\")}.")
 158   (accepted-key-types
 159    maybe-string-list
 160    "The list of accepted user public key types.")
 161   (extra-content
 162    (raw-configuration-string "")
 163    "Extra content appended as-is to this @code{Host} block in
 164 @file{~/.ssh/config}."))
 165
 166 (define (serialize-openssh-host config)
 167   (define (openssh-host-name-field? field)
 168     (eq? (configuration-field-name field) 'name))
 169
 170   (string-append
 171    "Host " (openssh-host-name config) "\n"
 172    (string-concatenate
 173     (map (lambda (field)
 174            ((configuration-field-serializer field)
 175             (configuration-field-name field)
 176             ((configuration-field-getter field) config)))
 177          (remove openssh-host-name-field?
 178                  openssh-host-fields)))))
 179
 180 (define-record-type* <home-openssh-configuration>
 181   home-openssh-configuration make-home-openssh-configuration
 182   home-openssh-configuration?
 183   (authorized-keys home-openssh-configuration-authorized-keys ;list of file-like
 184                    (default '()))
 185   (known-hosts     home-openssh-configuration-known-hosts ;unspec | list of file-like
 186                    (default *unspecified*))
 187   (hosts           home-openssh-configuration-hosts   ;list of <openssh-host>
 188                    (default '())))
 189
 190 (define (openssh-configuration->string config)
 191   (string-join (map serialize-openssh-host
 192                     (home-openssh-configuration-hosts config))
 193                "\n"))
 194
 195 (define* (file-join name files #:optional (delimiter " "))
 196   "Return a file in the store called @var{name} that is the concatenation
 197 of all the file-like objects listed in @var{files}, with @var{delimited}
 198 inserted after each of them."
 199   (computed-file name
 200                  (with-imported-modules '((guix build utils))
 201                    #~(begin
 202                        (use-modules (guix build utils))
 203
 204                        ;; Support non-ASCII file names.
 205                        (setenv "GUIX_LOCPATH"
 206                                #+(file-append glibc-utf8-locales
 207                                               "/lib/locale"))
 208                        (setlocale LC_ALL "en_US.utf8")
 209
 210                        (call-with-output-file #$output
 211                          (lambda (output)
 212                            (for-each (lambda (file)
 213                                        (call-with-input-file file
 214                                          (lambda (input)
 215                                            (dump-port input output)))
 216                                        (display #$delimiter output))
 217                                      '#$files)))))))
 218
 219 (define (openssh-configuration-files config)
 220   (let ((config (plain-file "ssh.conf"
 221                             (openssh-configuration->string config)))
 222         (known-hosts (home-openssh-configuration-known-hosts config))
 223         (authorized-keys (file-join
 224                           "authorized_keys"
 225                           (home-openssh-configuration-authorized-keys config)
 226                           "\n")))
 227     `((".ssh/authorized_keys" ,authorized-keys)
 228       ,@(if (unspecified? known-hosts)
 229             '()
 230             `((".ssh/known_hosts"
 231                ,(file-join "known_hosts" known-hosts "\n"))))
 232       (".ssh/config" ,config))))
 233
 234 (define openssh-activation
 235   (with-imported-modules (source-module-closure
 236                           '((gnu build activation)))
 237     #~(begin
 238         (use-modules (gnu build activation))
 239
 240         ;; Make sure ~/.ssh is #o700.
 241         (let* ((home (getenv "HOME"))
 242                (dot-ssh (string-append home "/.ssh")))
 243           (mkdir-p/perms dot-ssh (getpw (getuid)) #o700)))))
 244
 245 (define home-openssh-service-type
 246   (service-type
 247    (name 'home-openssh)
 248    (extensions
 249     (list (service-extension home-files-service-type
 250                              openssh-configuration-files)
 251           (service-extension home-activation-service-type
 252                              (const openssh-activation))))
 253    (description "Configure the OpenSSH @acronym{SSH, secure shell} client
 254 by providing a @file{~/.ssh/config} file, which is honored by the OpenSSH
 255 client,@command{ssh}, and by other tools such as @command{guix deploy}.")
 256    (default-value (home-openssh-configuration))))