mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 13:58:15 -05:00
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:
parent
50f7402c6a
commit
23ccfd3840
3 changed files with 36 additions and 12 deletions
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue