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'.

1 files changed, 96 insertions, 1 deletions

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)))