gnu/machine/ssh.scm

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