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