From 23ccfd3840d957e28fdbe3e3af9f588320c04fe3 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 23 Jan 2022 16:21:03 +0100
Subject: home: 'reconfigure' checks for potential downgrades.

* guix/scripts/home.scm (show-help, %options): Add "--allow-downgrades".
(%default-options): Remove 'build-mode'; add 'validate-reconfigure'.
(perform-action): Add #:validate-reconfigure.  Call
'check-forward-update' when ACTION is 'reconfigure.
(process-action): Pass #:validate-reconfigure to 'perform-action'.
* gnu/home/services.scm (home-provenance): Export.
* doc/guix.texi (Invoking guix home): Document '--allow-downgrades'.
---
 doc/guix.texi         | 10 ++++++++++
 gnu/home/services.scm |  1 +
 guix/scripts/home.scm | 37 +++++++++++++++++++++++++------------
 3 files changed, 36 insertions(+), 12 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 62e994ceb1..94f8e5e481 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -38072,6 +38072,16 @@ Consider the home-environment @var{expr} evaluates to.
 This is an alternative to specifying a file which evaluates to a home
 environment.
 
+@item --allow-downgrades
+Instruct @command{guix home reconfigure} to allow system downgrades.
+
+Just like @command{guix system}, @command{guix home reconfigure}, by
+default, prevents you from downgrading your home to older or unrelated
+revisions compared to the channel revisions that were used to deploy
+it---those shown by @command{guix home describe}.  Using
+@option{--allow-downgrades} allows you to bypass that check, at the risk
+of downgrading your home---be careful!
+
 @end table
 
 @node Documentation
diff --git a/gnu/home/services.scm b/gnu/home/services.scm
index 2a3cb44952..1c860d7b01 100644
--- a/gnu/home/services.scm
+++ b/gnu/home/services.scm
@@ -43,6 +43,7 @@ (define-module (gnu home services)
             home-provenance-service-type
 
             fold-home-service-types
+            home-provenance
 
             %initialize-gettext)
 
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 2312e4d313..837fd96361 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -36,7 +36,8 @@ (define-module (guix scripts home)
   #:use-module (guix scripts)
   #:use-module (guix scripts package)
   #:use-module (guix scripts build)
-  #:use-module (guix scripts system search)
+  #:autoload   (guix scripts system search) (service-type->recutils)
+  #:use-module (guix scripts system reconfigure)
   #:autoload   (guix scripts pull) (channel-commit-hyperlink)
   #:use-module (guix scripts home import)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -91,6 +92,9 @@ (define (show-help)
   (display (G_ "
   -e, --expression=EXPR  consider the home-environment EXPR evaluates to
                          instead of reading FILE, when applicable"))
+  (display (G_ "
+      --allow-downgrades for 'reconfigure', allow downgrades to earlier
+                         channel revisions"))
   (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (newline)
@@ -127,18 +131,23 @@ (define %options
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
+         (option '("allow-downgrades") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'validate-reconfigure
+                               warn-about-backward-reconfigure
+                               result)))
          %standard-build-options))
 
 (define %default-options
-  `((build-mode . ,(build-mode normal))
-    (graft? . #t)
+  `((graft? . #t)
     (substitutes? . #t)
     (offload? . #t)
     (print-build-trace? . #t)
     (print-extended-build-trace? . #t)
     (multiplexed-build-output? . #t)
     (verbosity . #f)                              ;default
-    (debug . 0)))
+    (debug . 0)
+    (validate-reconfigure . ,ensure-forward-reconfigure)))
 
 
 ;;;
@@ -149,12 +158,17 @@ (define* (perform-action action he
                          #:key
                          dry-run?
                          derivations-only?
-                         use-substitutes?)
+                         use-substitutes?
+                         (validate-reconfigure ensure-forward-reconfigure))
   "Perform ACTION for home environment. "
 
   (define println
     (cut format #t "~a~%" <>))
 
+  (when (eq? action 'reconfigure)
+    (check-forward-update validate-reconfigure
+                          #:current-channels (home-provenance %guix-home)))
+
   (mlet* %store-monad
       ((he-drv   (home-environment-derivation he))
        (drvs     (mapm/accumulate-builds lower-object (list he-drv)))
@@ -237,13 +251,12 @@ (define (ensure-home-environment file-or-exp obj)
           (mbegin %store-monad
             (set-guile-for-build (default-guile))
 
-            (case action
-              (else
-               (perform-action action home-environment
-                               #:dry-run? dry?
-                               #:derivations-only? (assoc-ref opts 'derivations-only?)
-                               #:use-substitutes? (assoc-ref opts 'substitutes?))
-               ))))))
+            (perform-action action home-environment
+                            #:dry-run? dry?
+                            #:derivations-only? (assoc-ref opts 'derivations-only?)
+                            #:use-substitutes? (assoc-ref opts 'substitutes?)
+                            #:validate-reconfigure
+                            (assoc-ref opts 'validate-reconfigure))))))
     (warn-about-disk-space)))
 
 
-- 
cgit v1.2.3