From 982f7c8531c342b76508acd5c219851d03bfbb13 Mon Sep 17 00:00:00 2001
Message-ID: <982f7c8531c342b76508acd5c219851d03bfbb13.1713191302.git.Rostislav.Svoboda@gmail.com>
From: Rostislav Svoboda <Rostislav.Svoboda@gmail.com>
Date: Wed, 10 Apr 2024 19:36:33 +0200
Subject: [PATCH] pull: Add fine-grained control for `guix pull
--allow-downgrades`.
Introduce the ability to specify channels for downgrades in `guix pull`,
enhancing security by enabling users to trust certain channels over
others. This update maintains backward compatibility and updates relevant
documentation.
* guix/scripts/pull.scm (allow-downgrades): Option accepts a list of
downgradable channels, add '-a' as its short version.
(%default-options): Remove validate-pull.
(channels-with-validations): New procedure.
* guix/channels.scm (latest-channel-instances): Signature change.
* doc/guix.texi (Invoking guix pull): Document changes.
* test/channels.scm (latest-channel-instances validate-pull): Adopt
latest-channel-instances signature change.
* guix/inferior.scm (cached-channel-instance): Adopt latest-channel-instances
signature change.
* guix/scripts/time-machine.scm (guix-time-machine): Adopt
latest-channel-instances signature change. (%reference-channels): compute JIT
Change-Id: If947a2453c520463d77da9591af9ac03e6472afc
---
doc/guix.texi | 21 ++++++---
guix/channels.scm | 67 ++++++++++++++------------
guix/inferior.scm | 17 +++----
guix/scripts/pull.scm | 89 ++++++++++++++++++++++++++++++-----
guix/scripts/time-machine.scm | 17 ++++---
tests/channels.scm | 8 ++--
6 files changed, 146 insertions(+), 73 deletions(-)
@@ -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,18 +1012,14 @@ (define latest-channel-instances*
(define* (latest-channel-derivation #:optional (channels %default-channels)
#:key
- (current-channels '())
- (validate-pull
- ensure-forward-channel-update))
+ (channel-validation-pairs '()))
"Return as a monadic value the derivation that builds the profile for the
latest instances of CHANNELS. CURRENT-CHANNELS and VALIDATE-PULL are passed
to 'latest-channel-instances'."
(mlet %store-monad ((instances
(latest-channel-instances* channels
- #:current-channels
- current-channels
- #:validate-pull
- validate-pull)))
+ #:channel-validation-pairs
+ channel-validation-pairs)))
(channel-instances->derivation instances)))
(define* (sexp->channel sexp #:optional (name 'channel))
@@ -872,17 +872,16 @@ (define* (cached-channel-instance store
(authenticate? #t)
(cache-directory (%inferior-cache-directory))
(ttl (* 3600 24 30))
- (reference-channels '())
- (validate-channels (const #t)))
+ (channel-validation-pairs '()))
"Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
The directory is a subdirectory of CACHE-DIRECTORY, where entries can be
reclaimed after TTL seconds. This procedure opens a new connection to the
build daemon. AUTHENTICATE? determines whether CHANNELS are authenticated.
-VALIDATE-CHANNELS must be a four-argument procedure used to validate channel
-instances against REFERENCE-CHANNELS; it is passed as #:validate-pull to
-'latest-channel-instances' and should raise an exception in case a target
-channel commit is deemed \"invalid\"."
+CHANNEL-VALIDATION-PAIRS must be a list of pairs (channel . validation-pull) where
+validation-pull is a four-argument procedure used to validate corresponding channel
+instance. This procedure 'latest-channel-instances' and should raise an exception in
+case a target channel commit is deemed \"invalid\"."
(define commits
;; Since computing the instances of CHANNELS is I/O-intensive, use a
;; cheaper way to get the commit list of CHANNELS. This limits overhead
@@ -935,10 +934,8 @@ (define* (cached-channel-instance store
-> (latest-channel-instances store channels
#:authenticate?
authenticate?
- #:current-channels
- reference-channels
- #:validate-pull
- validate-channels))
+ #:channel-validation-pairs
+ channel-validation-pairs))
(profile
(channel-instances->derivation instances)))
(mbegin %store-monad
@@ -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 + validate-pull 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)
@@ -149,10 +149,6 @@ (define (parse-args args)
(define %oldest-possible-commit
"4a0b87f0ec5b6c2dcf82b372dd20ca7ea6acdd9c") ;v0.16.0
-(define %reference-channels
- (list (channel (inherit %default-guix-channel)
- (commit %oldest-possible-commit))))
-
(define (validate-guix-channel channel start commit relation)
"Raise an error if CHANNEL is the 'guix' channel and the RELATION of COMMIT
to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor."
@@ -180,7 +176,12 @@ (define-command (guix-time-machine . args)
(substitutes? (assoc-ref opts 'substitutes?))
(authenticate? (assoc-ref opts 'authenticate-channels?)))
(if command-line
- (let* ((directory
+ (let* ((channel-validation-pairs
+ (list (cons (channel (inherit %default-guix-channel)
+ (commit %oldest-possible-commit))
+ validate-guix-channel)))
+
+ (directory
(with-store store
(with-status-verbosity (assoc-ref opts 'verbosity)
(with-build-handler (build-notifier #:use-substitutes?
@@ -191,10 +192,8 @@ (define-command (guix-time-machine . args)
(set-build-options-from-command-line store opts)
(cached-channel-instance store channels
#:authenticate? authenticate?
- #:reference-channels
- %reference-channels
- #:validate-channels
- validate-guix-channel)))))
+ #:channel-validation-pairs
+ channel-validation-pairs)))))
(executable (string-append directory "/bin/guix")))
(apply execl (cons* executable executable command-line)))
(warning (G_ "no command specified; nothing to do~%")))))))
@@ -245,10 +245,8 @@ (define channel-metadata-dependencies
(string=? (channel-instance-commit instance1)
(channel-instance-commit instance2)))))))))))
-(test-equal "latest-channel-instances #:validate-pull"
+(test-equal "latest-channel-instances validate-pull"
'descendant
-
- ;; Make sure the #:validate-pull procedure receives the right values.
(let/ec return
(with-temporary-git-repository directory
'((add "a.txt" "A")
@@ -275,8 +273,8 @@ (define channel-metadata-dependencies
(with-store store
;; Attempt a downgrade from NEW to OLD.
(latest-channel-instances store (list old)
- #:current-channels (list new)
- #:validate-pull validate-pull)))))))
+ #:channel-validation-pairs
+ (list (cons new validate-pull)))))))))
(test-assert "channel-instances->manifest"
;; Compute the manifest for a graph of instances and make sure we get a
base-commit: a8353e9d6b34fd8d42d2e8f14ce844849fe9c293
--
2.41.0
> Argh, the patch flawed. Please ignore it for now. Sorry. Corrected. Please have a look at the attachment. Thx. Cheers, Bost