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 bootloader)
  21   #:use-module (gnu machine)
  22   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  23   #:use-module (gnu system)
  24   #:use-module (gnu system file-systems)
  25   #:use-module (gnu system uuid)
  26   #:use-module (guix diagnostics)
  27   #:use-module (guix gexp)
  28   #:use-module (guix i18n)
  29   #:use-module (guix modules)
  30   #:use-module (guix monads)
  31   #:use-module (guix pki)
  32   #:use-module (guix records)
  33   #:use-module (guix remote)
  34   #:use-module (guix scripts system reconfigure)
  35   #:use-module (guix ssh)
  36   #:use-module (guix store)
  37   #:use-module (guix utils)
  38   #:use-module (gcrypt pk-crypto)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 textual-ports)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-19)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-35)
  46   #:export (managed-host-environment-type
  47
  48             machine-ssh-configuration
  49             machine-ssh-configuration?
  50             machine-ssh-configuration
  51
  52             machine-ssh-configuration-host-name
  53             machine-ssh-configuration-build-locally?
  54             machine-ssh-configuration-authorize?
  55             machine-ssh-configuration-port
  56             machine-ssh-configuration-user
  57             machine-ssh-configuration-session))
  58
  59 ;;; Commentary:
  60 ;;;
  61 ;;; This module implements remote evaluation and system deployment for
  62 ;;; machines that are accessible over SSH and have a known host-name. In the
  63 ;;; sense of the broader "machine" interface, we describe the environment for
  64 ;;; such machines as 'managed-host.
  65 ;;;
  66 ;;; Code:
  67
  68 \f
  69 ;;;
  70 ;;; Parameters for the SSH client.
  71 ;;;
  72
  73 (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  74   make-machine-ssh-configuration
  75   machine-ssh-configuration?
  76   this-machine-ssh-configuration
  77   (host-name      machine-ssh-configuration-host-name)     ; string
  78   (system         machine-ssh-configuration-system)        ; string
  79   (build-locally? machine-ssh-configuration-build-locally? ; boolean
  80                   (default #t))
  81   (authorize?     machine-ssh-configuration-authorize?     ; boolean
  82                   (default #t))
  83   (port           machine-ssh-configuration-port           ; integer
  84                   (default 22))
  85   (user           machine-ssh-configuration-user           ; string
  86                   (default "root"))
  87   (identity       machine-ssh-configuration-identity       ; path to a private key
  88                   (default #f))
  89   (session        machine-ssh-configuration-session        ; session
  90                   (default #f)))
  91
  92 (define (machine-ssh-session machine)
  93   "Return the SSH session that was given in MACHINE's configuration, or create
  94 one from the configuration's parameters if one was not provided."
  95   (maybe-raise-unsupported-configuration-error machine)
  96   (let ((config (machine-configuration machine)))
  97     (or (machine-ssh-configuration-session config)
  98         (let ((host-name (machine-ssh-configuration-host-name config))
  99               (user (machine-ssh-configuration-user config))
 100               (port (machine-ssh-configuration-port config))
 101               (identity (machine-ssh-configuration-identity config)))
 102           (open-ssh-session host-name
 103                             #:user user
 104                             #:port port
 105                             #:identity identity)))))
 106
 107 \f
 108 ;;;
 109 ;;; Remote evaluation.
 110 ;;;
 111
 112 (define (machine-become-command machine)
 113   "Return as a list of strings the program and arguments necessary to run a
 114 shell command with escalated privileges for MACHINE's configuration."
 115   (if (string= "root" (machine-ssh-configuration-user
 116                        (machine-configuration machine)))
 117       '()
 118       '("/run/setuid-programs/sudo" "-n" "--")))
 119
 120 (define (managed-host-remote-eval machine exp)
 121   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 122 an environment type of 'managed-host."
 123   (maybe-raise-unsupported-configuration-error machine)
 124   (let ((config (machine-configuration machine)))
 125     (remote-eval exp (machine-ssh-session machine)
 126                  #:build-locally?
 127                  (machine-ssh-configuration-build-locally? config)
 128                  #:system
 129                  (machine-ssh-configuration-system config)
 130                  #:become-command
 131                  (machine-become-command machine))))
 132
 133 \f
 134 ;;;
 135 ;;; Safety checks.
 136 ;;;
 137
 138 (define (machine-check-file-system-availability machine)
 139   "Raise a '&message' error condition if any of the file-systems specified in
 140 MACHINE's 'system' declaration do not exist on the machine."
 141   (define file-systems
 142     (filter (lambda (fs)
 143               (and (file-system-mount? fs)
 144                    (not (member (file-system-type fs)
 145                                 %pseudo-file-system-types))
 146                    (not (memq 'bind-mount (file-system-flags fs)))))
 147             (operating-system-file-systems (machine-operating-system machine))))
 148
 149   (define (check-literal-file-system fs)
 150     (define remote-exp
 151       #~(catch 'system-error
 152           (lambda ()
 153             (stat #$(file-system-device fs))
 154             #t)
 155           (lambda args
 156             (system-error-errno args))))
 157
 158     (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
 159       (when (number? errno)
 160         (raise (condition
 161                 (&message
 162                  (message (format #f (G_ "device '~a' not found: ~a")
 163                                   (file-system-device fs)
 164                                   (strerror errno)))))))
 165       (return #t)))
 166
 167   (define (check-labeled-file-system fs)
 168     (define remote-exp
 169       (with-imported-modules (source-module-closure
 170                               '((gnu build file-systems)))
 171         #~(begin
 172             (use-modules (gnu build file-systems))
 173             (find-partition-by-label #$(file-system-label->string
 174                                         (file-system-device fs))))))
 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 label '~a'")
 181                                   (file-system-label->string
 182                                    (file-system-device fs))))))))
 183       (return #t)))
 184
 185   (define (check-uuid-file-system fs)
 186     (define remote-exp
 187       (with-imported-modules (source-module-closure
 188                               '((gnu build file-systems)
 189                                 (gnu system uuid)))
 190         #~(begin
 191             (use-modules (gnu build file-systems)
 192                          (gnu system uuid))
 193
 194             (define uuid
 195               (string->uuid #$(uuid->string (file-system-device fs))))
 196
 197             (find-partition-by-uuid uuid))))
 198
 199     (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
 200       (unless result
 201         (raise (condition
 202                 (&message
 203                  (message (format #f (G_ "no file system with UUID '~a'")
 204                                   (uuid->string (file-system-device fs))))))))
 205       (return #t)))
 206
 207   (mbegin %store-monad
 208     (mapm %store-monad check-literal-file-system
 209           (filter (lambda (fs)
 210                     (string? (file-system-device fs)))
 211                   file-systems))
 212     (mapm %store-monad check-labeled-file-system
 213           (filter (lambda (fs)
 214                     (file-system-label? (file-system-device fs)))
 215                   file-systems))
 216     (mapm %store-monad check-uuid-file-system
 217           (filter (lambda (fs)
 218               (uuid? (file-system-device fs)))
 219                   file-systems))))
 220
 221 (define (machine-check-initrd-modules machine)
 222   "Raise a '&message' error condition if any of the modules needed by
 223 'needed-for-boot' file systems in MACHINE are not available in the initrd."
 224   (define file-systems
 225     (filter file-system-needed-for-boot?
 226             (operating-system-file-systems (machine-operating-system machine))))
 227
 228   (define (missing-modules fs)
 229     (define remote-exp
 230       (let ((device (file-system-device fs)))
 231         (with-imported-modules (source-module-closure
 232                                 '((gnu build file-systems)
 233                                   (gnu build linux-modules)
 234                                   (gnu system uuid)))
 235           #~(begin
 236               (use-modules (gnu build file-systems)
 237                            (gnu build linux-modules)
 238                            (gnu system uuid))
 239
 240               (define dev
 241                 #$(cond ((string? device) device)
 242                         ((uuid? device) #~(find-partition-by-uuid
 243                                            (string->uuid
 244                                             #$(uuid->string device))))
 245                         ((file-system-label? device)
 246                          #~(find-partition-by-label
 247                             #$(file-system-label->string device)))))
 248
 249               (missing-modules dev '#$(operating-system-initrd-modules
 250                                        (machine-operating-system machine)))))))
 251     (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
 252       (return (list fs missing))))
 253
 254   (mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
 255     (for-each (match-lambda
 256                 ((fs missing)
 257                  (unless (null? missing)
 258                    (raise (condition
 259                            (&message
 260                             (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
 261                                              (file-system-device fs)
 262                                              missing))))))))
 263               device)
 264     (return #t)))
 265
 266 (define (machine-check-building-for-appropriate-system machine)
 267   "Raise a '&message' error condition if MACHINE is configured to be built
 268 locally and the 'system' field does not match the '%current-system' reported
 269 by MACHINE."
 270   (let ((config (machine-configuration machine))
 271         (system (remote-system (machine-ssh-session machine))))
 272     (when (and (machine-ssh-configuration-build-locally? config)
 273                (not (string= system (machine-ssh-configuration-system config))))
 274       (raise (condition
 275               (&message
 276                (message (format #f (G_ "incorrect target system \
 277 ('~a' was given, while the system reports that it is '~a')~%")
 278                                 (machine-ssh-configuration-system config)
 279                                 system)))))))
 280   (with-monad %store-monad (return #t)))
 281
 282 (define (check-deployment-sanity machine)
 283   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 284 'system' declaration would fail."
 285   ;; Order is important here -- an incorrect value for 'system' will cause
 286   ;; invocations of 'remote-eval' to fail.
 287   (mbegin %store-monad
 288     (machine-check-building-for-appropriate-system machine)
 289     (machine-check-file-system-availability machine)
 290     (machine-check-initrd-modules machine)))
 291
 292 \f
 293 ;;;
 294 ;;; System deployment.
 295 ;;;
 296
 297 (define (machine-boot-parameters machine)
 298   "Monadic procedure returning a list of 'boot-parameters' for the generations
 299 of MACHINE's system profile, ordered from most recent to oldest."
 300   (define bootable-kernel-arguments
 301     (@@ (gnu system) bootable-kernel-arguments))
 302
 303   (define remote-exp
 304     (with-extensions (list guile-gcrypt)
 305       (with-imported-modules (source-module-closure '((guix config)
 306                                                       (guix profiles)))
 307         #~(begin
 308             (use-modules (guix config)
 309                          (guix profiles)
 310                          (ice-9 textual-ports))
 311
 312             (define %system-profile
 313               (string-append %state-directory "/profiles/system"))
 314
 315             (define (read-file path)
 316               (call-with-input-file path
 317                 (lambda (port)
 318                   (get-string-all port))))
 319
 320             (map (lambda (generation)
 321                    (let* ((system-path (generation-file-name %system-profile
 322                                                              generation))
 323                           (boot-parameters-path (string-append system-path
 324                                                                "/parameters"))
 325                           (time (stat:mtime (lstat system-path))))
 326                      (list generation
 327                            system-path
 328                            time
 329                            (read-file boot-parameters-path))))
 330                  (reverse (generation-numbers %system-profile)))))))
 331
 332   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 333     (return
 334      (map (lambda (generation)
 335             (match generation
 336               ((generation system-path time serialized-params)
 337                (let* ((params (call-with-input-string serialized-params
 338                                 read-boot-parameters))
 339                       (root (boot-parameters-root-device params))
 340                       (label (boot-parameters-label params)))
 341                  (boot-parameters
 342                   (inherit params)
 343                   (label
 344                    (string-append label " (#"
 345                                   (number->string generation) ", "
 346                                   (let ((time (make-time time-utc 0 time)))
 347                                     (date->string (time-utc->date time)
 348                                                   "~Y-~m-~d ~H:~M"))
 349                                   ")"))
 350                   (kernel-arguments
 351                    (append (bootable-kernel-arguments system-path root)
 352                            (boot-parameters-kernel-arguments params))))))))
 353           generations))))
 354
 355 (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
 356   "Catch exceptions that arise when binding MBODY, a monadic expression in
 357 %STORE-MONAD, and collect their arguments in a &deploy-error condition, with
 358 the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
 359   (catch #t
 360     (lambda ()
 361       mbody ...)
 362     (lambda args
 363       (raise (condition (&deploy-error
 364                          (should-roll-back should-roll-back?)
 365                          (captured-args args)))))))
 366
 367 (define (deploy-managed-host machine)
 368   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 369 environment type of 'managed-host."
 370   (maybe-raise-unsupported-configuration-error machine)
 371   (when (machine-ssh-configuration-authorize?
 372          (machine-configuration machine))
 373     (unless (file-exists? %public-key-file)
 374       (raise (condition
 375               (&message
 376                (message (format #f (G_ "no signing key '~a'. \
 377 have you run 'guix archive --generate-key?'")
 378                                 %public-key-file))))))
 379     (remote-authorize-signing-key (call-with-input-file %public-key-file
 380                                     (lambda (port)
 381                                       (string->canonical-sexp
 382                                        (get-string-all port))))
 383                                   (machine-ssh-session machine)
 384                                   (machine-become-command machine)))
 385   (mlet %store-monad ((_ (check-deployment-sanity machine))
 386                       (boot-parameters (machine-boot-parameters machine)))
 387     (let* ((os (machine-operating-system machine))
 388            (eval (cut machine-remote-eval machine <>))
 389            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 390            (bootloader-configuration (operating-system-bootloader os))
 391            (bootcfg (operating-system-bootcfg os menu-entries)))
 392       (mbegin %store-monad
 393         (with-roll-back #f
 394           (switch-to-system eval os))
 395         (with-roll-back #t
 396           (mbegin %store-monad
 397             (upgrade-shepherd-services eval os)
 398             (install-bootloader eval bootloader-configuration bootcfg)))))))
 399
 400 \f
 401 ;;;
 402 ;;; Roll-back.
 403 ;;;
 404
 405 (define (roll-back-managed-host machine)
 406   "Internal implementation of 'roll-back-machine' for MACHINE instances with
 407 an environment type of 'managed-host."
 408   (define remote-exp
 409     (with-extensions (list guile-gcrypt)
 410       (with-imported-modules (source-module-closure '((guix config)
 411                                                       (guix profiles)))
 412         #~(begin
 413             (use-modules (guix config)
 414                          (guix profiles))
 415
 416             (define %system-profile
 417               (string-append %state-directory "/profiles/system"))
 418
 419             (define target-generation
 420               (relative-generation %system-profile -1))
 421
 422             (if target-generation
 423                 (switch-to-generation %system-profile target-generation)
 424                 'error)))))
 425
 426   (define roll-back-failure
 427     (condition (&message (message (G_ "could not roll-back machine")))))
 428
 429   (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
 430                        (_ -> (if (< (length boot-parameters) 2)
 431                                  (raise roll-back-failure)))
 432                        (entries -> (map boot-parameters->menu-entry
 433                                         (list (second boot-parameters))))
 434                        (old-entries -> (map boot-parameters->menu-entry
 435                                             (drop boot-parameters 2)))
 436                        (bootloader -> (operating-system-bootloader
 437                                        (machine-operating-system machine)))
 438                        (bootcfg (lower-object
 439                                  ((bootloader-configuration-file-generator
 440                                    (bootloader-configuration-bootloader
 441                                     bootloader))
 442                                   bootloader entries
 443                                   #:old-entries old-entries)))
 444                        (remote-result (machine-remote-eval machine remote-exp)))
 445     (when (eqv? 'error remote-result)
 446       (raise roll-back-failure))))
 447
 448 \f
 449 ;;;
 450 ;;; Environment type.
 451 ;;;
 452
 453 (define managed-host-environment-type
 454   (environment-type
 455    (machine-remote-eval managed-host-remote-eval)
 456    (deploy-machine      deploy-managed-host)
 457    (roll-back-machine   roll-back-managed-host)
 458    (name                'managed-host-environment-type)
 459    (description         "Provisioning for machines that are accessible over SSH
 460 and have a known host-name. This entails little more than maintaining an SSH
 461 connection to the host.")))
 462
 463 (define (maybe-raise-unsupported-configuration-error machine)
 464   "Raise an error if MACHINE's configuration is not an instance of
 465 <machine-ssh-configuration>."
 466   (let ((config (machine-configuration machine))
 467         (environment (environment-type-name (machine-environment machine))))
 468     (unless (and config (machine-ssh-configuration? config))
 469       (raise (condition
 470               (&message
 471                (message (format #f (G_ "unsupported machine configuration '~a'
 472 for environment of type '~a'")
 473                                 config
 474                                 environment))))))))