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 (guix gexp)
  24   #:use-module (guix i18n)
  25   #:use-module (guix modules)
  26   #:use-module (guix monads)
  27   #:use-module (guix records)
  28   #:use-module (guix remote)
  29   #:use-module (guix scripts system reconfigure)
  30   #:use-module (guix ssh)
  31   #:use-module (guix store)
  32   #:use-module (ice-9 match)
  33   #:use-module (srfi srfi-19)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-35)
  36   #:export (managed-host-environment-type
  37
  38             machine-ssh-configuration
  39             machine-ssh-configuration?
  40             machine-ssh-configuration
  41
  42             machine-ssh-configuration-host-name
  43             machine-ssh-configuration-port
  44             machine-ssh-configuration-user
  45             machine-ssh-configuration-session))
  46
  47 ;;; Commentary:
  48 ;;;
  49 ;;; This module implements remote evaluation and system deployment for
  50 ;;; machines that are accessible over SSH and have a known host-name. In the
  51 ;;; sense of the broader "machine" interface, we describe the environment for
  52 ;;; such machines as 'managed-host.
  53 ;;;
  54 ;;; Code:
  55
  56 \f
  57 ;;;
  58 ;;; Parameters for the SSH client.
  59 ;;;
  60
  61 (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
  62   make-machine-ssh-configuration
  63   machine-ssh-configuration?
  64   this-machine-ssh-configuration
  65   (host-name machine-ssh-configuration-host-name) ; string
  66   (port      machine-ssh-configuration-port       ; integer
  67              (default 22))
  68   (user      machine-ssh-configuration-user       ; string
  69              (default "root"))
  70   (identity  machine-ssh-configuration-identity   ; path to a private key
  71              (default #f))
  72   (session   machine-ssh-configuration-session    ; session
  73              (default #f)))
  74
  75 (define (machine-ssh-session machine)
  76   "Return the SSH session that was given in MACHINE's configuration, or create
  77 one from the configuration's parameters if one was not provided."
  78   (maybe-raise-unsupported-configuration-error machine)
  79   (let ((config (machine-configuration machine)))
  80     (or (machine-ssh-configuration-session config)
  81         (let ((host-name (machine-ssh-configuration-host-name config))
  82               (user (machine-ssh-configuration-user config))
  83               (port (machine-ssh-configuration-port config))
  84               (identity (machine-ssh-configuration-identity config)))
  85           (open-ssh-session host-name
  86                             #:user user
  87                             #:port port
  88                             #:identity identity)))))
  89
  90 \f
  91 ;;;
  92 ;;; Remote evaluation.
  93 ;;;
  94
  95 (define (managed-host-remote-eval machine exp)
  96   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
  97 an environment type of 'managed-host."
  98   (maybe-raise-unsupported-configuration-error machine)
  99   (remote-eval exp (machine-ssh-session machine)))
 100
 101 \f
 102 ;;;
 103 ;;; System deployment.
 104 ;;;
 105
 106 (define (machine-boot-parameters machine)
 107   "Monadic procedure returning a list of 'boot-parameters' for the generations
 108 of MACHINE's system profile, ordered from most recent to oldest."
 109   (define bootable-kernel-arguments
 110     (@@ (gnu system) bootable-kernel-arguments))
 111
 112   (define remote-exp
 113     (with-extensions (list guile-gcrypt)
 114       (with-imported-modules (source-module-closure '((guix config)
 115                                                       (guix profiles)))
 116         #~(begin
 117             (use-modules (guix config)
 118                          (guix profiles)
 119                          (ice-9 textual-ports))
 120
 121             (define %system-profile
 122               (string-append %state-directory "/profiles/system"))
 123
 124             (define (read-file path)
 125               (call-with-input-file path
 126                 (lambda (port)
 127                   (get-string-all port))))
 128
 129             (map (lambda (generation)
 130                    (let* ((system-path (generation-file-name %system-profile
 131                                                              generation))
 132                           (boot-parameters-path (string-append system-path
 133                                                                "/parameters"))
 134                           (time (stat:mtime (lstat system-path))))
 135                      (list generation
 136                            system-path
 137                            time
 138                            (read-file boot-parameters-path))))
 139                  (reverse (generation-numbers %system-profile)))))))
 140
 141   (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
 142     (return
 143      (map (lambda (generation)
 144             (match generation
 145               ((generation system-path time serialized-params)
 146                (let* ((params (call-with-input-string serialized-params
 147                                 read-boot-parameters))
 148                       (root (boot-parameters-root-device params))
 149                       (label (boot-parameters-label params)))
 150                  (boot-parameters
 151                   (inherit params)
 152                   (label
 153                    (string-append label " (#"
 154                                   (number->string generation) ", "
 155                                   (let ((time (make-time time-utc 0 time)))
 156                                     (date->string (time-utc->date time)
 157                                                   "~Y-~m-~d ~H:~M"))
 158                                   ")"))
 159                   (kernel-arguments
 160                    (append (bootable-kernel-arguments system-path root)
 161                            (boot-parameters-kernel-arguments params))))))))
 162           generations))))
 163
 164 (define (deploy-managed-host machine)
 165   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 166 environment type of 'managed-host."
 167   (maybe-raise-unsupported-configuration-error machine)
 168   (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
 169     (let* ((os (machine-system machine))
 170            (eval (cut machine-remote-eval machine <>))
 171            (menu-entries (map boot-parameters->menu-entry boot-parameters))
 172            (bootloader-configuration (operating-system-bootloader os))
 173            (bootcfg (operating-system-bootcfg os menu-entries)))
 174       (mbegin %store-monad
 175         (switch-to-system eval os)
 176         (upgrade-shepherd-services eval os)
 177         (install-bootloader eval bootloader-configuration bootcfg)))))
 178
 179 \f
 180 ;;;
 181 ;;; Environment type.
 182 ;;;
 183
 184 (define managed-host-environment-type
 185   (environment-type
 186    (machine-remote-eval managed-host-remote-eval)
 187    (deploy-machine      deploy-managed-host)
 188    (name                'managed-host-environment-type)
 189    (description         "Provisioning for machines that are accessible over SSH
 190 and have a known host-name. This entails little more than maintaining an SSH
 191 connection to the host.")))
 192
 193 (define (maybe-raise-unsupported-configuration-error machine)
 194   "Raise an error if MACHINE's configuration is not an instance of
 195 <machine-ssh-configuration>."
 196   (let ((config (machine-configuration machine))
 197         (environment (environment-type-name (machine-environment machine))))
 198     (unless (and config (machine-ssh-configuration? config))
 199       (raise (condition
 200               (&message
 201                (message (format #f (G_ "unsupported machine configuration '~a'
 202 for environment of type '~a'")
 203                                 config
 204                                 environment))))))))