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.

4 files changed, 69 insertions, 20 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index e2b304ff63..ca96ecc298 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 641e871861..4e31baa4b9 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 399a432e3f..11ba21e824 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 a2570839a8..45bb1d5d3b 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)))