guix system: 'reconfigure' disallows downgrades by default.

This is similar to what 9744cc7b4636fafb772c94adb8f05961b5b39f16 did for
'guix pull'.

* guix/scripts/system/reconfigure.scm (ensure-forward-reconfigure)
(warn-about-backward-reconfigure, channel-relations)
(check-forward-update): New procedures.
* guix/scripts/system.scm (perform-action): Add #:validate-reconfigure.
Call 'check-forward-update' when ACTION is 'reconfigure.
(%options, show-help): Add "--allow-downgrades".
(%default-options): Add 'validate-reconfigure' key.
(process-action): Pass #:validate-reconfigure to 'perform-action'.
* doc/guix.texi (Invoking guix system): Document 'guix system describe'
more prominently, and document '--allow-downgrades'.

2 files changed, 110 insertions, 2 deletions

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f2b4367094..79bfcd7db2 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -736,6 +736,7 @@ and TARGET arguments."
 
 (define* (perform-action action os
                          #:key
+                         (validate-reconfigure ensure-forward-reconfigure)
                          save-provenance?
                          skip-safety-checks?
                          install-bootloader?
@@ -778,7 +779,8 @@ static checks."
          (operating-system-bootcfg os menu-entries)))
 
   (when (eq? action 'reconfigure)
-    (maybe-suggest-running-guix-pull))
+    (maybe-suggest-running-guix-pull)
+    (check-forward-update validate-reconfigure))
 
   ;; Check whether the declared file systems exist.  This is better than
   ;; instantiating a broken configuration.  Assume that we can only check if
@@ -927,6 +929,9 @@ Some ACTIONS support additional ARGS.\n"))
   -e, --expression=EXPR  consider the operating-system EXPR evaluates to
                          instead of reading FILE, when applicable"))
   (display (G_ "
+      --allow-downgrades for 'reconfigure', allow downgrades to earlier
+                         channel revisions"))
+  (display (G_ "
       --on-error=STRATEGY
                          apply STRATEGY (one of nothing-special, backtrace,
                          or debug) when an error occurs while reading FILE"))
@@ -981,6 +986,11 @@ Some ACTIONS support additional ARGS.\n"))
          (option '(#\d "derivation") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'derivations-only? #t result)))
+         (option '("allow-downgrades") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'validate-reconfigure
+                               warn-about-backward-reconfigure
+                               result)))
          (option '("on-error") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'on-error (string->symbol arg)
@@ -1053,6 +1063,7 @@ Some ACTIONS support additional ARGS.\n"))
     (graft? . #t)
     (debug . 0)
     (verbosity . #f)                              ;default
+    (validate-reconfigure . ,ensure-forward-reconfigure)
     (file-system-type . "ext4")
     (image-size . guess)
     (install-bootloader? . #t)))
@@ -1138,6 +1149,8 @@ resulting from command-line parsing."
                                #:use-substitutes? (assoc-ref opts 'substitutes?)
                                #:skip-safety-checks?
                                (assoc-ref opts 'skip-safety-checks?)
+                               #:validate-reconfigure
+                               (assoc-ref opts 'validate-reconfigure)
                                #:file-system-type (assoc-ref opts 'file-system-type)
                                #:image-size (assoc-ref opts 'image-size)
                                #:full-boot? (assoc-ref opts 'full-boot?)
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 7885c33457..9013e035f7 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -34,9 +34,18 @@
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module ((guix self) #:select (make-config.scm))
+  #:autoload   (guix describe) (current-profile)
+  #:use-module (guix channels)
+  #:autoload   (guix git) (update-cached-checkout)
+  #:use-module (guix i18n)
+  #:use-module (guix diagnostics)
+  #:use-module ((guix utils) #:select (&fix-hint))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module ((guix config) #:select (%guix-package-name))
   #:export (switch-system-program
             switch-to-system
 
@@ -44,7 +53,11 @@
             upgrade-shepherd-services
 
             install-bootloader-program
-            install-bootloader))
+            install-bootloader
+
+            check-forward-update
+            ensure-forward-reconfigure
+            warn-about-backward-reconfigure))
 
 ;;; Commentary:
 ;;;
@@ -266,3 +279,85 @@ additional configurations specified by MENU-ENTRIES can be selected."
                                                             bootcfg-file
                                                             device
                                                             target))))))
+
+
+;;;
+;;; Downgrade detection.
+;;;
+
+(define (ensure-forward-reconfigure channel start commit relation)
+  "Raise an error if RELATION is not 'ancestor, meaning that START is not an
+ancestor of COMMIT, unless CHANNEL specifies a commit."
+  (match relation
+    ('ancestor #t)
+    ('self #t)
+    (_
+     (raise (make-compound-condition
+             (condition
+              (&message (message
+                         (format #f (G_ "\
+aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a")
+                                 commit (channel-name channel)
+                                 start)))
+              (&fix-hint
+               (hint (G_ "Use @option{--allow-downgrades} to force
+this downgrade.")))))))))
+
+(define (warn-about-backward-reconfigure channel start commit relation)
+  "Warn about non-forward updates of CHANNEL from START to COMMIT, without
+aborting."
+  (match relation
+    ((or 'ancestor 'self)
+     #t)
+    ('descendant
+     (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
+              (channel-name channel) start commit))
+    ('unrelated
+     (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
+              (channel-name channel) start commit))))
+
+(define (channel-relations old new)
+  "Return a list of channel/relation pairs, where each relation is a symbol as
+returned by 'commit-relation' denoting how commits of channels in OLD relate
+to commits of channels in NEW."
+  (filter-map (lambda (old)
+                (let ((new (find (lambda (channel)
+                                   (eq? (channel-name channel)
+                                        (channel-name old)))
+                                 new)))
+                  (and new
+                       (let-values (((checkout commit relation)
+                                     (update-cached-checkout
+                                      (channel-url new)
+                                      #:ref
+                                      `(commit . ,(channel-commit new))
+                                      #:starting-commit
+                                      (channel-commit old)
+                                      #:check-out? #f)))
+                         (list new
+                               (channel-commit old) (channel-commit new)
+                               relation)))))
+              old))
+
+(define* (check-forward-update #:optional
+                               (validate-reconfigure ensure-forward-reconfigure))
+  "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'.
+  (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 (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)))