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 machine)
  21   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  22   #:use-module (gnu system)
  23   #:use-module (gnu system file-systems)
  24   #:use-module (gnu system uuid)
  25   #:use-module (guix diagnostics)
  26   #:use-module (guix gexp)
  27   #:use-module (guix i18n)
  28   #:use-module (guix modules)
  29   #:use-module (guix monads)
  30   #:use-module (guix records)
  31   #:use-module (guix remote)
  32   #:use-module (guix scripts system reconfigure)
  33   #:use-module (guix ssh)
  34   #:use-module (guix store)
  35   #:use-module (guix utils)
  36   #:use-module (ice-9 match)
  37   #:use-module (srfi srfi-19)
  38   #:use-module (srfi srfi-26)
  39   #:use-module (srfi srfi-35)
  40   #:export (managed-host-environment-type
  41
  42             machine-ssh-configuration
  43             machine-ssh-configuration?
  44             machine-ssh-configuration
  45
  46             machine-ssh-configuration-host-name
  47             machine-ssh-configuration-port
  48             machine-ssh-configuration-user
  49             machine-ssh-configuration-session))
  50
  51 ;;; Commentary:
  52 ;;;
  53 ;;; This module implements remote evaluation and system deployment for
  54 ;;; machines that are accessible over SSH and have a known host-name. In the
  55 ;;; sense of the broader "machine" interface, we describe the environment for
  56 ;;; such machines as 'managed-host.
  57 ;;;
  58 ;;; Code:
  59
  60 \f
  61 ;;;
  62 ;;; Parameters for the SSH client.
  63 ;;;
  64
  65 (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  66   make-machine-ssh-configuration
  67   machine-ssh-configuration?
  68   this-machine-ssh-configuration
  69   (host-name machine-ssh-configuration-host-name) ; string
  70   (port      machine-ssh-configuration-port       ; integer
  71              (default 22))
  72   (user      machine-ssh-configuration-user       ; string
  73              (default "root"))
  74   (identity  machine-ssh-configuration-identity   ; path to a private key
  75              (default #f))
  76   (session   machine-ssh-configuration-session    ; session
  77              (default #f)))
  78
  79 (define (machine-ssh-session machine)
  80   "Return the SSH session that was given in MACHINE's configuration, or create
  81 one from the configuration's parameters if one was not provided."
  82   (maybe-raise-unsupported-configuration-error machine)
  83   (let ((config (machine-configuration machine)))
  84     (or (machine-ssh-configuration-session config)
  85         (let ((host-name (machine-ssh-configuration-host-name config))
  86               (user (machine-ssh-configuration-user config))
  87               (port (machine-ssh-configuration-port config))
  88               (identity (machine-ssh-configuration-identity config)))
  89           (open-ssh-session host-name
  90                             #:user user
  91                             #:port port
  92                             #:identity identity)))))
  93
  94 \f
  95 ;;;
  96 ;;; Remote evaluation.
  97 ;;;
  98
  99 (define (managed-host-remote-eval machine exp)
 100   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 101 an environment type of 'managed-host."
 102   (maybe-raise-unsupported-configuration-error machine)
 103   (remote-eval exp (machine-ssh-session machine)))
 104
 105 \f
 106 ;;;
 107 ;;; Safety checks.
 108 ;;;
 109
 110 (define (machine-check-file-system-availability machine)
 111   "Raise a '&message' error condition if any of the file-systems specified in
 112 MACHINE's 'system' declaration do not exist on the machine."
 113   (define file-systems
 114     (filter (lambda (fs)
 115               (and (file-system-mount? fs)
 116                    (not (member (file-system-type fs)
 117                                 %pseudo-file-system-types))
 118                    (not (memq 'bind-mount (file-system-flags fs)))))
 119             (operating-system-file-systems (machine-operating-system machine))))
 120
 121   (define (check-literal-file-system fs)
 122     (define remote-exp
 123       #~(catch 'system-error
 124           (lambda ()
 125             (stat #$(file-system-device fs))
 126             #t)
 127           (lambda args
 128             (system-error-errno args))))
 129
 130     (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
 131       (when (number? errno)
 132         (raise (condition
 133                 (&message
 134                  (message (format #f (G_ "device '~a' not found: ~a")
 135                                   (file-system-device fs)
 136                                   (strerror errno)))))))
 137       (return #t)))
 138
 139   (define (check-labeled-file-system fs)
 140     (define remote-exp
 141       (with-imported-modules '((gnu build file-systems))
 142         #~(begin
 143             (use-modules (gnu build file-systems))
 144             (find-partition-by-label #$(file-system-label->string
 145                                         (file-system-device fs))))))
 146
 147     (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
 148       (unless result
 149         (raise (condition
 150                 (&message
 151                  (message (format #f (G_ "no file system with label '~a'")
 152                                   (file-system-label->string
 153                                    (file-system-device fs))))))))
 154       (return #t)))
 155
 156   (define (check-uuid-file-system fs)
 157     (define remote-exp
 158       (with-imported-modules (source-module-closure
 159                               '((gnu build file-systems)
 160                                 (gnu system uuid)))
 161         #~(begin
 162             (use-modules (gnu build file-systems)
 163                          (gnu system uuid))
 164
 165             (define uuid
 166               (string->uuid #$(uuid->string (file-system-device fs))))
 167
 168             (find-partition-by-uuid uuid))))
 169
 170     (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
 171       (unless result
 172         (raise (condition
 173                 (&message
 174                  (message (format #f (G_ "no file system with UUID '~a'")
 175                                   (uuid->string (file-system-device fs))))))))
 176       (return #t)))
 177
 178   (mbegin %store-monad
 179     (mapm %store-monad check-literal-file-system
 180           (filter (lambda (fs)
 181                     (string? (file-system-device fs)))
 182                   file-systems))
 183     (mapm %store-monad check-labeled-file-system
 184           (filter (lambda (fs)
 185                     (file-system-label? (file-system-device fs)))
 186                   file-systems))
 187     (mapm %store-monad check-uuid-file-system
 188           (filter (lambda (fs)
 189               (uuid? (file-system-device fs)))
 190                   file-systems))))
 191
 192 (define (machine-check-initrd-modules machine)
 193   "Raise a '&message' error condition if any of the modules needed by
 194 'needed-for-boot' file systems in MACHINE are not available in the initrd."
 195   (define file-systems
 196     (filter file-system-needed-for-boot?
 197             (operating-system-file-systems (machine-operating-system machine))))
 198
 199   (define (missing-modules fs)
 200     (define remote-exp
 201       (let ((device (file-system-device fs)))
 202         (with-imported-modules (source-module-closure
 203                                 '((gnu build file-systems)
 204                                   (gnu build linux-modules)
 205                                   (gnu system uuid)))
 206           #~(begin
 207               (use-modules (gnu build file-systems)
 208                            (gnu build linux-modules)
 209                            (gnu system uuid))
 210
 211               (define dev
 212                 #$(cond ((string? device) device)
 213                         ((uuid? device) #~(find-partition-by-uuid
 214                                            (string->uuid
 215                                             #$(uuid->string device))))
 216                         ((file-system-label? device)
 217                          #~(find-partition-by-label
 218                             (file-system-label->string #$device)))))
 219
 220               (missing-modules dev '#$(operating-system-initrd-modules
 221                                        (machine-operating-system machine)))))))
 222     (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
 223       (return (list fs missing))))
 224
 225   (mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
 226     (for-each (match-lambda
 227                 ((fs missing)
 228                  (unless (null? missing)
 229                    (raise (condition
 230                            (&message
 231                             (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
 232                                              (file-system-device fs)
 233                                              missing))))))))
 234               device)
 235     (return #t)))
 236
 237 (define (check-deployment-sanity machine)
 238   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 239 'system' declaration would fail."
 240   (mbegin %store-monad
 241     (machine-check-file-system-availability machine)
 242     (machine-check-initrd-modules machine)))
 243
 244 \f
 245 ;;;
 246 ;;; System deployment.
 247 ;;;
 248
 249 (define (machine-boot-parameters machine)
 250   "Monadic procedure returning a list of 'boot-parameters' for the generations
 251 of MACHINE's system profile, ordered from most recent to oldest."
 252   (define bootable-kernel-arguments
 253     (@@ (gnu system) bootable-kernel-arguments))
 254
 255   (define remote-exp
 256     (with-extensions (list guile-gcrypt)
 257       (with-imported-modules (source-module-closure '((guix config)
 258                                                       (guix profiles)))
 259         #~(begin
 260             (use-modules (guix config)
 261                          (guix profiles)
 262                          (ice-9 textual-ports))
 263
 264             (define %system-profile
 265               (string-append %state-directory "/profiles/system"))
 266
 267             (define (read-file path)
 268               (call-with-input-file path
 269                 (lambda (port)
 270                   (get-string-all port))))
 271
 272             (map (lambda (generation)
 273                    (let* ((system-path (generation-file-name %system-profile
 274                                                              generation))
 275                           (boot-parameters-path (string-append system-path
 276                                                                "/parameters"))
 277                           (time (stat:mtime (lstat system-path))))
 278                      (list generation
 279                            system-path
 280                            time
 281                            (read-file boot-parameters-path))))
 282                  (reverse (generation-numbers %system-profile)))))))
 283
 284   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 285     (return
 286      (map (lambda (generation)
 287             (match generation
 288               ((generation system-path time serialized-params)
 289                (let* ((params (call-with-input-string serialized-params
 290                                 read-boot-parameters))
 291                       (root (boot-parameters-root-device params))
 292                       (label (boot-parameters-label params)))
 293                  (boot-parameters
 294                   (inherit params)
 295                   (label
 296                    (string-append label " (#"
 297                                   (number->string generation) ", "
 298                                   (let ((time (make-time time-utc 0 time)))
 299                                     (date->string (time-utc->date time)
 300                                                   "~Y-~m-~d ~H:~M"))
 301                                   ")"))
 302                   (kernel-arguments
 303                    (append (bootable-kernel-arguments system-path root)
 304                            (boot-parameters-kernel-arguments params))))))))
 305           generations))))
 306
 307 (define (deploy-managed-host machine)
 308   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 309 environment type of 'managed-host."
 310   (maybe-raise-unsupported-configuration-error machine)
 311   (mlet %store-monad ((_ (check-deployment-sanity machine))
 312                       (boot-parameters (machine-boot-parameters machine)))
 313     (let* ((os (machine-operating-system machine))
 314            (eval (cut machine-remote-eval machine <>))
 315            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 316            (bootloader-configuration (operating-system-bootloader os))
 317            (bootcfg (operating-system-bootcfg os menu-entries)))
 318       (mbegin %store-monad
 319         (switch-to-system eval os)
 320         (upgrade-shepherd-services eval os)
 321         (install-bootloader eval bootloader-configuration bootcfg)))))
 322
 323 \f
 324 ;;;
 325 ;;; Environment type.
 326 ;;;
 327
 328 (define managed-host-environment-type
 329   (environment-type
 330    (machine-remote-eval managed-host-remote-eval)
 331    (deploy-machine      deploy-managed-host)
 332    (name                'managed-host-environment-type)
 333    (description         "Provisioning for machines that are accessible over SSH
 334 and have a known host-name. This entails little more than maintaining an SSH
 335 connection to the host.")))
 336
 337 (define (maybe-raise-unsupported-configuration-error machine)
 338   "Raise an error if MACHINE's configuration is not an instance of
 339 <machine-ssh-configuration>."
 340   (let ((config (machine-configuration machine))
 341         (environment (environment-type-name (machine-environment machine))))
 342     (unless (and config (machine-ssh-configuration? config))
 343       (raise (condition
 344               (&message
 345                (message (format #f (G_ "unsupported machine configuration '~a'
 346 for environment of type '~a'")
 347                                 config
 348                                 environment))))))))