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