gnu/machine/ssh.scm

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