summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-07-16 00:01:17 +0200
committerLudovic Courtès <ludo@gnu.org>2020-07-23 00:22:25 +0200
commit8e31736b0a60919cc1bfc5dc22c395b09243484a (patch)
tree13998cb2b522e4aaea14e23aff1f772a22cd5431 /guix
parenta620c9d51d57c8277ec75892c7eee8f9c84fa96f (diff)
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'.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/system.scm15
-rw-r--r--guix/scripts/system/reconfigure.scm97
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)))