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 services)
  24   #:use-module (gnu services shepherd)
  25   #:use-module (gnu system)
  26   #:use-module (guix derivations)
  27   #:use-module (guix gexp)
  28   #:use-module (guix i18n)
  29   #:use-module (guix modules)
  30   #:use-module (guix monads)
  31   #:use-module (guix records)
  32   #:use-module (guix remote)
  33   #:use-module (guix ssh)
  34   #:use-module (guix store)
  35   #:use-module (ice-9 match)
  36   #:use-module (srfi srfi-19)
  37   #:use-module (srfi srfi-35)
  38   #:export (managed-host-environment-type
  39
  40             machine-ssh-configuration
  41             machine-ssh-configuration?
  42             machine-ssh-configuration
  43
  44             machine-ssh-configuration-host-name
  45             machine-ssh-configuration-port
  46             machine-ssh-configuration-user
  47             machine-ssh-configuration-session))
  48
  49 ;;; Commentary:
  50 ;;;
  51 ;;; This module implements remote evaluation and system deployment for
  52 ;;; machines that are accessible over SSH and have a known host-name. In the
  53 ;;; sense of the broader "machine" interface, we describe the environment for
  54 ;;; such machines as 'managed-host.
  55 ;;;
  56 ;;; Code:
  57
  58 \f
  59 ;;;
  60 ;;; Parameters for the SSH client.
  61 ;;;
  62
  63 (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  64   make-machine-ssh-configuration
  65   machine-ssh-configuration?
  66   this-machine-ssh-configuration
  67   (host-name machine-ssh-configuration-host-name) ; string
  68   (port      machine-ssh-configuration-port       ; integer
  69              (default 22))
  70   (user      machine-ssh-configuration-user       ; string
  71              (default "root"))
  72   (identity  machine-ssh-configuration-identity   ; path to a private key
  73              (default #f))
  74   (session   machine-ssh-configuration-session    ; session
  75              (default #f)))
  76
  77 (define (machine-ssh-session machine)
  78   "Return the SSH session that was given in MACHINE's configuration, or create
  79 one from the configuration's parameters if one was not provided."
  80   (maybe-raise-unsupported-configuration-error machine)
  81   (let ((config (machine-configuration machine)))
  82     (or (machine-ssh-configuration-session config)
  83         (let ((host-name (machine-ssh-configuration-host-name config))
  84               (user (machine-ssh-configuration-user config))
  85               (port (machine-ssh-configuration-port config))
  86               (identity (machine-ssh-configuration-identity config)))
  87           (open-ssh-session host-name
  88                             #:user user
  89                             #:port port
  90                             #:identity identity)))))
  91
  92 \f
  93 ;;;
  94 ;;; Remote evaluation.
  95 ;;;
  96
  97 (define (managed-host-remote-eval machine exp)
  98   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
  99 an environment type of 'managed-host."
 100   (maybe-raise-unsupported-configuration-error machine)
 101   (remote-eval exp (machine-ssh-session machine)))
 102
 103 \f
 104 ;;;
 105 ;;; System deployment.
 106 ;;;
 107
 108 (define (switch-to-system machine)
 109   "Monadic procedure creating a new generation on MACHINE and execute the
 110 activation script for the new system configuration."
 111   (define (remote-exp drv script)
 112     (with-extensions (list guile-gcrypt)
 113       (with-imported-modules (source-module-closure '((guix config)
 114                                                       (guix profiles)
 115                                                       (guix utils)))
 116         #~(begin
 117             (use-modules (guix config)
 118                          (guix profiles)
 119                          (guix utils))
 120
 121             (define %system-profile
 122               (string-append %state-directory "/profiles/system"))
 123
 124             (let* ((system #$drv)
 125                    (number (1+ (generation-number %system-profile)))
 126                    (generation (generation-file-name %system-profile number)))
 127               (switch-symlinks generation system)
 128               (switch-symlinks %system-profile generation)
 129               ;; The implementation of 'guix system reconfigure' saves the
 130               ;; load path and environment here. This is unnecessary here
 131               ;; because each invocation of 'remote-eval' runs in a distinct
 132               ;; Guile REPL.
 133               (setenv "GUIX_NEW_SYSTEM" system)
 134               ;; The activation script may write to stdout, which confuses
 135               ;; 'remote-eval' when it attempts to read a result from the
 136               ;; remote REPL. We work around this by forcing the output to a
 137               ;; string.
 138               (with-output-to-string
 139                 (lambda ()
 140                   (primitive-load #$script))))))))
 141
 142   (let* ((os (machine-system machine))
 143          (script (operating-system-activation-script os)))
 144     (mlet* %store-monad ((drv (operating-system-derivation os)))
 145       (machine-remote-eval machine (remote-exp drv script)))))
 146
 147 ;; XXX: Currently, this does NOT attempt to restart running services. This is
 148 ;; also the case with 'guix system reconfigure'.
 149 ;;
 150 ;; See <https://issues.guix.info/issue/33508>.
 151 (define (upgrade-shepherd-services machine)
 152   "Monadic procedure unloading and starting services on the remote as needed
 153 to realize the MACHINE's system configuration."
 154   (define target-services
 155     ;; Monadic expression evaluating to a list of (name output-path) pairs for
 156     ;; all of MACHINE's services.
 157     (mapm %store-monad
 158           (lambda (service)
 159             (mlet %store-monad ((file ((compose lower-object
 160                                                 shepherd-service-file)
 161                                        service)))
 162               (return (list (shepherd-service-canonical-name service)
 163                             (derivation->output-path file)))))
 164           (service-value
 165            (fold-services (operating-system-services (machine-system machine))
 166                           #:target-type shepherd-root-service-type))))
 167
 168   (define (remote-exp target-services)
 169     (with-imported-modules '((gnu services herd))
 170       #~(begin
 171           (use-modules (gnu services herd)
 172                        (srfi srfi-1))
 173
 174           (define running
 175             (filter live-service-running (current-services)))
 176
 177           (define (essential? service)
 178             ;; Return #t if SERVICE is essential and should not be unloaded
 179             ;; under any circumstance.
 180             (memq (first (live-service-provision service))
 181                   '(root shepherd)))
 182
 183           (define (obsolete? service)
 184             ;; Return #t if SERVICE can be safely unloaded.
 185             (and (not (essential? service))
 186                  (every (lambda (requirements)
 187                           (not (memq (first (live-service-provision service))
 188                                      requirements)))
 189                         (map live-service-requirement running))))
 190
 191           (define to-unload
 192             (filter obsolete?
 193                     (remove (lambda (service)
 194                               (memq (first (live-service-provision service))
 195                                     (map first '#$target-services)))
 196                             running)))
 197
 198           (define to-start
 199             (remove (lambda (service-pair)
 200                       (memq (first service-pair)
 201                             (map (compose first live-service-provision)
 202                                  running)))
 203                     '#$target-services))
 204
 205           ;; Unload obsolete services.
 206           (for-each (lambda (service)
 207                       (false-if-exception
 208                        (unload-service service)))
 209                     to-unload)
 210
 211           ;; Load the service files for any new services and start them.
 212           (load-services/safe (map second to-start))
 213           (for-each start-service (map first to-start))
 214
 215           #t)))
 216
 217   (mlet %store-monad ((target-services target-services))
 218     (machine-remote-eval machine (remote-exp target-services))))
 219
 220 (define (machine-boot-parameters machine)
 221   "Monadic procedure returning a list of 'boot-parameters' for the generations
 222 of MACHINE's system profile, ordered from most recent to oldest."
 223   (define bootable-kernel-arguments
 224     (@@ (gnu system) bootable-kernel-arguments))
 225
 226   (define remote-exp
 227     (with-extensions (list guile-gcrypt)
 228       (with-imported-modules (source-module-closure '((guix config)
 229                                                       (guix profiles)))
 230         #~(begin
 231             (use-modules (guix config)
 232                          (guix profiles)
 233                          (ice-9 textual-ports))
 234
 235             (define %system-profile
 236               (string-append %state-directory "/profiles/system"))
 237
 238             (define (read-file path)
 239               (call-with-input-file path
 240                 (lambda (port)
 241                   (get-string-all port))))
 242
 243             (map (lambda (generation)
 244                    (let* ((system-path (generation-file-name %system-profile
 245                                                              generation))
 246                           (boot-parameters-path (string-append system-path
 247                                                                "/parameters"))
 248                           (time (stat:mtime (lstat system-path))))
 249                      (list generation
 250                            system-path
 251                            time
 252                            (read-file boot-parameters-path))))
 253                  (reverse (generation-numbers %system-profile)))))))
 254
 255   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 256     (return
 257      (map (lambda (generation)
 258             (match generation
 259               ((generation system-path time serialized-params)
 260                (let* ((params (call-with-input-string serialized-params
 261                                 read-boot-parameters))
 262                       (root (boot-parameters-root-device params))
 263                       (label (boot-parameters-label params)))
 264                  (boot-parameters
 265                   (inherit params)
 266                   (label
 267                    (string-append label " (#"
 268                                   (number->string generation) ", "
 269                                   (let ((time (make-time time-utc 0 time)))
 270                                     (date->string (time-utc->date time)
 271                                                   "~Y-~m-~d ~H:~M"))
 272                                   ")"))
 273                   (kernel-arguments
 274                    (append (bootable-kernel-arguments system-path root)
 275                            (boot-parameters-kernel-arguments params))))))))
 276           generations))))
 277
 278 (define (install-bootloader machine)
 279   "Create a bootloader entry for the new system generation on MACHINE, and
 280 configure the bootloader to boot that generation by default."
 281   (define bootloader-installer-script
 282     (@@ (guix scripts system) bootloader-installer-script))
 283
 284   (define (remote-exp installer bootcfg bootcfg-file)
 285     (with-extensions (list guile-gcrypt)
 286       (with-imported-modules (source-module-closure '((gnu build install)
 287                                                       (guix store)
 288                                                       (guix utils)))
 289         #~(begin
 290             (use-modules (gnu build install)
 291                          (guix store)
 292                          (guix utils))
 293             (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
 294                    (temp-gc-root (string-append gc-root ".new")))
 295
 296               (switch-symlinks temp-gc-root gc-root)
 297
 298               (unless (false-if-exception
 299                        (begin
 300                          ;; The implementation of 'guix system reconfigure'
 301                          ;; saves the load path here. This is unnecessary here
 302                          ;; because each invocation of 'remote-eval' runs in a
 303                          ;; distinct Guile REPL.
 304                          (install-boot-config #$bootcfg #$bootcfg-file "/")
 305                          ;; The installation script may write to stdout, which
 306                          ;; confuses 'remote-eval' when it attempts to read a
 307                          ;; result from the remote REPL. We work around this
 308                          ;; by forcing the output to a string.
 309                          (with-output-to-string
 310                            (lambda ()
 311                              (primitive-load #$installer)))))
 312                 (delete-file temp-gc-root)
 313                 (error "failed to install bootloader"))
 314
 315               (rename-file temp-gc-root gc-root)
 316               #t)))))
 317
 318   (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
 319     (let* ((os (machine-system machine))
 320            (bootloader ((compose bootloader-configuration-bootloader
 321                                  operating-system-bootloader)
 322                         os))
 323            (bootloader-target (bootloader-configuration-target
 324                                (operating-system-bootloader os)))
 325            (installer (bootloader-installer-script
 326                        (bootloader-installer bootloader)
 327                        (bootloader-package bootloader)
 328                        bootloader-target
 329                        "/"))
 330            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 331            (bootcfg (operating-system-bootcfg os menu-entries))
 332            (bootcfg-file (bootloader-configuration-file bootloader)))
 333       (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
 334
 335 (define (deploy-managed-host machine)
 336   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 337 environment type of 'managed-host."
 338   (maybe-raise-unsupported-configuration-error machine)
 339   (mbegin %store-monad
 340     (switch-to-system machine)
 341     (upgrade-shepherd-services machine)
 342     (install-bootloader machine)))
 343
 344 \f
 345 ;;;
 346 ;;; Environment type.
 347 ;;;
 348
 349 (define managed-host-environment-type
 350   (environment-type
 351    (machine-remote-eval managed-host-remote-eval)
 352    (deploy-machine      deploy-managed-host)
 353    (name                'managed-host-environment-type)
 354    (description         "Provisioning for machines that are accessible over SSH
 355 and have a known host-name. This entails little more than maintaining an SSH
 356 connection to the host.")))
 357
 358 (define (maybe-raise-unsupported-configuration-error machine)
 359   "Raise an error if MACHINE's configuration is not an instance of
 360 <machine-ssh-configuration>."
 361   (let ((config (machine-configuration machine))
 362         (environment (environment-type-name (machine-environment machine))))
 363     (unless (and config (machine-ssh-configuration? config))
 364       (raise (condition
 365               (&message
 366                (message (format #f (G_ "unsupported machine configuration '~a'
 367 for environment of type '~a'")
 368                                 config
 369                                 environment))))))))