;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
- #:use-module (gnu services)
- #:use-module (gnu services shepherd)
#:use-module (gnu system)
- #:use-module (guix derivations)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system uuid)
+ #:use-module ((gnu services) #:select (sexp->system-provenance))
+ #:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix i18n)
#:use-module (guix modules)
#:use-module (guix monads)
+ #:use-module (guix pki)
#:use-module (guix records)
#:use-module (guix remote)
+ #:use-module (guix scripts system reconfigure)
#:use-module (guix ssh)
#:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
machine-ssh-configuration
machine-ssh-configuration-host-name
+ machine-ssh-configuration-build-locally?
+ machine-ssh-configuration-authorize?
+ machine-ssh-configuration-allow-downgrades?
machine-ssh-configuration-port
machine-ssh-configuration-user
+ machine-ssh-configuration-host-key
machine-ssh-configuration-session))
;;; Commentary:
;;;
;;; This module implements remote evaluation and system deployment for
-;;; machines that are accessable over SSH and have a known host-name. In the
+;;; machines that are accessible over SSH and have a known host-name. In the
;;; sense of the broader "machine" interface, we describe the environment for
;;; such machines as 'managed-host.
;;;
(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
make-machine-ssh-configuration
machine-ssh-configuration?
- this-machine-ssh-configuration
- (host-name machine-ssh-configuration-host-name) ; string
- (port machine-ssh-configuration-port ; integer
- (default 22))
- (user machine-ssh-configuration-user ; string
- (default "root"))
- (identity machine-ssh-configuration-identity ; path to a private key
- (default #f))
- (session machine-ssh-configuration-session ; session
- (default #f)))
+ (host-name machine-ssh-configuration-host-name) ; string
+ (system machine-ssh-configuration-system) ; string
+ (build-locally? machine-ssh-configuration-build-locally? ; boolean
+ (default #t))
+ (authorize? machine-ssh-configuration-authorize? ; boolean
+ (default #t))
+ (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
+ (default #f))
+ (port machine-ssh-configuration-port ; integer
+ (default 22))
+ (user machine-ssh-configuration-user ; string
+ (default "root"))
+ (identity machine-ssh-configuration-identity ; path to a private key
+ (default #f))
+ (session machine-ssh-configuration-session ; session
+ (default #f))
+ (host-key machine-ssh-configuration-host-key ; #f | string
+ (default #f)))
(define (machine-ssh-session machine)
"Return the SSH session that was given in MACHINE's configuration, or create
(let ((host-name (machine-ssh-configuration-host-name config))
(user (machine-ssh-configuration-user config))
(port (machine-ssh-configuration-port config))
- (identity (machine-ssh-configuration-identity config)))
+ (identity (machine-ssh-configuration-identity config))
+ (host-key (machine-ssh-configuration-host-key config)))
+ (unless host-key
+ (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
+is deprecated~%")))
(open-ssh-session host-name
#:user user
#:port port
- #:identity identity)))))
+ #:identity identity
+ #:host-key host-key)))))
\f
;;;
;;; Remote evaluation.
;;;
+(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" "--")))
+
(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)
- (remote-eval exp (machine-ssh-session machine)))
+ (let ((config (machine-configuration machine)))
+ (remote-eval exp (machine-ssh-session machine)
+ #:build-locally?
+ (machine-ssh-configuration-build-locally? config)
+ #:system
+ (machine-ssh-configuration-system config)
+ #:become-command
+ (machine-become-command machine))))
\f
;;;
-;;; System deployment.
+;;; Safety checks.
;;;
-(define (switch-to-system machine)
- "Monadic procedure creating a new generation on MACHINE and execute the
-activation script for the new system configuration."
- (define (remote-exp drv script)
- (with-extensions (list guile-gcrypt)
- (with-imported-modules (source-module-closure '((guix config)
- (guix profiles)
- (guix utils)))
+;; 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 ...)))
+
+(define (machine-check-file-system-availability machine)
+ "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."
+ (define file-systems
+ (filter (lambda (fs)
+ (and (file-system-mount? fs)
+ (not (member (file-system-type fs)
+ %pseudo-file-system-types))
+ (not (memq 'bind-mount (file-system-flags fs)))))
+ (operating-system-file-systems (machine-operating-system machine))))
+
+ (define (check-literal-file-system fs)
+ (remote-let ((errno #~(catch 'system-error
+ (lambda ()
+ (stat #$(file-system-device fs))
+ #t)
+ (lambda args
+ (system-error-errno args)))))
+ (when (number? errno)
+ (raise (formatted-message (G_ "device '~a' not found: ~a")
+ (file-system-device fs)
+ (strerror errno))))))
+
+ (define (check-labeled-file-system fs)
+ (define remote-exp
+ (with-imported-modules (source-module-closure
+ '((gnu build file-systems)))
#~(begin
- (use-modules (guix config)
- (guix profiles)
- (guix utils))
-
- (define %system-profile
- (string-append %state-directory "/profiles/system"))
+ (use-modules (gnu build file-systems))
+ (find-partition-by-label #$(file-system-label->string
+ (file-system-device fs))))))
+
+ (remote-let ((result remote-exp))
+ (unless result
+ (raise (formatted-message (G_ "no file system with label '~a'")
+ (file-system-label->string
+ (file-system-device fs)))))))
+
+ (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))
+
+ (let ((uuid (uuid #$(uuid->string (file-system-device fs))
+ '#$(uuid-type (file-system-device fs)))))
+ (find-partition-by-uuid uuid)))))
+
+ (remote-let ((result remote-exp))
+ (unless result
+ (raise (formatted-message (G_ "no file system with UUID '~a'")
+ (uuid->string (file-system-device fs)))))))
+
+ (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))))
+
+(define (machine-check-initrd-modules machine)
+ "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."
+ (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)))
+ #~(begin
+ (use-modules (gnu build file-systems)
+ (gnu build linux-modules)
+ (gnu system uuid))
+
+ (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)))))
+
+ (missing-modules dev '#$(operating-system-initrd-modules
+ (machine-operating-system machine)))))))
+
+ (remote-let ((missing remote-exp))
+ (unless (null? missing)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "missing modules for ~a:~{ ~a~}~%")
+ (file-system-device fs)
+ missing))))))))
+
+ (map missing-modules file-systems))
+
+(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)))
+
+(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))))
+ (raise (formatted-message (G_ "incorrect target system\
+ ('~a' was given, while the system reports that it is '~a')~%")
+ (machine-ssh-configuration-system config)
+ system)))))
+
+(define (check-deployment-sanity machine)
+ "Raise a '&message' error condition if it is clear that deploying MACHINE's
+'system' declaration would fail."
+ (define assertions
+ (append (machine-check-file-system-availability machine)
+ (machine-check-initrd-modules machine)
+ (list (machine-check-forward-update machine))))
+
+ (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)))
- (let* ((system #$drv)
- (number (1+ (generation-number %system-profile)))
- (generation (generation-file-name %system-profile number)))
- (switch-symlinks generation system)
- (switch-symlinks %system-profile generation)
- ;; The implementation of 'guix system reconfigure' saves the
- ;; load path and environment here. This is unnecessary here
- ;; because each invocation of 'remote-eval' runs in a distinct
- ;; Guile REPL.
- (setenv "GUIX_NEW_SYSTEM" system)
- ;; The activation script may write to stdout, which confuses
- ;; 'remote-eval' when it attempts to read a result from the
- ;; remote REPL. We work around this by forcing the output to a
- ;; string.
- (with-output-to-string
- (lambda ()
- (primitive-load #$script))))))))
-
- (let* ((os (machine-system machine))
- (script (operating-system-activation-script os)))
- (mlet* %store-monad ((drv (operating-system-derivation os)))
- (machine-remote-eval machine (remote-exp drv script)))))
-
-;; XXX: Currently, this does NOT attempt to restart running services. This is
-;; also the case with 'guix system reconfigure'.
-;;
-;; See <https://issues.guix.info/issue/33508>.
-(define (upgrade-shepherd-services machine)
- "Monadic procedure unloading and starting services on the remote as needed
-to realize the MACHINE's system configuration."
- (define target-services
- ;; Monadic expression evaluating to a list of (name output-path) pairs for
- ;; all of MACHINE's services.
- (mapm %store-monad
- (lambda (service)
- (mlet %store-monad ((file ((compose lower-object
- shepherd-service-file)
- service)))
- (return (list (shepherd-service-canonical-name service)
- (derivation->output-path file)))))
- (service-value
- (fold-services (operating-system-services (machine-system machine))
- #:target-type shepherd-root-service-type))))
-
- (define (remote-exp target-services)
- (with-imported-modules '((gnu services herd))
- #~(begin
- (use-modules (gnu services herd)
- (srfi srfi-1))
-
- (define running
- (filter live-service-running (current-services)))
-
- (define (essential? service)
- ;; Return #t if SERVICE is essential and should not be unloaded
- ;; under any circumstance.
- (memq (first (live-service-provision service))
- '(root shepherd)))
-
- (define (obsolete? service)
- ;; Return #t if SERVICE can be safely unloaded.
- (and (not (essential? service))
- (every (lambda (requirements)
- (not (memq (first (live-service-provision service))
- requirements)))
- (map live-service-requirement running))))
-
- (define to-unload
- (filter obsolete?
- (remove (lambda (service)
- (memq (first (live-service-provision service))
- (map first '#$target-services)))
- running)))
-
- (define to-start
- (remove (lambda (service-pair)
- (memq (first service-pair)
- (map (compose first live-service-provision)
- running)))
- '#$target-services))
-
- ;; Unload obsolete services.
- (for-each (lambda (service)
- (false-if-exception
- (unload-service service)))
- to-unload)
-
- ;; Load the service files for any new services and start them.
- (load-services/safe (map second to-start))
- (for-each start-service (map first to-start))
-
- #t)))
-
- (mlet %store-monad ((target-services target-services))
- (machine-remote-eval machine (remote-exp target-services))))
+\f
+;;;
+;;; System deployment.
+;;;
(define (machine-boot-parameters machine)
"Monadic procedure returning a list of 'boot-parameters' for the generations
(boot-parameters-kernel-arguments params))))))))
generations))))
-(define (install-bootloader machine)
- "Create a bootloader entry for the new system generation on MACHINE, and
-configure the bootloader to boot that generation by default."
- (define bootloader-installer-script
- (@@ (guix scripts system) bootloader-installer-script))
-
- (define (remote-exp installer bootcfg bootcfg-file)
- (with-extensions (list guile-gcrypt)
- (with-imported-modules (source-module-closure '((gnu build install)
- (guix store)
- (guix utils)))
- #~(begin
- (use-modules (gnu build install)
- (guix store)
- (guix utils))
- (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
- (temp-gc-root (string-append gc-root ".new")))
-
- (switch-symlinks temp-gc-root gc-root)
-
- (unless (false-if-exception
- (begin
- ;; The implementation of 'guix system reconfigure'
- ;; saves the load path here. This is unnecessary here
- ;; because each invocation of 'remote-eval' runs in a
- ;; distinct Guile REPL.
- (install-boot-config #$bootcfg #$bootcfg-file "/")
- ;; The installation script may write to stdout, which
- ;; confuses 'remote-eval' when it attempts to read a
- ;; result from the remote REPL. We work around this
- ;; by forcing the output to a string.
- (with-output-to-string
- (lambda ()
- (primitive-load #$installer)))))
- (delete-file temp-gc-root)
- (error "failed to install bootloader"))
-
- (rename-file temp-gc-root gc-root)
- #t)))))
-
- (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
- (let* ((os (machine-system machine))
- (bootloader ((compose bootloader-configuration-bootloader
- operating-system-bootloader)
- os))
- (bootloader-target (bootloader-configuration-target
- (operating-system-bootloader os)))
- (installer (bootloader-installer-script
- (bootloader-installer bootloader)
- (bootloader-package bootloader)
- bootloader-target
- "/"))
- (menu-entries (map boot-parameters->menu-entry boot-parameters))
- (bootcfg (operating-system-bootcfg os menu-entries))
- (bootcfg-file (bootloader-configuration-file bootloader)))
- (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
+(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)))))))
(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)
- (mbegin %store-monad
- (switch-to-system machine)
- (upgrade-shepherd-services machine)
- (install-bootloader machine)))
+ (when (machine-ssh-configuration-authorize?
+ (machine-configuration machine))
+ (unless (file-exists? %public-key-file)
+ (raise (formatted-message (G_ "no signing key '~a'. \
+have you run 'guix archive --generate-key?'")
+ %public-key-file)))
+ (remote-authorize-signing-key (call-with-input-file %public-key-file
+ (lambda (port)
+ (string->canonical-sexp
+ (get-string-all port))))
+ (machine-ssh-session machine)
+ (machine-become-command machine)))
+ (mlet %store-monad ((_ (check-deployment-sanity machine))
+ (boot-parameters (machine-boot-parameters machine)))
+ (let* ((os (machine-operating-system machine))
+ (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
+ (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)))))))
+
+\f
+;;;
+;;; 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))))
+ (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
+ #:old-entries old-entries)))
+ (remote-result (machine-remote-eval machine remote-exp)))
+ (when (eqv? 'error remote-result)
+ (raise roll-back-failure))))
\f
;;;
(environment-type
(machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host)
+ (roll-back-machine roll-back-managed-host)
(name 'managed-host-environment-type)
- (description "Provisioning for machines that are accessable over SSH
+ (description "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
connection to the host.")))
(let ((config (machine-configuration machine))
(environment (environment-type-name (machine-environment machine))))
(unless (and config (machine-ssh-configuration? config))
- (raise (condition
- (&message
- (message (format #f (G_ "unsupported machine configuration '~a'
+ (raise (formatted-message (G_ "unsupported machine configuration '~a'
for environment of type '~a'")
config
- environment))))))))
+ environment)))))
+
+;; Local Variables:
+;; eval: (put 'remote-let 'scheme-indent-function 1)
+;; End:
HCoop / jackhill / guix / guix.git / blobdiff