gnu/machine/ssh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 machine ssh)
  20   #:use-module (gnu machine)
  21   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  22   #:use-module (gnu system)
  23   #:use-module (gnu system file-systems)
  24   #:use-module (gnu system uuid)
  25   #:use-module (guix diagnostics)
  26   #:use-module (guix gexp)
  27   #:use-module (guix i18n)
  28   #:use-module (guix modules)
  29   #:use-module (guix monads)
  30   #:use-module (guix records)
  31   #:use-module (guix remote)
  32   #:use-module (guix scripts system reconfigure)
  33   #:use-module (guix ssh)
  34   #:use-module (guix store)
  35   #:use-module (guix utils)
  36   #:use-module (ice-9 match)
  37   #:use-module (srfi srfi-19)
  38   #:use-module (srfi srfi-26)
  39   #:use-module (srfi srfi-35)
  40   #:export (managed-host-environment-type
  41
  42             machine-ssh-configuration
  43             machine-ssh-configuration?
  44             machine-ssh-configuration
  45
  46             machine-ssh-configuration-host-name
  47             machine-ssh-configuration-build-locally?
  48             machine-ssh-configuration-port
  49             machine-ssh-configuration-user
  50             machine-ssh-configuration-session))
  51
  52 ;;; Commentary:
  53 ;;;
  54 ;;; This module implements remote evaluation and system deployment for
  55 ;;; machines that are accessible over SSH and have a known host-name. In the
  56 ;;; sense of the broader "machine" interface, we describe the environment for
  57 ;;; such machines as 'managed-host.
  58 ;;;
  59 ;;; Code:
  60
  61 \f
  62 ;;;
  63 ;;; Parameters for the SSH client.
  64 ;;;
  65
  66 (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  67   make-machine-ssh-configuration
  68   machine-ssh-configuration?
  69   this-machine-ssh-configuration
  70   (host-name      machine-ssh-configuration-host-name) ; string
  71   (build-locally? machine-ssh-configuration-build-locally?
  72                   (default #t))
  73   (port           machine-ssh-configuration-port       ; integer
  74                   (default 22))
  75   (user           machine-ssh-configuration-user       ; string
  76                   (default "root"))
  77   (identity       machine-ssh-configuration-identity   ; path to a private key
  78                   (default #f))
  79   (session        machine-ssh-configuration-session    ; session
  80                   (default #f)))
  81
  82 (define (machine-ssh-session machine)
  83   "Return the SSH session that was given in MACHINE's configuration, or create
  84 one from the configuration's parameters if one was not provided."
  85   (maybe-raise-unsupported-configuration-error machine)
  86   (let ((config (machine-configuration machine)))
  87     (or (machine-ssh-configuration-session config)
  88         (let ((host-name (machine-ssh-configuration-host-name config))
  89               (user (machine-ssh-configuration-user config))
  90               (port (machine-ssh-configuration-port config))
  91               (identity (machine-ssh-configuration-identity config)))
  92           (open-ssh-session host-name
  93                             #:user user
  94                             #:port port
  95                             #:identity identity)))))
  96
  97 \f
  98 ;;;
  99 ;;; Remote evaluation.
 100 ;;;
 101
 102 (define (managed-host-remote-eval machine exp)
 103   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 104 an environment type of 'managed-host."
 105   (maybe-raise-unsupported-configuration-error machine)
 106   (remote-eval exp (machine-ssh-session machine)
 107                #:build-locally?
 108                (machine-ssh-configuration-build-locally?
 109                 (machine-configuration machine))))
 110
 111 \f
 112 ;;;
 113 ;;; Safety checks.
 114 ;;;
 115
 116 (define (machine-check-file-system-availability machine)
 117   "Raise a '&message' error condition if any of the file-systems specified in
 118 MACHINE's 'system' declaration do not exist on the machine."
 119   (define file-systems
 120     (filter (lambda (fs)
 121               (and (file-system-mount? fs)
 122                    (not (member (file-system-type fs)
 123                                 %pseudo-file-system-types))
 124                    (not (memq 'bind-mount (file-system-flags fs)))))
 125             (operating-system-file-systems (machine-operating-system machine))))
 126
 127   (define (check-literal-file-system fs)
 128     (define remote-exp
 129       #~(catch 'system-error
 130           (lambda ()
 131             (stat #$(file-system-device fs))
 132             #t)
 133           (lambda args
 134             (system-error-errno args))))
 135
 136     (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
 137       (when (number? errno)
 138         (raise (condition
 139                 (&message
 140                  (message (format #f (G_ "device '~a' not found: ~a")
 141                                   (file-system-device fs)
 142                                   (strerror errno)))))))
 143       (return #t)))
 144
 145   (define (check-labeled-file-system fs)
 146     (define remote-exp
 147       (with-imported-modules '((gnu build file-systems))
 148         #~(begin
 149             (use-modules (gnu build file-systems))
 150             (find-partition-by-label #$(file-system-label->string
 151                                         (file-system-device fs))))))
 152
 153     (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
 154       (unless result
 155         (raise (condition
 156                 (&message
 157                  (message (format #f (G_ "no file system with label '~a'")
 158                                   (file-system-label->string
 159                                    (file-system-device fs))))))))
 160       (return #t)))
 161
 162   (define (check-uuid-file-system fs)
 163     (define remote-exp
 164       (with-imported-modules (source-module-closure
 165                               '((gnu build file-systems)
 166                                 (gnu system uuid)))
 167         #~(begin
 168             (use-modules (gnu build file-systems)
 169                          (gnu system uuid))
 170
 171             (define uuid
 172               (string->uuid #$(uuid->string (file-system-device fs))))
 173
 174             (find-partition-by-uuid uuid))))
 175
 176     (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
 177       (unless result
 178         (raise (condition
 179                 (&message
 180                  (message (format #f (G_ "no file system with UUID '~a'")
 181                                   (uuid->string (file-system-device fs))))))))
 182       (return #t)))
 183
 184   (mbegin %store-monad
 185     (mapm %store-monad check-literal-file-system
 186           (filter (lambda (fs)
 187                     (string? (file-system-device fs)))
 188                   file-systems))
 189     (mapm %store-monad check-labeled-file-system
 190           (filter (lambda (fs)
 191                     (file-system-label? (file-system-device fs)))
 192                   file-systems))
 193     (mapm %store-monad check-uuid-file-system
 194           (filter (lambda (fs)
 195               (uuid? (file-system-device fs)))
 196                   file-systems))))
 197
 198 (define (machine-check-initrd-modules machine)
 199   "Raise a '&message' error condition if any of the modules needed by
 200 'needed-for-boot' file systems in MACHINE are not available in the initrd."
 201   (define file-systems
 202     (filter file-system-needed-for-boot?
 203             (operating-system-file-systems (machine-operating-system machine))))
 204
 205   (define (missing-modules fs)
 206     (define remote-exp
 207       (let ((device (file-system-device fs)))
 208         (with-imported-modules (source-module-closure
 209                                 '((gnu build file-systems)
 210                                   (gnu build linux-modules)
 211                                   (gnu system uuid)))
 212           #~(begin
 213               (use-modules (gnu build file-systems)
 214                            (gnu build linux-modules)
 215                            (gnu system uuid))
 216
 217               (define dev
 218                 #$(cond ((string? device) device)
 219                         ((uuid? device) #~(find-partition-by-uuid
 220                                            (string->uuid
 221                                             #$(uuid->string device))))
 222                         ((file-system-label? device)
 223                          #~(find-partition-by-label
 224                             (file-system-label->string #$device)))))
 225
 226               (missing-modules dev '#$(operating-system-initrd-modules
 227                                        (machine-operating-system machine)))))))
 228     (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
 229       (return (list fs missing))))
 230
 231   (mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
 232     (for-each (match-lambda
 233                 ((fs missing)
 234                  (unless (null? missing)
 235                    (raise (condition
 236                            (&message
 237                             (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
 238                                              (file-system-device fs)
 239                                              missing))))))))
 240               device)
 241     (return #t)))
 242
 243 (define (check-deployment-sanity machine)
 244   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 245 'system' declaration would fail."
 246   (mbegin %store-monad
 247     (machine-check-file-system-availability machine)
 248     (machine-check-initrd-modules machine)))
 249
 250 \f
 251 ;;;
 252 ;;; System deployment.
 253 ;;;
 254
 255 (define (machine-boot-parameters machine)
 256   "Monadic procedure returning a list of 'boot-parameters' for the generations
 257 of MACHINE's system profile, ordered from most recent to oldest."
 258   (define bootable-kernel-arguments
 259     (@@ (gnu system) bootable-kernel-arguments))
 260
 261   (define remote-exp
 262     (with-extensions (list guile-gcrypt)
 263       (with-imported-modules (source-module-closure '((guix config)
 264                                                       (guix profiles)))
 265         #~(begin
 266             (use-modules (guix config)
 267                          (guix profiles)
 268                          (ice-9 textual-ports))
 269
 270             (define %system-profile
 271               (string-append %state-directory "/profiles/system"))
 272
 273             (define (read-file path)
 274               (call-with-input-file path
 275                 (lambda (port)
 276                   (get-string-all port))))
 277
 278             (map (lambda (generation)
 279                    (let* ((system-path (generation-file-name %system-profile
 280                                                              generation))
 281                           (boot-parameters-path (string-append system-path
 282                                                                "/parameters"))
 283                           (time (stat:mtime (lstat system-path))))
 284                      (list generation
 285                            system-path
 286                            time
 287                            (read-file boot-parameters-path))))
 288                  (reverse (generation-numbers %system-profile)))))))
 289
 290   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 291     (return
 292      (map (lambda (generation)
 293             (match generation
 294               ((generation system-path time serialized-params)
 295                (let* ((params (call-with-input-string serialized-params
 296                                 read-boot-parameters))
 297                       (root (boot-parameters-root-device params))
 298                       (label (boot-parameters-label params)))
 299                  (boot-parameters
 300                   (inherit params)
 301                   (label
 302                    (string-append label " (#"
 303                                   (number->string generation) ", "
 304                                   (let ((time (make-time time-utc 0 time)))
 305                                     (date->string (time-utc->date time)
 306                                                   "~Y-~m-~d ~H:~M"))
 307                                   ")"))
 308                   (kernel-arguments
 309                    (append (bootable-kernel-arguments system-path root)
 310                            (boot-parameters-kernel-arguments params))))))))
 311           generations))))
 312
 313 (define (deploy-managed-host machine)
 314   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 315 environment type of 'managed-host."
 316   (maybe-raise-unsupported-configuration-error machine)
 317   (mlet %store-monad ((_ (check-deployment-sanity machine))
 318                       (boot-parameters (machine-boot-parameters machine)))
 319     (let* ((os (machine-operating-system machine))
 320            (eval (cut machine-remote-eval machine <>))
 321            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 322            (bootloader-configuration (operating-system-bootloader os))
 323            (bootcfg (operating-system-bootcfg os menu-entries)))
 324       (mbegin %store-monad
 325         (switch-to-system eval os)
 326         (upgrade-shepherd-services eval os)
 327         (install-bootloader eval bootloader-configuration bootcfg)))))
 328
 329 \f
 330 ;;;
 331 ;;; Environment type.
 332 ;;;
 333
 334 (define managed-host-environment-type
 335   (environment-type
 336    (machine-remote-eval managed-host-remote-eval)
 337    (deploy-machine      deploy-managed-host)
 338    (name                'managed-host-environment-type)
 339    (description         "Provisioning for machines that are accessible over SSH
 340 and have a known host-name. This entails little more than maintaining an SSH
 341 connection to the host.")))
 342
 343 (define (maybe-raise-unsupported-configuration-error machine)
 344   "Raise an error if MACHINE's configuration is not an instance of
 345 <machine-ssh-configuration>."
 346   (let ((config (machine-configuration machine))
 347         (environment (environment-type-name (machine-environment machine))))
 348     (unless (and config (machine-ssh-configuration? config))
 349       (raise (condition
 350               (&message
 351                (message (format #f (G_ "unsupported machine configuration '~a'
 352 for environment of type '~a'")
 353                                 config
 354                                 environment))))))))