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'.
This commit is contained in:
Ludovic Courtès 2022-01-23 16:21:03 +01:00
parent 50f7402c6a
commit 23ccfd3840
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 36 additions and 12 deletions

View file

@ -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 This is an alternative to specifying a file which evaluates to a home
environment. 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 @end table
@node Documentation @node Documentation

View file

@ -43,6 +43,7 @@ (define-module (gnu home services)
home-provenance-service-type home-provenance-service-type
fold-home-service-types fold-home-service-types
home-provenance
%initialize-gettext) %initialize-gettext)

View file

@ -36,7 +36,8 @@ (define-module (guix scripts home)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix scripts package) #:use-module (guix scripts package)
#:use-module (guix scripts build) #: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) #:autoload (guix scripts pull) (channel-commit-hyperlink)
#:use-module (guix scripts home import) #:use-module (guix scripts home import)
#:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix status) #:select (with-status-verbosity))
@ -91,6 +92,9 @@ (define (show-help)
(display (G_ " (display (G_ "
-e, --expression=EXPR consider the home-environment EXPR evaluates to -e, --expression=EXPR consider the home-environment EXPR evaluates to
instead of reading FILE, when applicable")) instead of reading FILE, when applicable"))
(display (G_ "
--allow-downgrades for 'reconfigure', allow downgrades to earlier
channel revisions"))
(display (G_ " (display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL")) -v, --verbosity=LEVEL use the given verbosity LEVEL"))
(newline) (newline)
@ -127,18 +131,23 @@ (define %options
(option '(#\e "expression") #t #f (option '(#\e "expression") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'expression 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)) %standard-build-options))
(define %default-options (define %default-options
`((build-mode . ,(build-mode normal)) `((graft? . #t)
(graft? . #t)
(substitutes? . #t) (substitutes? . #t)
(offload? . #t) (offload? . #t)
(print-build-trace? . #t) (print-build-trace? . #t)
(print-extended-build-trace? . #t) (print-extended-build-trace? . #t)
(multiplexed-build-output? . #t) (multiplexed-build-output? . #t)
(verbosity . #f) ;default (verbosity . #f) ;default
(debug . 0))) (debug . 0)
(validate-reconfigure . ,ensure-forward-reconfigure)))
;;; ;;;
@ -149,12 +158,17 @@ (define* (perform-action action he
#:key #:key
dry-run? dry-run?
derivations-only? derivations-only?
use-substitutes?) use-substitutes?
(validate-reconfigure ensure-forward-reconfigure))
"Perform ACTION for home environment. " "Perform ACTION for home environment. "
(define println (define println
(cut format #t "~a~%" <>)) (cut format #t "~a~%" <>))
(when (eq? action 'reconfigure)
(check-forward-update validate-reconfigure
#:current-channels (home-provenance %guix-home)))
(mlet* %store-monad (mlet* %store-monad
((he-drv (home-environment-derivation he)) ((he-drv (home-environment-derivation he))
(drvs (mapm/accumulate-builds lower-object (list he-drv))) (drvs (mapm/accumulate-builds lower-object (list he-drv)))
@ -237,13 +251,12 @@ (define (ensure-home-environment file-or-exp obj)
(mbegin %store-monad (mbegin %store-monad
(set-guile-for-build (default-guile)) (set-guile-for-build (default-guile))
(case action
(else
(perform-action action home-environment (perform-action action home-environment
#:dry-run? dry? #:dry-run? dry?
#:derivations-only? (assoc-ref opts 'derivations-only?) #:derivations-only? (assoc-ref opts 'derivations-only?)
#:use-substitutes? (assoc-ref opts 'substitutes?)) #:use-substitutes? (assoc-ref opts 'substitutes?)
)))))) #:validate-reconfigure
(assoc-ref opts 'validate-reconfigure))))))
(warn-about-disk-space))) (warn-about-disk-space)))