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                    (not (memq 'bind-mount (file-system-flags fs)))))
 176             (operating-system-file-systems (machine-operating-system machine))))
 177
 178   (define (check-literal-file-system fs)
 179     (remote-let ((errno #~(catch 'system-error
 180                             (lambda ()
 181                               (stat #$(file-system-device fs))
 182                               #t)
 183                             (lambda args
 184                               (system-error-errno args)))))
 185       (when (number? errno)
 186         (raise (formatted-message (G_ "device '~a' not found: ~a")
 187                                   (file-system-device fs)
 188                                   (strerror errno))))))
 189
 190   (define (check-labeled-file-system fs)
 191     (define remote-exp
 192       (with-imported-modules (source-module-closure
 193                               '((gnu build file-systems)))
 194         #~(begin
 195             (use-modules (gnu build file-systems))
 196             (find-partition-by-label #$(file-system-label->string
 197                                         (file-system-device fs))))))
 198
 199     (remote-let ((result remote-exp))
 200       (unless result
 201         (raise (formatted-message (G_ "no file system with label '~a'")
 202                                   (file-system-label->string
 203                                    (file-system-device fs)))))))
 204
 205   (define (check-uuid-file-system fs)
 206     (define remote-exp
 207       (with-imported-modules (source-module-closure
 208                               '((gnu build file-systems)
 209                                 (gnu system uuid)))
 210         #~(begin
 211             (use-modules (gnu build file-systems)
 212                          (gnu system uuid))
 213
 214             (let ((uuid (uuid #$(uuid->string (file-system-device fs))
 215                               '#$(uuid-type (file-system-device fs)))))
 216               (find-partition-by-uuid uuid)))))
 217
 218     (remote-let ((result remote-exp))
 219       (unless result
 220         (raise (formatted-message (G_ "no file system with UUID '~a'")
 221                                   (uuid->string (file-system-device fs)))))))
 222
 223   (append (map check-literal-file-system
 224                (filter (lambda (fs)
 225                          (string? (file-system-device fs)))
 226                        file-systems))
 227           (map check-labeled-file-system
 228                (filter (lambda (fs)
 229                          (file-system-label? (file-system-device fs)))
 230                        file-systems))
 231           (map check-uuid-file-system
 232                (filter (lambda (fs)
 233                          (uuid? (file-system-device fs)))
 234                        file-systems))))
 235
 236 (define (machine-check-initrd-modules machine)
 237   "Return a list of <remote-assertion> that raise a '&message' error condition
 238 if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
 239 not available in the initrd."
 240   (define file-systems
 241     (filter file-system-needed-for-boot?
 242             (operating-system-file-systems (machine-operating-system machine))))
 243
 244   (define (missing-modules fs)
 245     (define remote-exp
 246       (let ((device (file-system-device fs)))
 247         (with-imported-modules (source-module-closure
 248                                 '((gnu build file-systems)
 249                                   (gnu build linux-modules)
 250                                   (gnu system uuid)))
 251           #~(begin
 252               (use-modules (gnu build file-systems)
 253                            (gnu build linux-modules)
 254                            (gnu system uuid))
 255
 256               (define dev
 257                 #$(cond ((string? device) device)
 258                         ((uuid? device) #~(find-partition-by-uuid
 259                                            (string->uuid
 260                                             #$(uuid->string device))))
 261                         ((file-system-label? device)
 262                          #~(find-partition-by-label
 263                             #$(file-system-label->string device)))))
 264
 265               (missing-modules dev '#$(operating-system-initrd-modules
 266                                        (machine-operating-system machine)))))))
 267
 268     (remote-let ((missing remote-exp))
 269       (unless (null? missing)
 270         (raise (condition
 271                 (&message
 272                  (message (format #f (G_ "missing modules for ~a:~{ ~a~}~%")
 273                                   (file-system-device fs)
 274                                   missing))))))))
 275
 276   (map missing-modules file-systems))
 277
 278 (define* (machine-check-forward-update machine)
 279   "Check whether we are making a forward update for MACHINE.  Depending on its
 280 'allow-upgrades?' field, raise an error or display a warning if we are
 281 potentially downgrading it."
 282   (define config
 283     (machine-configuration machine))
 284
 285   (define validate-reconfigure
 286     (if (machine-ssh-configuration-allow-downgrades? config)
 287         warn-about-backward-reconfigure
 288         ensure-forward-reconfigure))
 289
 290   (remote-let ((provenance #~(call-with-input-file
 291                                  "/run/current-system/provenance"
 292                                read)))
 293     (define channels
 294       (sexp->system-provenance provenance))
 295
 296     (check-forward-update validate-reconfigure
 297                           #:current-channels channels)))
 298
 299 (define (machine-check-building-for-appropriate-system machine)
 300   "Raise a '&message' error condition if MACHINE is configured to be built
 301 locally and the 'system' field does not match the '%current-system' reported
 302 by MACHINE."
 303   (let ((config (machine-configuration machine))
 304         (system (remote-system (machine-ssh-session machine))))
 305     (when (and (machine-ssh-configuration-build-locally? config)
 306                (not (string= system (machine-ssh-configuration-system config))))
 307       (raise (formatted-message (G_ "incorrect target system\
 308  ('~a' was given, while the system reports that it is '~a')~%")
 309                                 (machine-ssh-configuration-system config)
 310                                 system)))))
 311
 312 (define (check-deployment-sanity machine)
 313   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 314 'system' declaration would fail."
 315   (define assertions
 316     (append (machine-check-file-system-availability machine)
 317             (machine-check-initrd-modules machine)
 318             (list (machine-check-forward-update machine))))
 319
 320   (define aggregate-exp
 321     ;; Gather all the expressions so that a single round-trip is enough to
 322     ;; evaluate all the ASSERTIONS remotely.
 323     #~(map (lambda (file)
 324              (false-if-exception (primitive-load file)))
 325            '#$(map (lambda (assertion)
 326                      (scheme-file "remote-assertion.scm"
 327                                   (remote-assertion-expression assertion)))
 328                    assertions)))
 329
 330   ;; First check MACHINE's system type--an incorrect value for 'system' would
 331   ;; cause subsequent invocations of 'remote-eval' to fail.
 332   (machine-check-building-for-appropriate-system machine)
 333
 334   (mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
 335     (for-each (lambda (proc value)
 336                 (proc value))
 337               (map remote-assertion-procedure assertions)
 338               values)
 339     (return #t)))
 340
 341 \f
 342 ;;;
 343 ;;; System deployment.
 344 ;;;
 345
 346 (define (machine-boot-parameters machine)
 347   "Monadic procedure returning a list of 'boot-parameters' for the generations
 348 of MACHINE's system profile, ordered from most recent to oldest."
 349   (define bootable-kernel-arguments
 350     (@@ (gnu system) bootable-kernel-arguments))
 351
 352   (define remote-exp
 353     (with-extensions (list guile-gcrypt)
 354       (with-imported-modules (source-module-closure '((guix config)
 355                                                       (guix profiles)))
 356         #~(begin
 357             (use-modules (guix config)
 358                          (guix profiles)
 359                          (ice-9 textual-ports))
 360
 361             (define %system-profile
 362               (string-append %state-directory "/profiles/system"))
 363
 364             (define (read-file path)
 365               (call-with-input-file path
 366                 (lambda (port)
 367                   (get-string-all port))))
 368
 369             (map (lambda (generation)
 370                    (let* ((system-path (generation-file-name %system-profile
 371                                                              generation))
 372                           (boot-parameters-path (string-append system-path
 373                                                                "/parameters"))
 374                           (time (stat:mtime (lstat system-path))))
 375                      (list generation
 376                            system-path
 377                            time
 378                            (read-file boot-parameters-path))))
 379                  (reverse (generation-numbers %system-profile)))))))
 380
 381   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 382     (return
 383      (map (lambda (generation)
 384             (match generation
 385               ((generation system-path time serialized-params)
 386                (let* ((params (call-with-input-string serialized-params
 387                                 read-boot-parameters))
 388                       (root (boot-parameters-root-device params))
 389                       (label (boot-parameters-label params)))
 390                  (boot-parameters
 391                   (inherit params)
 392                   (label
 393                    (string-append label " (#"
 394                                   (number->string generation) ", "
 395                                   (let ((time (make-time time-utc 0 time)))
 396                                     (date->string (time-utc->date time)
 397                                                   "~Y-~m-~d ~H:~M"))
 398                                   ")"))
 399                   (kernel-arguments
 400                    (append (bootable-kernel-arguments system-path root)
 401                            (boot-parameters-kernel-arguments params))))))))
 402           generations))))
 403
 404 (define-syntax-rule (with-roll-back should-roll-back? mbody ...)
 405   "Catch exceptions that arise when binding MBODY, a monadic expression in
 406 %STORE-MONAD, and collect their arguments in a &deploy-error condition, with
 407 the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
 408   (catch #t
 409     (lambda ()
 410       mbody ...)
 411     (lambda args
 412       (raise (condition (&deploy-error
 413                          (should-roll-back should-roll-back?)
 414                          (captured-args args)))))))
 415
 416 (define (deploy-managed-host machine)
 417   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 418 environment type of 'managed-host."
 419   (maybe-raise-unsupported-configuration-error machine)
 420   (when (machine-ssh-configuration-authorize?
 421          (machine-configuration machine))
 422     (unless (file-exists? %public-key-file)
 423       (raise (formatted-message (G_ "no signing key '~a'. \
 424 have you run 'guix archive --generate-key?'")
 425                                 %public-key-file)))
 426     (remote-authorize-signing-key (call-with-input-file %public-key-file
 427                                     (lambda (port)
 428                                       (string->canonical-sexp
 429                                        (get-string-all port))))
 430                                   (machine-ssh-session machine)
 431                                   (machine-become-command machine)))
 432   (mlet %store-monad ((_ (check-deployment-sanity machine))
 433                       (boot-parameters (machine-boot-parameters machine)))
 434     (let* ((os (machine-operating-system machine))
 435            (eval (cut machine-remote-eval machine <>))
 436            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 437            (bootloader-configuration (operating-system-bootloader os))
 438            (bootcfg (operating-system-bootcfg os menu-entries)))
 439       (mbegin %store-monad
 440         (with-roll-back #f
 441           (switch-to-system eval os))
 442         (with-roll-back #t
 443           (mbegin %store-monad
 444             (upgrade-shepherd-services eval os)
 445             (install-bootloader eval bootloader-configuration bootcfg)))))))
 446
 447 \f
 448 ;;;
 449 ;;; Roll-back.
 450 ;;;
 451
 452 (define (roll-back-managed-host machine)
 453   "Internal implementation of 'roll-back-machine' for MACHINE instances with
 454 an environment type of 'managed-host."
 455   (define remote-exp
 456     (with-extensions (list guile-gcrypt)
 457       (with-imported-modules (source-module-closure '((guix config)
 458                                                       (guix profiles)))
 459         #~(begin
 460             (use-modules (guix config)
 461                          (guix profiles))
 462
 463             (define %system-profile
 464               (string-append %state-directory "/profiles/system"))
 465
 466             (define target-generation
 467               (relative-generation %system-profile -1))
 468
 469             (if target-generation
 470                 (switch-to-generation %system-profile target-generation)
 471                 'error)))))
 472
 473   (define roll-back-failure
 474     (condition (&message (message (G_ "could not roll-back machine")))))
 475
 476   (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
 477                        (_ -> (if (< (length boot-parameters) 2)
 478                                  (raise roll-back-failure)))
 479                        (entries -> (map boot-parameters->menu-entry
 480                                         (list (second boot-parameters))))
 481                        (old-entries -> (map boot-parameters->menu-entry
 482                                             (drop boot-parameters 2)))
 483                        (bootloader -> (operating-system-bootloader
 484                                        (machine-operating-system machine)))
 485                        (bootcfg (lower-object
 486                                  ((bootloader-configuration-file-generator
 487                                    (bootloader-configuration-bootloader
 488                                     bootloader))
 489                                   bootloader entries
 490                                   #:old-entries old-entries)))
 491                        (remote-result (machine-remote-eval machine remote-exp)))
 492     (when (eqv? 'error remote-result)
 493       (raise roll-back-failure))))
 494
 495 \f
 496 ;;;
 497 ;;; Environment type.
 498 ;;;
 499
 500 (define managed-host-environment-type
 501   (environment-type
 502    (machine-remote-eval managed-host-remote-eval)
 503    (deploy-machine      deploy-managed-host)
 504    (roll-back-machine   roll-back-managed-host)
 505    (name                'managed-host-environment-type)
 506    (description         "Provisioning for machines that are accessible over SSH
 507 and have a known host-name. This entails little more than maintaining an SSH
 508 connection to the host.")))
 509
 510 (define (maybe-raise-unsupported-configuration-error machine)
 511   "Raise an error if MACHINE's configuration is not an instance of
 512 <machine-ssh-configuration>."
 513   (let ((config (machine-configuration machine))
 514         (environment (environment-type-name (machine-environment machine))))
 515     (unless (and config (machine-ssh-configuration? config))
 516       (raise (formatted-message (G_ "unsupported machine configuration '~a'
 517 for environment of type '~a'")
 518                                 config
 519                                 environment)))))
 520
 521 ;; Local Variables:
 522 ;; eval: (put 'remote-let 'scheme-indent-function 1)
 523 ;; End: