2019-07-05 14:55:21 -04:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2020-02-09 17:12:16 -05:00
|
|
|
|
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
|
2021-01-04 05:29:17 -05:00
|
|
|
|
;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
|
2019-07-05 14:55:21 -04:00
|
|
|
|
;;;
|
|
|
|
|
;;; This file is part of GNU Guix.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
|
|
|
;;; under the terms of the GNU General Public License as published by
|
|
|
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
|
;;; your option) any later version.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
|
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;;; GNU General Public License for more details.
|
|
|
|
|
;;;
|
|
|
|
|
;;; You should have received a copy of the GNU General Public License
|
|
|
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
|
|
(define-module (gnu machine ssh)
|
2019-08-15 04:05:57 -04:00
|
|
|
|
#:use-module (gnu bootloader)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (gnu machine)
|
|
|
|
|
#:autoload (gnu packages gnupg) (guile-gcrypt)
|
|
|
|
|
#:use-module (gnu system)
|
2019-07-31 10:38:29 -04:00
|
|
|
|
#:use-module (gnu system file-systems)
|
|
|
|
|
#:use-module (gnu system uuid)
|
2020-07-27 05:03:14 -04:00
|
|
|
|
#:use-module ((gnu services) #:select (sexp->system-provenance))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
#:use-module (guix diagnostics)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (guix gexp)
|
|
|
|
|
#:use-module (guix i18n)
|
|
|
|
|
#:use-module (guix modules)
|
|
|
|
|
#:use-module (guix monads)
|
2019-08-15 04:06:41 -04:00
|
|
|
|
#:use-module (guix pki)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (guix records)
|
|
|
|
|
#:use-module (guix remote)
|
2019-07-24 12:34:02 -04:00
|
|
|
|
#:use-module (guix scripts system reconfigure)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (guix ssh)
|
|
|
|
|
#:use-module (guix store)
|
2019-07-31 10:38:29 -04:00
|
|
|
|
#:use-module (guix utils)
|
2020-11-09 17:24:33 -05:00
|
|
|
|
#:use-module ((guix self) #:select (make-config.scm))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
#:use-module (gcrypt pk-crypto)
|
2020-06-28 09:43:26 -04:00
|
|
|
|
#:use-module (ice-9 format)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (ice-9 match)
|
2019-08-15 04:06:41 -04:00
|
|
|
|
#:use-module (ice-9 textual-ports)
|
2019-08-15 04:05:57 -04:00
|
|
|
|
#:use-module (srfi srfi-1)
|
2020-03-20 07:08:10 -04:00
|
|
|
|
#:use-module (srfi srfi-9)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (srfi srfi-19)
|
2019-07-24 12:34:02 -04:00
|
|
|
|
#:use-module (srfi srfi-26)
|
2019-08-09 14:24:57 -04:00
|
|
|
|
#:use-module (srfi srfi-34)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#:use-module (srfi srfi-35)
|
|
|
|
|
#:export (managed-host-environment-type
|
|
|
|
|
|
|
|
|
|
machine-ssh-configuration
|
|
|
|
|
machine-ssh-configuration?
|
|
|
|
|
machine-ssh-configuration
|
|
|
|
|
|
|
|
|
|
machine-ssh-configuration-host-name
|
2019-08-07 08:44:18 -04:00
|
|
|
|
machine-ssh-configuration-build-locally?
|
2019-08-15 04:06:41 -04:00
|
|
|
|
machine-ssh-configuration-authorize?
|
2020-07-27 05:03:14 -04:00
|
|
|
|
machine-ssh-configuration-allow-downgrades?
|
2019-07-05 14:55:21 -04:00
|
|
|
|
machine-ssh-configuration-port
|
|
|
|
|
machine-ssh-configuration-user
|
2019-12-03 15:59:09 -05:00
|
|
|
|
machine-ssh-configuration-host-key
|
2019-07-05 14:55:21 -04:00
|
|
|
|
machine-ssh-configuration-session))
|
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
;;;
|
|
|
|
|
;;; This module implements remote evaluation and system deployment for
|
2019-07-17 11:32:31 -04:00
|
|
|
|
;;; machines that are accessible over SSH and have a known host-name. In the
|
2019-07-05 14:55:21 -04:00
|
|
|
|
;;; sense of the broader "machine" interface, we describe the environment for
|
|
|
|
|
;;; such machines as 'managed-host.
|
|
|
|
|
;;;
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Parameters for the SSH client.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
|
|
|
|
|
make-machine-ssh-configuration
|
|
|
|
|
machine-ssh-configuration?
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(host-name machine-ssh-configuration-host-name) ; string
|
|
|
|
|
(system machine-ssh-configuration-system) ; string
|
|
|
|
|
(build-locally? machine-ssh-configuration-build-locally? ; boolean
|
2019-08-07 08:44:18 -04:00
|
|
|
|
(default #t))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(authorize? machine-ssh-configuration-authorize? ; boolean
|
|
|
|
|
(default #t))
|
2020-07-27 05:03:14 -04:00
|
|
|
|
(allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
|
|
|
|
|
(default #f))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(port machine-ssh-configuration-port ; integer
|
2019-08-07 08:44:18 -04:00
|
|
|
|
(default 22))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(user machine-ssh-configuration-user ; string
|
2019-08-07 08:44:18 -04:00
|
|
|
|
(default "root"))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(identity machine-ssh-configuration-identity ; path to a private key
|
2019-08-07 08:44:18 -04:00
|
|
|
|
(default #f))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(session machine-ssh-configuration-session ; session
|
2019-12-03 15:59:09 -05:00
|
|
|
|
(default #f))
|
|
|
|
|
(host-key machine-ssh-configuration-host-key ; #f | string
|
2019-08-07 08:44:18 -04:00
|
|
|
|
(default #f)))
|
2019-07-05 14:55:21 -04:00
|
|
|
|
|
|
|
|
|
(define (machine-ssh-session machine)
|
|
|
|
|
"Return the SSH session that was given in MACHINE's configuration, or create
|
|
|
|
|
one from the configuration's parameters if one was not provided."
|
|
|
|
|
(maybe-raise-unsupported-configuration-error machine)
|
|
|
|
|
(let ((config (machine-configuration machine)))
|
|
|
|
|
(or (machine-ssh-configuration-session config)
|
|
|
|
|
(let ((host-name (machine-ssh-configuration-host-name config))
|
|
|
|
|
(user (machine-ssh-configuration-user config))
|
|
|
|
|
(port (machine-ssh-configuration-port config))
|
2019-12-03 15:59:09 -05:00
|
|
|
|
(identity (machine-ssh-configuration-identity config))
|
|
|
|
|
(host-key (machine-ssh-configuration-host-key config)))
|
2019-12-06 07:21:11 -05:00
|
|
|
|
(unless host-key
|
|
|
|
|
(warning (G_ "<machine-ssh-configuration> without a 'host-key' \
|
|
|
|
|
is deprecated~%")))
|
2019-07-05 14:55:21 -04:00
|
|
|
|
(open-ssh-session host-name
|
|
|
|
|
#:user user
|
|
|
|
|
#:port port
|
2019-12-03 15:59:09 -05:00
|
|
|
|
#:identity identity
|
|
|
|
|
#:host-key host-key)))))
|
2019-07-05 14:55:21 -04:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Remote evaluation.
|
|
|
|
|
;;;
|
|
|
|
|
|
2019-08-15 04:05:04 -04:00
|
|
|
|
(define (machine-become-command machine)
|
|
|
|
|
"Return as a list of strings the program and arguments necessary to run a
|
|
|
|
|
shell command with escalated privileges for MACHINE's configuration."
|
|
|
|
|
(if (string= "root" (machine-ssh-configuration-user
|
|
|
|
|
(machine-configuration machine)))
|
|
|
|
|
'()
|
|
|
|
|
'("/run/setuid-programs/sudo" "-n" "--")))
|
|
|
|
|
|
2019-07-05 14:55:21 -04:00
|
|
|
|
(define (managed-host-remote-eval machine exp)
|
|
|
|
|
"Internal implementation of 'machine-remote-eval' for MACHINE instances with
|
|
|
|
|
an environment type of 'managed-host."
|
|
|
|
|
(maybe-raise-unsupported-configuration-error machine)
|
2019-08-09 14:24:57 -04:00
|
|
|
|
(let ((config (machine-configuration machine)))
|
|
|
|
|
(remote-eval exp (machine-ssh-session machine)
|
|
|
|
|
#:build-locally?
|
|
|
|
|
(machine-ssh-configuration-build-locally? config)
|
|
|
|
|
#:system
|
2019-08-15 12:09:11 -04:00
|
|
|
|
(machine-ssh-configuration-system config)
|
|
|
|
|
#:become-command
|
|
|
|
|
(machine-become-command machine))))
|
2019-07-05 14:55:21 -04:00
|
|
|
|
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Safety checks.
|
|
|
|
|
;;;
|
|
|
|
|
|
2020-03-20 07:08:10 -04:00
|
|
|
|
;; Assertion to be executed remotely. This abstraction exists to allow us to
|
|
|
|
|
;; gather a list of expressions to be evaluated and eventually evaluate them
|
|
|
|
|
;; all at once instead of one by one. (This is pretty much a monad.)
|
|
|
|
|
(define-record-type <remote-assertion>
|
|
|
|
|
(remote-assertion exp proc)
|
|
|
|
|
remote-assertion?
|
|
|
|
|
(exp remote-assertion-expression)
|
|
|
|
|
(proc remote-assertion-procedure))
|
|
|
|
|
|
|
|
|
|
(define-syntax-rule (remote-let ((var exp)) body ...)
|
|
|
|
|
"Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
|
|
|
|
|
a gexp, remotely, and evaluate BODY in that context."
|
|
|
|
|
(remote-assertion exp (lambda (var) body ...)))
|
|
|
|
|
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(define (machine-check-file-system-availability machine)
|
2020-03-20 07:08:10 -04:00
|
|
|
|
"Return a list of <remote-assertion> that raise a '&message' error condition
|
|
|
|
|
if any of the file-systems specified in MACHINE's 'system' declaration do not
|
|
|
|
|
exist on the machine."
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(define file-systems
|
|
|
|
|
(filter (lambda (fs)
|
|
|
|
|
(and (file-system-mount? fs)
|
|
|
|
|
(not (member (file-system-type fs)
|
|
|
|
|
%pseudo-file-system-types))
|
2020-09-07 04:04:19 -04:00
|
|
|
|
;; Don't try to validate network file systems.
|
|
|
|
|
(not (string-prefix? "nfs" (file-system-type fs)))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(not (memq 'bind-mount (file-system-flags fs)))))
|
|
|
|
|
(operating-system-file-systems (machine-operating-system machine))))
|
|
|
|
|
|
|
|
|
|
(define (check-literal-file-system fs)
|
2020-03-20 07:08:10 -04:00
|
|
|
|
(remote-let ((errno #~(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(stat #$(file-system-device fs))
|
|
|
|
|
#t)
|
|
|
|
|
(lambda args
|
|
|
|
|
(system-error-errno args)))))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(when (number? errno)
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(raise (formatted-message (G_ "device '~a' not found: ~a")
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(file-system-device fs)
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(strerror errno))))))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
|
|
|
|
(define (check-labeled-file-system fs)
|
|
|
|
|
(define remote-exp
|
2019-08-17 08:26:58 -04:00
|
|
|
|
(with-imported-modules (source-module-closure
|
|
|
|
|
'((gnu build file-systems)))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
#~(begin
|
|
|
|
|
(use-modules (gnu build file-systems))
|
|
|
|
|
(find-partition-by-label #$(file-system-label->string
|
|
|
|
|
(file-system-device fs))))))
|
|
|
|
|
|
2020-03-20 07:08:10 -04:00
|
|
|
|
(remote-let ((result remote-exp))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(unless result
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(raise (formatted-message (G_ "no file system with label '~a'")
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(file-system-label->string
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(file-system-device fs)))))))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
|
|
|
|
(define (check-uuid-file-system fs)
|
|
|
|
|
(define remote-exp
|
|
|
|
|
(with-imported-modules (source-module-closure
|
|
|
|
|
'((gnu build file-systems)
|
|
|
|
|
(gnu system uuid)))
|
|
|
|
|
#~(begin
|
|
|
|
|
(use-modules (gnu build file-systems)
|
|
|
|
|
(gnu system uuid))
|
|
|
|
|
|
2020-06-18 21:12:35 -04:00
|
|
|
|
(let ((uuid (uuid #$(uuid->string (file-system-device fs))
|
|
|
|
|
'#$(uuid-type (file-system-device fs)))))
|
|
|
|
|
(find-partition-by-uuid uuid)))))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
2020-03-20 07:08:10 -04:00
|
|
|
|
(remote-let ((result remote-exp))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(unless result
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(raise (formatted-message (G_ "no file system with UUID '~a'")
|
|
|
|
|
(uuid->string (file-system-device fs)))))))
|
2020-03-20 07:08:10 -04:00
|
|
|
|
|
|
|
|
|
(append (map check-literal-file-system
|
|
|
|
|
(filter (lambda (fs)
|
|
|
|
|
(string? (file-system-device fs)))
|
|
|
|
|
file-systems))
|
|
|
|
|
(map check-labeled-file-system
|
|
|
|
|
(filter (lambda (fs)
|
|
|
|
|
(file-system-label? (file-system-device fs)))
|
|
|
|
|
file-systems))
|
|
|
|
|
(map check-uuid-file-system
|
|
|
|
|
(filter (lambda (fs)
|
|
|
|
|
(uuid? (file-system-device fs)))
|
|
|
|
|
file-systems))))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
|
|
|
|
(define (machine-check-initrd-modules machine)
|
2020-03-20 07:08:10 -04:00
|
|
|
|
"Return a list of <remote-assertion> that raise a '&message' error condition
|
|
|
|
|
if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
|
|
|
|
|
not available in the initrd."
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(define file-systems
|
|
|
|
|
(filter file-system-needed-for-boot?
|
|
|
|
|
(operating-system-file-systems (machine-operating-system machine))))
|
|
|
|
|
|
|
|
|
|
(define (missing-modules fs)
|
|
|
|
|
(define remote-exp
|
|
|
|
|
(let ((device (file-system-device fs)))
|
|
|
|
|
(with-imported-modules (source-module-closure
|
|
|
|
|
'((gnu build file-systems)
|
|
|
|
|
(gnu build linux-modules)
|
|
|
|
|
(gnu system uuid)))
|
2020-08-25 06:39:11 -04:00
|
|
|
|
#~(begin
|
|
|
|
|
(use-modules (gnu build file-systems)
|
|
|
|
|
(gnu build linux-modules)
|
|
|
|
|
(gnu system uuid))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
2020-08-25 06:39:11 -04:00
|
|
|
|
(define dev
|
|
|
|
|
#$(cond ((string? device) device)
|
|
|
|
|
((uuid? device) #~(find-partition-by-uuid
|
|
|
|
|
(string->uuid
|
|
|
|
|
#$(uuid->string device))))
|
|
|
|
|
((file-system-label? device)
|
|
|
|
|
#~(find-partition-by-label
|
|
|
|
|
#$(file-system-label->string device)))))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
2020-08-25 06:39:11 -04:00
|
|
|
|
(missing-modules dev '#$(operating-system-initrd-modules
|
|
|
|
|
(machine-operating-system machine)))))))
|
2020-03-20 07:08:10 -04:00
|
|
|
|
|
|
|
|
|
(remote-let ((missing remote-exp))
|
|
|
|
|
(unless (null? missing)
|
2021-02-25 04:01:56 -05:00
|
|
|
|
(raise (formatted-message (G_ "missing modules for ~a:~{ ~a~}~%")
|
2020-03-20 07:08:10 -04:00
|
|
|
|
(file-system-device fs)
|
2021-02-25 04:01:56 -05:00
|
|
|
|
missing)))))
|
2020-03-20 07:08:10 -04:00
|
|
|
|
|
|
|
|
|
(map missing-modules file-systems))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
2020-07-27 05:03:14 -04:00
|
|
|
|
(define* (machine-check-forward-update machine)
|
|
|
|
|
"Check whether we are making a forward update for MACHINE. Depending on its
|
|
|
|
|
'allow-upgrades?' field, raise an error or display a warning if we are
|
|
|
|
|
potentially downgrading it."
|
|
|
|
|
(define config
|
|
|
|
|
(machine-configuration machine))
|
|
|
|
|
|
|
|
|
|
(define validate-reconfigure
|
|
|
|
|
(if (machine-ssh-configuration-allow-downgrades? config)
|
|
|
|
|
warn-about-backward-reconfigure
|
|
|
|
|
ensure-forward-reconfigure))
|
|
|
|
|
|
|
|
|
|
(remote-let ((provenance #~(call-with-input-file
|
|
|
|
|
"/run/current-system/provenance"
|
|
|
|
|
read)))
|
|
|
|
|
(define channels
|
|
|
|
|
(sexp->system-provenance provenance))
|
|
|
|
|
|
|
|
|
|
(check-forward-update validate-reconfigure
|
|
|
|
|
#:current-channels channels)))
|
|
|
|
|
|
2019-08-09 14:24:57 -04:00
|
|
|
|
(define (machine-check-building-for-appropriate-system machine)
|
|
|
|
|
"Raise a '&message' error condition if MACHINE is configured to be built
|
|
|
|
|
locally and the 'system' field does not match the '%current-system' reported
|
|
|
|
|
by MACHINE."
|
|
|
|
|
(let ((config (machine-configuration machine))
|
|
|
|
|
(system (remote-system (machine-ssh-session machine))))
|
|
|
|
|
(when (and (machine-ssh-configuration-build-locally? config)
|
|
|
|
|
(not (string= system (machine-ssh-configuration-system config))))
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(raise (formatted-message (G_ "incorrect target system\
|
2020-03-20 07:08:10 -04:00
|
|
|
|
('~a' was given, while the system reports that it is '~a')~%")
|
2019-08-09 14:24:57 -04:00
|
|
|
|
(machine-ssh-configuration-system config)
|
2020-07-25 12:26:18 -04:00
|
|
|
|
system)))))
|
2019-08-09 14:24:57 -04:00
|
|
|
|
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(define (check-deployment-sanity machine)
|
|
|
|
|
"Raise a '&message' error condition if it is clear that deploying MACHINE's
|
|
|
|
|
'system' declaration would fail."
|
2020-03-20 07:08:10 -04:00
|
|
|
|
(define assertions
|
|
|
|
|
(append (machine-check-file-system-availability machine)
|
2020-07-27 05:03:14 -04:00
|
|
|
|
(machine-check-initrd-modules machine)
|
|
|
|
|
(list (machine-check-forward-update machine))))
|
2020-03-20 07:08:10 -04:00
|
|
|
|
|
|
|
|
|
(define aggregate-exp
|
|
|
|
|
;; Gather all the expressions so that a single round-trip is enough to
|
|
|
|
|
;; evaluate all the ASSERTIONS remotely.
|
|
|
|
|
#~(map (lambda (file)
|
|
|
|
|
(false-if-exception (primitive-load file)))
|
|
|
|
|
'#$(map (lambda (assertion)
|
|
|
|
|
(scheme-file "remote-assertion.scm"
|
|
|
|
|
(remote-assertion-expression assertion)))
|
|
|
|
|
assertions)))
|
|
|
|
|
|
|
|
|
|
;; First check MACHINE's system type--an incorrect value for 'system' would
|
|
|
|
|
;; cause subsequent invocations of 'remote-eval' to fail.
|
|
|
|
|
(machine-check-building-for-appropriate-system machine)
|
|
|
|
|
|
|
|
|
|
(mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
|
|
|
|
|
(for-each (lambda (proc value)
|
|
|
|
|
(proc value))
|
|
|
|
|
(map remote-assertion-procedure assertions)
|
|
|
|
|
values)
|
|
|
|
|
(return #t)))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
|
2019-07-05 14:55:21 -04:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; System deployment.
|
|
|
|
|
;;;
|
|
|
|
|
|
2021-01-04 05:29:17 -05:00
|
|
|
|
(define not-config?
|
|
|
|
|
;; Select (guix …) and (gnu …) modules, except (guix config).
|
|
|
|
|
(match-lambda
|
|
|
|
|
(('guix 'config) #f)
|
|
|
|
|
(('guix _ ...) #t)
|
|
|
|
|
(('gnu _ ...) #t)
|
|
|
|
|
(_ #f)))
|
|
|
|
|
|
2019-07-05 14:55:21 -04:00
|
|
|
|
(define (machine-boot-parameters machine)
|
|
|
|
|
"Monadic procedure returning a list of 'boot-parameters' for the generations
|
|
|
|
|
of MACHINE's system profile, ordered from most recent to oldest."
|
|
|
|
|
(define bootable-kernel-arguments
|
|
|
|
|
(@@ (gnu system) bootable-kernel-arguments))
|
|
|
|
|
|
|
|
|
|
(define remote-exp
|
|
|
|
|
(with-extensions (list guile-gcrypt)
|
2021-01-04 05:29:17 -05:00
|
|
|
|
(with-imported-modules `(((guix config) => ,(make-config.scm))
|
|
|
|
|
,@(source-module-closure
|
|
|
|
|
'((guix profiles))
|
|
|
|
|
#:select? not-config?))
|
2019-07-05 14:55:21 -04:00
|
|
|
|
#~(begin
|
|
|
|
|
(use-modules (guix config)
|
|
|
|
|
(guix profiles)
|
|
|
|
|
(ice-9 textual-ports))
|
|
|
|
|
|
|
|
|
|
(define %system-profile
|
|
|
|
|
(string-append %state-directory "/profiles/system"))
|
|
|
|
|
|
|
|
|
|
(define (read-file path)
|
|
|
|
|
(call-with-input-file path
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(get-string-all port))))
|
|
|
|
|
|
|
|
|
|
(map (lambda (generation)
|
|
|
|
|
(let* ((system-path (generation-file-name %system-profile
|
|
|
|
|
generation))
|
|
|
|
|
(boot-parameters-path (string-append system-path
|
|
|
|
|
"/parameters"))
|
|
|
|
|
(time (stat:mtime (lstat system-path))))
|
|
|
|
|
(list generation
|
|
|
|
|
system-path
|
|
|
|
|
time
|
|
|
|
|
(read-file boot-parameters-path))))
|
|
|
|
|
(reverse (generation-numbers %system-profile)))))))
|
|
|
|
|
|
|
|
|
|
(mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
|
|
|
|
|
(return
|
|
|
|
|
(map (lambda (generation)
|
|
|
|
|
(match generation
|
|
|
|
|
((generation system-path time serialized-params)
|
|
|
|
|
(let* ((params (call-with-input-string serialized-params
|
|
|
|
|
read-boot-parameters))
|
|
|
|
|
(root (boot-parameters-root-device params))
|
|
|
|
|
(label (boot-parameters-label params)))
|
|
|
|
|
(boot-parameters
|
|
|
|
|
(inherit params)
|
|
|
|
|
(label
|
|
|
|
|
(string-append label " (#"
|
|
|
|
|
(number->string generation) ", "
|
|
|
|
|
(let ((time (make-time time-utc 0 time)))
|
|
|
|
|
(date->string (time-utc->date time)
|
|
|
|
|
"~Y-~m-~d ~H:~M"))
|
|
|
|
|
")"))
|
|
|
|
|
(kernel-arguments
|
|
|
|
|
(append (bootable-kernel-arguments system-path root)
|
|
|
|
|
(boot-parameters-kernel-arguments params))))))))
|
|
|
|
|
generations))))
|
|
|
|
|
|
2019-08-15 04:05:57 -04:00
|
|
|
|
(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
|
|
|
|
|
"Catch exceptions that arise when binding MBODY, a monadic expression in
|
|
|
|
|
%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
|
|
|
|
|
the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
|
|
|
|
|
(catch #t
|
|
|
|
|
(lambda ()
|
|
|
|
|
mbody ...)
|
|
|
|
|
(lambda args
|
|
|
|
|
(raise (condition (&deploy-error
|
|
|
|
|
(should-roll-back should-roll-back?)
|
|
|
|
|
(captured-args args)))))))
|
|
|
|
|
|
2019-07-05 14:55:21 -04:00
|
|
|
|
(define (deploy-managed-host machine)
|
|
|
|
|
"Internal implementation of 'deploy-machine' for MACHINE instances with an
|
|
|
|
|
environment type of 'managed-host."
|
|
|
|
|
(maybe-raise-unsupported-configuration-error machine)
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(when (machine-ssh-configuration-authorize?
|
|
|
|
|
(machine-configuration machine))
|
|
|
|
|
(unless (file-exists? %public-key-file)
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(raise (formatted-message (G_ "no signing key '~a'. \
|
2019-08-15 04:06:41 -04:00
|
|
|
|
have you run 'guix archive --generate-key?'")
|
2020-07-25 12:26:18 -04:00
|
|
|
|
%public-key-file)))
|
2019-08-15 04:06:41 -04:00
|
|
|
|
(remote-authorize-signing-key (call-with-input-file %public-key-file
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(string->canonical-sexp
|
|
|
|
|
(get-string-all port))))
|
2019-08-15 12:09:11 -04:00
|
|
|
|
(machine-ssh-session machine)
|
|
|
|
|
(machine-become-command machine)))
|
2019-07-31 10:38:29 -04:00
|
|
|
|
(mlet %store-monad ((_ (check-deployment-sanity machine))
|
|
|
|
|
(boot-parameters (machine-boot-parameters machine)))
|
2019-07-30 13:48:32 -04:00
|
|
|
|
(let* ((os (machine-operating-system machine))
|
2019-07-24 12:34:02 -04:00
|
|
|
|
(eval (cut machine-remote-eval machine <>))
|
|
|
|
|
(menu-entries (map boot-parameters->menu-entry boot-parameters))
|
|
|
|
|
(bootloader-configuration (operating-system-bootloader os))
|
|
|
|
|
(bootcfg (operating-system-bootcfg os menu-entries)))
|
|
|
|
|
(mbegin %store-monad
|
2019-08-15 04:05:57 -04:00
|
|
|
|
(with-roll-back #f
|
|
|
|
|
(switch-to-system eval os))
|
|
|
|
|
(with-roll-back #t
|
|
|
|
|
(mbegin %store-monad
|
|
|
|
|
(upgrade-shepherd-services eval os)
|
|
|
|
|
(install-bootloader eval bootloader-configuration bootcfg)))))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Roll-back.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (roll-back-managed-host machine)
|
|
|
|
|
"Internal implementation of 'roll-back-machine' for MACHINE instances with
|
|
|
|
|
an environment type of 'managed-host."
|
|
|
|
|
(define remote-exp
|
|
|
|
|
(with-extensions (list guile-gcrypt)
|
|
|
|
|
(with-imported-modules (source-module-closure '((guix config)
|
|
|
|
|
(guix profiles)))
|
|
|
|
|
#~(begin
|
|
|
|
|
(use-modules (guix config)
|
|
|
|
|
(guix profiles))
|
|
|
|
|
|
|
|
|
|
(define %system-profile
|
|
|
|
|
(string-append %state-directory "/profiles/system"))
|
|
|
|
|
|
|
|
|
|
(define target-generation
|
|
|
|
|
(relative-generation %system-profile -1))
|
|
|
|
|
|
|
|
|
|
(if target-generation
|
|
|
|
|
(switch-to-generation %system-profile target-generation)
|
|
|
|
|
'error)))))
|
|
|
|
|
|
|
|
|
|
(define roll-back-failure
|
|
|
|
|
(condition (&message (message (G_ "could not roll-back machine")))))
|
|
|
|
|
|
|
|
|
|
(mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
|
|
|
|
|
(_ -> (if (< (length boot-parameters) 2)
|
|
|
|
|
(raise roll-back-failure)))
|
|
|
|
|
(entries -> (map boot-parameters->menu-entry
|
|
|
|
|
(list (second boot-parameters))))
|
2019-04-22 08:44:22 -04:00
|
|
|
|
(locale -> (boot-parameters-locale
|
|
|
|
|
(second boot-parameters)))
|
2020-12-21 07:02:01 -05:00
|
|
|
|
(crypto-dev -> (boot-parameters-store-crypto-devices
|
|
|
|
|
(second boot-parameters)))
|
2020-10-24 12:15:53 -04:00
|
|
|
|
(store-dir -> (boot-parameters-store-directory-prefix
|
|
|
|
|
(second boot-parameters)))
|
2019-08-15 04:05:57 -04:00
|
|
|
|
(old-entries -> (map boot-parameters->menu-entry
|
|
|
|
|
(drop boot-parameters 2)))
|
|
|
|
|
(bootloader -> (operating-system-bootloader
|
|
|
|
|
(machine-operating-system machine)))
|
|
|
|
|
(bootcfg (lower-object
|
|
|
|
|
((bootloader-configuration-file-generator
|
|
|
|
|
(bootloader-configuration-bootloader
|
|
|
|
|
bootloader))
|
|
|
|
|
bootloader entries
|
2019-04-22 08:44:22 -04:00
|
|
|
|
#:locale locale
|
2020-12-21 07:02:01 -05:00
|
|
|
|
#:store-crypto-devices crypto-dev
|
2020-10-24 12:15:53 -04:00
|
|
|
|
#:store-directory-prefix store-dir
|
2019-08-15 04:05:57 -04:00
|
|
|
|
#:old-entries old-entries)))
|
|
|
|
|
(remote-result (machine-remote-eval machine remote-exp)))
|
|
|
|
|
(when (eqv? 'error remote-result)
|
|
|
|
|
(raise roll-back-failure))))
|
2019-07-05 14:55:21 -04:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Environment type.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define managed-host-environment-type
|
|
|
|
|
(environment-type
|
|
|
|
|
(machine-remote-eval managed-host-remote-eval)
|
|
|
|
|
(deploy-machine deploy-managed-host)
|
2019-08-15 04:05:57 -04:00
|
|
|
|
(roll-back-machine roll-back-managed-host)
|
2019-07-05 14:55:21 -04:00
|
|
|
|
(name 'managed-host-environment-type)
|
2019-07-17 11:32:31 -04:00
|
|
|
|
(description "Provisioning for machines that are accessible over SSH
|
2019-07-05 14:55:21 -04:00
|
|
|
|
and have a known host-name. This entails little more than maintaining an SSH
|
|
|
|
|
connection to the host.")))
|
|
|
|
|
|
|
|
|
|
(define (maybe-raise-unsupported-configuration-error machine)
|
|
|
|
|
"Raise an error if MACHINE's configuration is not an instance of
|
|
|
|
|
<machine-ssh-configuration>."
|
|
|
|
|
(let ((config (machine-configuration machine))
|
|
|
|
|
(environment (environment-type-name (machine-environment machine))))
|
|
|
|
|
(unless (and config (machine-ssh-configuration? config))
|
2020-07-25 12:26:18 -04:00
|
|
|
|
(raise (formatted-message (G_ "unsupported machine configuration '~a'
|
2019-07-05 14:55:21 -04:00
|
|
|
|
for environment of type '~a'")
|
|
|
|
|
config
|
2020-07-25 12:26:18 -04:00
|
|
|
|
environment)))))
|
2020-07-27 05:03:14 -04:00
|
|
|
|
|
|
|
|
|
;; Local Variables:
|
|
|
|
|
;; eval: (put 'remote-let 'scheme-indent-function 1)
|
|
|
|
|
;; End:
|