[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/13: machine: ssh: Check for potential system downgrades.
From: |
guix-commits |
Subject: |
02/13: machine: ssh: Check for potential system downgrades. |
Date: |
Mon, 27 Jul 2020 06:07:29 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit a396dd01bc6e90ae512001350d1afa471e01661d
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Jul 27 11:03:14 2020 +0200
machine: ssh: Check for potential system downgrades.
This is a followup to 8e31736b0a60919cc1bfc5dc22c395b09243484a.
* guix/scripts/system/reconfigure.scm (check-forward-update): Add
#:current-channels. Use it instead of OLD.
* gnu/services.scm (sexp->system-provenance): New procedure.
(system-provenance): Use it.
* gnu/machine/ssh.scm (<machine-ssh-configuration>)[allow-downgrades?]:
New field.
(machine-check-forward-update): New procedure.
(check-deployment-sanity)[assertions]: Call it.
* doc/guix.texi (Invoking guix deploy): Document 'allow-downgrades?'
field.
---
doc/guix.texi | 10 ++++++++++
gnu/machine/ssh.scm | 32 +++++++++++++++++++++++++++++++-
gnu/services.scm | 26 +++++++++++++++++---------
guix/scripts/system/reconfigure.scm | 21 +++++++++++----------
4 files changed, 69 insertions(+), 20 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index e2b304f..ca96ecc 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -29033,6 +29033,16 @@ When @code{host-key} is @code{#f}, the server is
authenticated against
the @file{~/.ssh/known_hosts} file, just like the OpenSSH @command{ssh}
client does.
+@item @code{allow-downgrades?} (default: @code{#f})
+Whether to allow potential downgrades.
+
+Like @command{guix system reconfigure}, @command{guix deploy} compares
+the channel commits currently deployed on the remote host (as returned
+by @command{guix system describe}) to those currently in use (as
+returned by @command{guix describe}) to determine whether commits
+currently in use are descendants of those deployed. When this is not
+the case and @code{allow-downgrades?} is false, it raises an error.
+This ensures you do not accidentally downgrade remote machines.
@end table
@end deftp
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 641e871..4e31baa 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -24,6 +24,7 @@
#:use-module (gnu system)
#: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)
@@ -55,6 +56,7 @@
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
@@ -83,6 +85,8 @@
(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
@@ -271,6 +275,27 @@ not available in the initrd."
(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
@@ -289,7 +314,8 @@ by MACHINE."
'system' declaration would fail."
(define assertions
(append (machine-check-file-system-availability machine)
- (machine-check-initrd-modules 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
@@ -491,3 +517,7 @@ connection to the host.")))
for environment of type '~a'")
config
environment)))))
+
+;; Local Variables:
+;; eval: (put 'remote-let 'scheme-indent-function 1)
+;; End:
diff --git a/gnu/services.scm b/gnu/services.scm
index 399a432..11ba21e 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -89,6 +89,7 @@
system-service-type
provenance-service-type
+ sexp->system-provenance
system-provenance
boot-service-type
cleanup-service-type
@@ -488,6 +489,19 @@ channels in use and CONFIG-FILE, if it is true."
itself: the channels used when building the system, and its configuration
file, when available.")))
+(define (sexp->system-provenance sexp)
+ "Parse SEXP, an s-expression read from /run/current-system/provenance or
+similar, and return two values: the list of channels listed therein, and the
+OS configuration file or #f."
+ (match sexp
+ (('provenance ('version 0)
+ ('channels channels ...)
+ ('configuration-file config-file))
+ (values (map sexp->channel channels)
+ config-file))
+ (_
+ (values '() #f))))
+
(define (system-provenance system)
"Given SYSTEM, the file name of a system generation, return two values: the
list of channels SYSTEM is built from, and its configuration file. If that
@@ -495,15 +509,9 @@ information is missing, return the empty list (for
channels) and possibly
#false (for the configuration file)."
(catch 'system-error
(lambda ()
- (match (call-with-input-file (string-append system "/provenance")
- read)
- (('provenance ('version 0)
- ('channels channels ...)
- ('configuration-file config-file))
- (values (map sexp->channel channels)
- config-file))
- (_
- (values '() #f))))
+ (sexp->system-provenance
+ (call-with-input-file (string-append system "/provenance")
+ read)))
(lambda _
(values '() #f))))
diff --git a/guix/scripts/system/reconfigure.scm
b/guix/scripts/system/reconfigure.scm
index a257083..45bb1d5 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -339,24 +339,25 @@ to commits of channels in NEW."
old))
(define* (check-forward-update #:optional
- (validate-reconfigure
ensure-forward-reconfigure))
+ (validate-reconfigure
+ ensure-forward-reconfigure)
+ #:key
+ (current-channels
+ (system-provenance "/run/current-system")))
"Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the
-currently-deployed commit (as returned by 'guix system describe') and the
-target commit (as returned by 'guix describe')."
- ;; TODO: Make that functionality available to 'guix deploy'.
+currently-deployed commit (from CURRENT-CHANNELS, which is as returned by
+'guix system describe' by default) and the target commit (as returned by 'guix
+describe')."
(define new
(or (and=> (current-profile) profile-channels)
'()))
- (define old
- (system-provenance "/run/current-system"))
-
- (when (null? old)
- (warning (G_ "cannot determine provenance for /run/current-system~%")))
+ (when (null? current-channels)
+ (warning (G_ "cannot determine provenance for current system~%")))
(when (and (null? new) (not (getenv "GUIX_UNINSTALLED")))
(warning (G_ "cannot determine provenance of ~a~%") %guix-package-name))
(for-each (match-lambda
((channel old new relation)
(validate-reconfigure channel old new relation)))
- (channel-relations old new)))
+ (channel-relations current-channels new)))
- branch master updated (578a1d7 -> 1dba0b4), guix-commits, 2020/07/27
- 01/13: processes: Allow 'less' to properly estimate line length., guix-commits, 2020/07/27
- 02/13: machine: ssh: Check for potential system downgrades.,
guix-commits <=
- 03/13: gnu: guile-reader: Update to 0.6.3., guix-commits, 2020/07/27
- 04/13: gnu: guile-reader: Switch to Guile 3.0., guix-commits, 2020/07/27
- 05/13: services: Add 'unattended-upgrade-service-type'., guix-commits, 2020/07/27
- 06/13: services: auditd: Provide default configuration directory., guix-commits, 2020/07/27
- 08/13: gnu: Add libportal., guix-commits, 2020/07/27
- 10/13: gnu: Add xdg-desktop-portal., guix-commits, 2020/07/27
- 12/13: nls: Update 'fr' translation., guix-commits, 2020/07/27
- 09/13: gnu: pipewire@0.3: Update to 0.3.7., guix-commits, 2020/07/27
- 07/13: gnu: Add pipewire-0.3., guix-commits, 2020/07/27
- 13/13: maint: 'authenticate' runs the user's 'guix git authenticate'., guix-commits, 2020/07/27