gnu/machine/ssh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
   3 ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu machine ssh)
  21   #:use-module (gnu bootloader)
  22   #:use-module (gnu machine)
  23   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  24   #:use-module (gnu system)
  25   #:use-module (gnu system file-systems)
  26   #:use-module (gnu system uuid)
  27   #:use-module ((gnu services) #:select (sexp->system-provenance))
  28   #:use-module (guix diagnostics)
  29   #:use-module (guix gexp)
  30   #:use-module (guix i18n)
  31   #:use-module (guix modules)
  32   #:use-module (guix monads)
  33   #:use-module (guix pki)
  34   #:use-module (guix records)
  35   #:use-module (guix remote)
  36   #:use-module (guix scripts system reconfigure)
  37   #:use-module (guix ssh)
  38   #:use-module (guix store)
  39   #:use-module (guix utils)
  40   #:use-module (gcrypt pk-crypto)
  41   #:use-module (ice-9 format)
  42   #:use-module (ice-9 match)
  43   #:use-module (ice-9 textual-ports)
  44   #:use-module (srfi srfi-1)
  45   #:use-module (srfi srfi-9)
  46   #:use-module (srfi srfi-19)
  47   #:use-module (srfi srfi-26)
  48   #:use-module (srfi srfi-34)
  49   #:use-module (srfi srfi-35)
  50   #:export (managed-host-environment-type
  51
  52             machine-ssh-configuration
  53             machine-ssh-configuration?
  54             machine-ssh-configuration
  55
  56             machine-ssh-configuration-host-name
  57             machine-ssh-configuration-build-locally?
  58             machine-ssh-configuration-authorize?
  59             machine-ssh-configuration-allow-downgrades?
  60             machine-ssh-configuration-port
  61             machine-ssh-configuration-user
  62             machine-ssh-configuration-host-key
  63             machine-ssh-configuration-session))
  64
  65 ;;; Commentary:
  66 ;;;
  67 ;;; This module implements remote evaluation and system deployment for
  68 ;;; machines that are accessible over SSH and have a known host-name. In the
  69 ;;; sense of the broader "machine" interface, we describe the environment for
  70 ;;; such machines as 'managed-host.
  71 ;;;
  72 ;;; Code:
  73
  74 \f
  75 ;;;
  76 ;;; Parameters for the SSH client.
  77 ;;;
  78
  79 (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  80   make-machine-ssh-configuration
  81   machine-ssh-configuration?
  82   (host-name      machine-ssh-configuration-host-name)     ; string
  83   (system         machine-ssh-configuration-system)        ; string
  84   (build-locally? machine-ssh-configuration-build-locally? ; boolean
  85                   (default #t))
  86   (authorize?     machine-ssh-configuration-authorize?     ; boolean
  87                   (default #t))
  88   (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
  89                      (default #f))
  90   (port           machine-ssh-configuration-port           ; integer
  91                   (default 22))
  92   (user           machine-ssh-configuration-user           ; string
  93                   (default "root"))
  94   (identity       machine-ssh-configuration-identity       ; path to a private key
  95                   (default #f))
  96   (session        machine-ssh-configuration-session        ; session
  97                   (default #f))
  98   (host-key       machine-ssh-configuration-host-key       ; #f | string
  99                   (default #f)))
 100
 101 (define (machine-ssh-session machine)
 102   "Return the SSH session that was given in MACHINE's configuration, or create
 103 one from the configuration's parameters if one was not provided."
 104   (maybe-raise-unsupported-configuration-error machine)
 105   (let ((config (machine-configuration machine)))
 106     (or (machine-ssh-configuration-session config)
 107         (let ((host-name (machine-ssh-configuration-host-name config))
 108               (user (machine-ssh-configuration-user config))
 109               (port (machine-ssh-configuration-port config))
 110               (identity (machine-ssh-configuration-identity config))
 111               (host-key (machine-ssh-configuration-host-key config)))
 112           (unless host-key
 113             (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
 114 is deprecated~%")))
 115           (open-ssh-session host-name
 116                             #:user user
 117                             #:port port
 118                             #:identity identity
 119                             #:host-key host-key)))))
 120
 121 \f
 122 ;;;
 123 ;;; Remote evaluation.
 124 ;;;
 125
 126 (define (machine-become-command machine)
 127   "Return as a list of strings the program and arguments necessary to run a
 128 shell command with escalated privileges for MACHINE's configuration."
 129   (if (string= "root" (machine-ssh-configuration-user
 130                        (machine-configuration machine)))
 131       '()
 132       '("/run/setuid-programs/sudo" "-n" "--")))
 133
 134 (define (managed-host-remote-eval machine exp)
 135   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 136 an environment type of 'managed-host."
 137   (maybe-raise-unsupported-configuration-error machine)
 138   (let ((config (machine-configuration machine)))
 139     (remote-eval exp (machine-ssh-session machine)
 140                  #:build-locally?
 141                  (machine-ssh-configuration-build-locally? config)
 142                  #:system
 143                  (machine-ssh-configuration-system config)
 144                  #:become-command
 145                  (machine-become-command machine))))
 146
 147 \f
 148 ;;;
 149 ;;; Safety checks.
 150 ;;;
 151
 152 ;; Assertion to be executed remotely.  This abstraction exists to allow us to
 153 ;; gather a list of expressions to be evaluated and eventually evaluate them
 154 ;; all at once instead of one by one.  (This is pretty much a monad.)
 155 (define-record-type <remote-assertion>
 156   (remote-assertion exp proc)
 157   remote-assertion?
 158   (exp   remote-assertion-expression)
 159   (proc  remote-assertion-procedure))
 160
 161 (define-syntax-rule (remote-let ((var exp)) body ...)
 162   "Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
 163 a gexp, remotely, and evaluate BODY in that context."
 164   (remote-assertion exp (lambda (var) body ...)))
 165
 166 (define (machine-check-file-system-availability machine)
 167   "Return a list of <remote-assertion> that raise a '&message' error condition
 168 if any of the file-systems specified in MACHINE's 'system' declaration do not
 169 exist on the machine."
 170   (define file-systems
 171     (filter (lambda (fs)
 172               (and (file-system-mount? fs)
 173                    (not (member (file-system-type fs)
 174                                 %pseudo-file-system-types))
 175                    ;; Don't try to validate network file systems.
 176                    (not (string-prefix? "nfs" (file-system-type fs)))
 177                    (not (memq 'bind-mount (file-system-flags fs)))))
 178             (operating-system-file-systems (machine-operating-system machine))))
 179
 180   (define (check-literal-file-system fs)
 181     (remote-let ((errno #~(catch 'system-error
 182                             (lambda ()
 183                               (stat #$(file-system-device fs))
 184                               #t)
 185                             (lambda args
 186                               (system-error-errno args)))))
 187       (when (number? errno)
 188         (raise (formatted-message (G_ "device '~a' not found: ~a")
 189                                   (file-system-device fs)
 190                                   (strerror errno))))))
 191
 192   (define (check-labeled-file-system fs)
 193     (define remote-exp
 194       (with-imported-modules (source-module-closure
 195                               '((gnu build file-systems)))
 196         #~(begin
 197             (use-modules (gnu build file-systems))
 198             (find-partition-by-label #$(file-system-label->string
 199                                         (file-system-device fs))))))
 200
 201     (remote-let ((result remote-exp))
 202       (unless result
 203         (raise (formatted-message (G_ "no file system with label '~a'")
 204                                   (file-system-label->string
 205                                    (file-system-device fs)))))))
 206
 207   (define (check-uuid-file-system fs)
 208     (define remote-exp
 209       (with-imported-modules (source-module-closure
 210                               '((gnu build file-systems)
 211                                 (gnu system uuid)))
 212         #~(begin
 213             (use-modules (gnu build file-systems)
 214                          (gnu system uuid))
 215
 216             (let ((uuid (uuid #$(uuid->string (file-system-device fs))
 217                               '#$(uuid-type (file-system-device fs)))))
 218               (find-partition-by-uuid uuid)))))
 219
 220     (remote-let ((result remote-exp))
 221       (unless result
 222         (raise (formatted-message (G_ "no file system with UUID '~a'")
 223                                   (uuid->string (file-system-device fs)))))))
 224
 225   (append (map check-literal-file-system
 226                (filter (lambda (fs)
 227                          (string? (file-system-device fs)))
 228                        file-systems))
 229           (map check-labeled-file-system
 230                (filter (lambda (fs)
 231                          (file-system-label? (file-system-device fs)))
 232                        file-systems))
 233           (map check-uuid-file-system
 234                (filter (lambda (fs)
 235                          (uuid? (file-system-device fs)))
 236                        file-systems))))
 237
 238 (define (machine-check-initrd-modules machine)
 239   "Return a list of <remote-assertion> that raise a '&message' error condition
 240 if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
 241 not available in the initrd."
 242   (define file-systems
 243     (filter file-system-needed-for-boot?
 244             (operating-system-file-systems (machine-operating-system machine))))
 245
 246   (define (missing-modules fs)
 247     (define remote-exp
 248       (let ((device (file-system-device fs)))
 249         (with-imported-modules (source-module-closure
 250                                 '((gnu build file-systems)
 251                                   (gnu build linux-modules)
 252                                   (gnu system uuid)))
 253           #~(begin
 254               (use-modules (gnu build file-systems)
 255                            (gnu build linux-modules)
 256                            (gnu system uuid))
 257
 258               (define dev
 259                 #$(cond ((string? device) device)
 260                         ((uuid? device) #~(find-partition-by-uuid
 261                                            (string->uuid
 262                                             #$(uuid->string device))))
 263                         ((file-system-label? device)
 264                          #~(find-partition-by-label
 265                             #$(file-system-label->string device)))))
 266
 267               (missing-modules dev '#$(operating-system-initrd-modules
 268                                        (machine-operating-system machine)))))))
 269
 270     (remote-let ((missing remote-exp))
 271       (unless (null? missing)
 272         (raise (condition
 273                 (&message
 274                  (message (format #f (G_ "missing modules for ~a:~{ ~a~}~%")
 275                                   (file-system-device fs)
 276                                   missing))))))))
 277
 278   (map missing-modules file-systems))
 279
 280 (define* (machine-check-forward-update machine)
 281   "Check whether we are making a forward update for MACHINE.  Depending on its
 282 'allow-upgrades?' field, raise an error or display a warning if we are
 283 potentially downgrading it."
 284   (define config
 285     (machine-configuration machine))
 286
 287   (define validate-reconfigure
 288     (if (machine-ssh-configuration-allow-downgrades? config)
 289         warn-about-backward-reconfigure
 290         ensure-forward-reconfigure))
 291
 292   (remote-let ((provenance #~(call-with-input-file
 293                                  "/run/current-system/provenance"
 294                                read)))
 295     (define channels
 296       (sexp->system-provenance provenance))
 297
 298     (check-forward-update validate-reconfigure
 299                           #:current-channels channels)))
 300
 301 (define (machine-check-building-for-appropriate-system machine)
 302   "Raise a '&message' error condition if MACHINE is configured to be built
 303 locally and the 'system' field does not match the '%current-system' reported
 304 by MACHINE."
 305   (let ((config (machine-configuration machine))
 306         (system (remote-system (machine-ssh-session machine))))
 307     (when (and (machine-ssh-configuration-build-locally? config)
 308                (not (string= system (machine-ssh-configuration-system config))))
 309       (raise (formatted-message (G_ "incorrect target system\
 310  ('~a' was given, while the system reports that it is '~a')~%")
 311                                 (machine-ssh-configuration-system config)
 312                                 system)))))
 313
 314 (define (check-deployment-sanity machine)
 315   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 316 'system' declaration would fail."
 317   (define assertions
 318     (append (machine-check-file-system-availability machine)
 319             (machine-check-initrd-modules machine)
 320             (list (machine-check-forward-update machine))))
 321
 322   (define aggregate-exp
 323     ;; Gather all the expressions so that a single round-trip is enough to
 324     ;; evaluate all the ASSERTIONS remotely.
 325     #~(map (lambda (file)
 326              (false-if-exception (primitive-load file)))
 327            '#$(map (lambda (assertion)
 328                      (scheme-file "remote-assertion.scm"
 329                                   (remote-assertion-expression assertion)))
 330                    assertions)))
 331
 332   ;; First check MACHINE's system type--an incorrect value for 'system' would
 333   ;; cause subsequent invocations of 'remote-eval' to fail.
 334   (machine-check-building-for-appropriate-system machine)
 335
 336   (mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
 337     (for-each (lambda (proc value)
 338                 (proc value))
 339               (map remote-assertion-procedure assertions)
 340               values)
 341     (return #t)))
 342
 343 \f
 344 ;;;
 345 ;;; System deployment.
 346 ;;;
 347
 348 (define (machine-boot-parameters machine)
 349   "Monadic procedure returning a list of 'boot-parameters' for the generations
 350 of MACHINE's system profile, ordered from most recent to oldest."
 351   (define bootable-kernel-arguments
 352     (@@ (gnu system) bootable-kernel-arguments))
 353
 354   (define remote-exp
 355     (with-extensions (list guile-gcrypt)
 356       (with-imported-modules (source-module-closure '((guix config)
 357                                                       (guix profiles)))
 358         #~(begin
 359             (use-modules (guix config)
 360                          (guix profiles)
 361                          (ice-9 textual-ports))
 362
 363             (define %system-profile
 364               (string-append %state-directory "/profiles/system"))
 365
 366             (define (read-file path)
 367               (call-with-input-file path
 368                 (lambda (port)
 369                   (get-string-all port))))
 370
 371             (map (lambda (generation)
 372                    (let* ((system-path (generation-file-name %system-profile
 373                                                              generation))
 374                           (boot-parameters-path (string-append system-path
 375                                                                "/parameters"))
 376                           (time (stat:mtime (lstat system-path))))
 377                      (list generation
 378                            system-path
 379                            time
 380                            (read-file boot-parameters-path))))
 381                  (reverse (generation-numbers %system-profile)))))))
 382
 383   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 384     (return
 385      (map (lambda (generation)
 386             (match generation
 387               ((generation system-path time serialized-params)
 388                (let* ((params (call-with-input-string serialized-params
 389                                 read-boot-parameters))
 390                       (root (boot-parameters-root-device params))
 391                       (label (boot-parameters-label params)))
 392                  (boot-parameters
 393                   (inherit params)
 394                   (label
 395                    (string-append label " (#"
 396                                   (number->string generation) ", "
 397                                   (let ((time (make-time time-utc 0 time)))
 398                                     (date->string (time-utc->date time)
 399                                                   "~Y-~m-~d ~H:~M"))
 400                                   ")"))
 401                   (kernel-arguments
 402                    (append (bootable-kernel-arguments system-path root)
 403                            (boot-parameters-kernel-arguments params))))))))
 404           generations))))
 405
 406 (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
 407   "Catch exceptions that arise when binding MBODY, a monadic expression in
 408 %STORE-MONAD, and collect their arguments in a &deploy-error condition, with
 409 the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
 410   (catch #t
 411     (lambda ()
 412       mbody ...)
 413     (lambda args
 414       (raise (condition (&deploy-error
 415                          (should-roll-back should-roll-back?)
 416                          (captured-args args)))))))
 417
 418 (define (deploy-managed-host machine)
 419   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 420 environment type of 'managed-host."
 421   (maybe-raise-unsupported-configuration-error machine)
 422   (when (machine-ssh-configuration-authorize?
 423          (machine-configuration machine))
 424     (unless (file-exists? %public-key-file)
 425       (raise (formatted-message (G_ "no signing key '~a'. \
 426 have you run 'guix archive --generate-key?'")
 427                                 %public-key-file)))
 428     (remote-authorize-signing-key (call-with-input-file %public-key-file
 429                                     (lambda (port)
 430                                       (string->canonical-sexp
 431                                        (get-string-all port))))
 432                                   (machine-ssh-session machine)
 433                                   (machine-become-command machine)))
 434   (mlet %store-monad ((_ (check-deployment-sanity machine))
 435                       (boot-parameters (machine-boot-parameters machine)))
 436     (let* ((os (machine-operating-system machine))
 437            (eval (cut machine-remote-eval machine <>))
 438            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 439            (bootloader-configuration (operating-system-bootloader os))
 440            (bootcfg (operating-system-bootcfg os menu-entries)))
 441       (mbegin %store-monad
 442         (with-roll-back #f
 443           (switch-to-system eval os))
 444         (with-roll-back #t
 445           (mbegin %store-monad
 446             (upgrade-shepherd-services eval os)
 447             (install-bootloader eval bootloader-configuration bootcfg)))))))
 448
 449 \f
 450 ;;;
 451 ;;; Roll-back.
 452 ;;;
 453
 454 (define (roll-back-managed-host machine)
 455   "Internal implementation of 'roll-back-machine' for MACHINE instances with
 456 an environment type of 'managed-host."
 457   (define remote-exp
 458     (with-extensions (list guile-gcrypt)
 459       (with-imported-modules (source-module-closure '((guix config)
 460                                                       (guix profiles)))
 461         #~(begin
 462             (use-modules (guix config)
 463                          (guix profiles))
 464
 465             (define %system-profile
 466               (string-append %state-directory "/profiles/system"))
 467
 468             (define target-generation
 469               (relative-generation %system-profile -1))
 470
 471             (if target-generation
 472                 (switch-to-generation %system-profile target-generation)
 473                 'error)))))
 474
 475   (define roll-back-failure
 476     (condition (&message (message (G_ "could not roll-back machine")))))
 477
 478   (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
 479                        (_ -> (if (< (length boot-parameters) 2)
 480                                  (raise roll-back-failure)))
 481                        (entries -> (map boot-parameters->menu-entry
 482                                         (list (second boot-parameters))))
 483                        (locale -> (boot-parameters-locale
 484                                    (second boot-parameters)))
 485                        (old-entries -> (map boot-parameters->menu-entry
 486                                             (drop boot-parameters 2)))
 487                        (bootloader -> (operating-system-bootloader
 488                                        (machine-operating-system machine)))
 489                        (bootcfg (lower-object
 490                                  ((bootloader-configuration-file-generator
 491                                    (bootloader-configuration-bootloader
 492                                     bootloader))
 493                                   bootloader entries
 494                                   #:locale locale
 495                                   #:old-entries old-entries)))
 496                        (remote-result (machine-remote-eval machine remote-exp)))
 497     (when (eqv? 'error remote-result)
 498       (raise roll-back-failure))))
 499
 500 \f
 501 ;;;
 502 ;;; Environment type.
 503 ;;;
 504
 505 (define managed-host-environment-type
 506   (environment-type
 507    (machine-remote-eval managed-host-remote-eval)
 508    (deploy-machine      deploy-managed-host)
 509    (roll-back-machine   roll-back-managed-host)
 510    (name                'managed-host-environment-type)
 511    (description         "Provisioning for machines that are accessible over SSH
 512 and have a known host-name. This entails little more than maintaining an SSH
 513 connection to the host.")))
 514
 515 (define (maybe-raise-unsupported-configuration-error machine)
 516   "Raise an error if MACHINE's configuration is not an instance of
 517 <machine-ssh-configuration>."
 518   (let ((config (machine-configuration machine))
 519         (environment (environment-type-name (machine-environment machine))))
 520     (unless (and config (machine-ssh-configuration? config))
 521       (raise (formatted-message (G_ "unsupported machine configuration '~a'
 522 for environment of type '~a'")
 523                                 config
 524                                 environment)))))
 525
 526 ;; Local Variables:
 527 ;; eval: (put 'remote-let 'scheme-indent-function 1)
 528 ;; End: