@@ -4565,15 +4565,22 @@ Invoking guix pull
Show which channel commit(s) would be used and what would be built or
substituted but do not actually do it.
-@item --allow-downgrades
-Allow pulling older or unrelated revisions of channels than those
-currently in use.
+@item --allow-downgrades[=channels]
+@itemx -a [channels]
+Allows pulling older or unrelated revisions of specified channels, or
+all channels if none are specified.
@cindex downgrade attacks, protection against
-By default, @command{guix pull} protects against so-called ``downgrade
-attacks'' whereby the Git repository of a channel would be reset to an
-earlier or unrelated revision of itself, potentially leading you to
-install older, known-vulnerable versions of software packages.
+By default, @command{guix pull} safeguards against so-called ``downgrade
+attacks``, where a channel's Git repository is reset to a previous or
+unrelated revision, potentially causing the installation of older,
+vulnerable software versions. Without specifying channels, this
+protection is disabled entirely, posing a security risk.
+
+It's advisable to permit downgrades only for channels you trust
+implicitly, such as those you maintain. For all other channels,
+including the official Guix channel, downgrade protection remains
+recommended.
@quotation Note
Make sure you understand its security implications before using
@@ -497,26 +497,35 @@ (define (channel-instance-primary-url instance)
(define* (latest-channel-instances store channels
#:key
- (current-channels '())
- (authenticate? #t)
- (validate-pull
- ensure-forward-channel-update))
+ (channel-validation-pairs '())
+ (authenticate? #t))
"Return a list of channel instances corresponding to the latest checkouts of
CHANNELS and the channels on which they depend.
When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
\"channel introduction\".
-CURRENT-CHANNELS is the list of currently used channels. It is compared
-against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
-for each channel update and can choose to emit warnings or raise an error,
-depending on the policy it implements."
+CHANNEL-VALIDATION-PAIRS is a list of pairs of currently used channels with their
+respective validation procedures: (current-channel . validate-pull). The
+current-channel is compared against the newly-fetched instances of CHANNELS, and its
+validate-pull procedure is called for each channel update and can choose to emit
+warnings or raise an error, depending on the policy it implements."
(define (current-commit name)
- ;; Return the current commit for channel NAME.
- (any (lambda (channel)
- (and (eq? (channel-name channel) name)
- (channel-commit channel)))
- current-channels))
+ "Return the current commit for channel NAME."
+ (any (lambda (channel-with-validation)
+ (let ((channel (car channel-with-validation)))
+ (and (eq? (channel-name channel) name)
+ (channel-commit channel))))
+ channel-validation-pairs))
+
+ (define (current-validate-pull name)
+ "Return the desired validate-pull procedure for channel NAME."
+ (any (lambda (channel-with-validation)
+ (let ((channel (car channel-with-validation))
+ (validate-pull (cdr channel-with-validation)))
+ (and (eq? (channel-name channel) name)
+ validate-pull)))
+ channel-validation-pairs))
(define instance-name
(compose channel-name channel-instance-channel))
@@ -544,20 +553,22 @@ (define* (latest-channel-instances store channels
(if (and previous
(not (more-specific? channel previous)))
(loop rest previous-channels instances)
- (begin
+ (let ((current (current-commit (channel-name channel)))
+ (validate-pull (current-validate-pull (channel-name channel))))
+ ;; (format #t "channel '~a' is validated by '~a'~%"
+ ;; (channel-name channel) (procedure-name validate-pull))
(format (current-error-port)
(G_ "Updating channel '~a' from Git repository at '~a'...~%")
(channel-name channel)
(channel-url channel))
- (let* ((current (current-commit (channel-name channel)))
- (instance
- (latest-channel-instance store channel
- #:authenticate?
- authenticate?
- #:validate-pull
- validate-pull
- #:starting-commit
- current)))
+ (let ((instance
+ (latest-channel-instance store channel
+ #:authenticate?
+ authenticate?
+ #:validate-pull
+ validate-pull
+ #:starting-commit
+ current)))
(when authenticate?
;; CHANNEL is authenticated so we can trust the
;; primary URL advertised in its metadata and warn
@@ -1001,7 +1012,7 @@ (define latest-channel-instances*
(define* (latest-channel-derivation #:optional (channels %default-channels)
#:key
- (current-channels '())
+ (channel-validation-pairs '())
(validate-pull
ensure-forward-channel-update))
"Return as a monadic value the derivation that builds the profile for the
@@ -1010,7 +1021,7 @@ (define* (latest-channel-derivation #:optional (channels %default-channels)
(mlet %store-monad ((instances
(latest-channel-instances* channels
#:current-channels
- current-channels
+ channel-validation-pairs
#:validate-pull
validate-pull)))
(channel-instances->derivation instances)))
@@ -76,8 +76,7 @@ (define %default-options
(graft? . #t)
(debug . 0)
(verbosity . 1)
- (authenticate-channels? . #t)
- (validate-pull . ,ensure-forward-channel-update)))
+ (authenticate-channels? . #t)))
(define (show-help)
(display (G_ "Usage: guix pull [OPTION]...
@@ -94,7 +93,8 @@ (define (show-help)
(display (G_ "
--branch=BRANCH download the tip of the specified \"guix\" channel BRANCH"))
(display (G_ "
- --allow-downgrades allow downgrades to earlier channel revisions"))
+ -a, --allow-downgrades[=CHANNELS]
+ allow downgrades to earlier revisions of CHANNELS"))
(display (G_ "
--disable-authentication
disable channel authentication"))
@@ -176,10 +176,37 @@ (define %options
(option '("branch") #t #f
(lambda (opt name arg result)
(alist-cons 'ref `(branch . ,arg) result)))
- (option '("allow-downgrades") #f #f
+ (option '(#\a "allow-downgrades") #f #t
(lambda (opt name arg result)
- (alist-cons 'validate-pull warn-about-backward-updates
- result)))
+ (cond
+ ((string? arg)
+ ((compose
+ (cut alist-cons 'allow-downgrades <>
+ (alist-delete 'allow-downgrades result))
+ (cut append
+ (or (assoc-ref result 'allow-downgrades)
+ (list))
+ <>))
+ ;; Values may be also comma-separated. Possibilities:
+ ;; -a val1 -a val2,val3 -a val4 -aval5
+ (string-tokenize arg
+ (char-set-complement (char-set #\,)))))
+ ((boolean? arg)
+ ;; The command contains this option with no value
+ ;; specified, (`arg' is #f). We'll interpreted this as
+ ;; 'all channels can be downgraded'
+ (alist-cons 'allow-downgrades #t result))
+ (else
+ ((compose
+ (lambda (text)
+ (raise (condition (&message (message text)))))
+ (cut format #f <>
+ "You found a bug:" arg name
+ version system %guix-version
+ %guix-bug-report-address))
+ "~a The value '~a' of the '~a' option is unrecognized.
+(version: ~s; system: ~s; host version: ~s)
+Please report the COMPLETE output above by email to <~a>.~%")))))
(option '("disable-authentication") #f #f
(lambda (opt name arg result)
(alist-cons 'authenticate-channels? #f result)))
@@ -828,6 +855,41 @@ (define (validate-cache-directory-ownership)
@command{sudo -i} or equivalent if you really want to pull as ~a.")
dir:user our:user)))))))))))
+(define (channels-with-validations downgradable-candidates channels)
+ "Return a list of pairs: channel + pull-validation procedure. The procedure
+is `warn-about-backward-updates' if a given channel is among the
+DOWNGRADABLE-CANDIDATES or `ensure-forward-channel-update' otherwise. E.g.:
+
+((channel1 . #<procedure warn-about-backward-updates ...>)
+ (channel2 . #<procedure ensure-forward-channel-update ...>))"
+ (cond
+ ((and (list? downgradable-candidates) (not (null? downgradable-candidates)))
+ (let ((downgradables-candidate-names (map string->symbol
+ downgradable-candidates))
+ (channels-names (map channel-name channels)))
+ (map (lambda (name)
+ (unless (member name channels-names)
+ (leave (G_ "'~a' must be one of '~a~'%") name channels-names)))
+ downgradables-candidate-names)
+ (let* ((downgradables-names
+ (filter (cut member <> downgradables-candidate-names)
+ channels-names))
+ (downgradables
+ (filter (compose (cut member <> downgradables-names)
+ (cut channel-name <>))
+ channels))
+ (non-downgradables (lset-difference equal? channels
+ downgradables)))
+ (append
+ (map (cut cons <> warn-about-backward-updates) downgradables)
+ (map (cut cons <> ensure-forward-channel-update) non-downgradables)))))
+
+ ((and (boolean? downgradable-candidates) downgradable-candidates)
+ (map (cut cons <> warn-about-backward-updates) channels))
+
+ (else
+ (map (cut cons <> ensure-forward-channel-update) channels))))
+
(define-command (guix-pull . args)
(synopsis "pull the latest revision of Guix")
@@ -844,7 +906,7 @@ (define-command (guix-pull . args)
(dry-run? (assoc-ref opts 'dry-run?))
(profile (or (assoc-ref opts 'profile) %current-profile))
(current-channels (profile-channels profile))
- (validate-pull (assoc-ref opts 'validate-pull))
+ (allow-downgrades (assoc-ref opts 'allow-downgrades))
(authenticate? (assoc-ref opts 'authenticate-channels?)))
(cond
((assoc-ref opts 'query)
@@ -868,14 +930,17 @@ (define-command (guix-pull . args)
(set-build-options-from-command-line store opts)
(ensure-default-profile)
(honor-x509-certificates store)
-
(let* ((channels (channel-list opts))
+ (channel-validation-pairs
+ ;; Only current-channels can be checked against
+ ;; downgrade-attacks. New channels can't be
+ ;; downgraded. Their commit history is unknown yet.
+ (channels-with-validations allow-downgrades
+ current-channels))
(instances
(latest-channel-instances store channels
- #:current-channels
- current-channels
- #:validate-pull
- validate-pull
+ #:channel-validation-pairs
+ channel-validation-pairs
#:authenticate?
authenticate?)))
(format (current-error-port)