channels: Warn when pulling from a mirror.

* guix/channels.scm (<channel-metadata>)[url]: New field.
(read-channel-metadata): Initialize it.
(read-channel-metadata-from-source): Likewise.
(channel-instance-primary-url): New procedure.
(latest-channel-instances): Compare CHANNEL's URL against it.
* doc/guix.texi (Channels)[Primary URL]: New subsection.
This commit is contained in:
Ludovic Courtès 2020-06-15 16:20:14 +02:00
parent cb8c698e8d
commit 4ae762af76
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 47 additions and 4 deletions

View File

@ -4153,6 +4153,28 @@ add a meta-data file @file{.guix-channel} that contains:
(directory "guix")) (directory "guix"))
@end lisp @end lisp
@cindex primary URL, channels
@subsection Primary URL
Channel authors can indicate the primary URL of their channel's Git
repository in the @file{.guix-channel} file, like so:
@lisp
(channel
(version 0)
(url "https://example.org/guix.git"))
@end lisp
This allows @command{guix pull} to determine whether it is pulling code
from a mirror of the channel; when that is the case, it warns the user
that the mirror might be stale and displays the primary URL. That way,
users cannot be tricked into fetching code from a stale mirror that does
not receive security updates.
This feature only makes sense for authenticated repositories, such as
the official @code{guix} channel, for which @command{guix pull} ensures
the code it fetches is authentic.
@cindex news, for channels @cindex news, for channels
@subsection Writing Channel News @subsection Writing Channel News

View File

@ -182,12 +182,13 @@ introduction, add it."
(checkout channel-instance-checkout)) (checkout channel-instance-checkout))
(define-record-type <channel-metadata> (define-record-type <channel-metadata>
(channel-metadata directory dependencies news-file keyring-reference) (channel-metadata directory dependencies news-file keyring-reference url)
channel-metadata? channel-metadata?
(directory channel-metadata-directory) ;string with leading slash (directory channel-metadata-directory) ;string with leading slash
(dependencies channel-metadata-dependencies) ;list of <channel> (dependencies channel-metadata-dependencies) ;list of <channel>
(news-file channel-metadata-news-file) ;string | #f (news-file channel-metadata-news-file) ;string | #f
(keyring-reference channel-metadata-keyring-reference)) ;string (keyring-reference channel-metadata-keyring-reference) ;string
(url channel-metadata-url)) ;string | #f
(define %default-keyring-reference (define %default-keyring-reference
;; Default value of the 'keyring-reference' field. ;; Default value of the 'keyring-reference' field.
@ -209,6 +210,7 @@ if valid metadata could not be read from PORT."
(let ((directory (and=> (assoc-ref properties 'directory) first)) (let ((directory (and=> (assoc-ref properties 'directory) first))
(dependencies (or (assoc-ref properties 'dependencies) '())) (dependencies (or (assoc-ref properties 'dependencies) '()))
(news-file (and=> (assoc-ref properties 'news-file) first)) (news-file (and=> (assoc-ref properties 'news-file) first))
(url (and=> (assoc-ref properties 'url) first))
(keyring-reference (keyring-reference
(or (and=> (assoc-ref properties 'keyring-reference) first) (or (and=> (assoc-ref properties 'keyring-reference) first)
%default-keyring-reference))) %default-keyring-reference)))
@ -229,7 +231,8 @@ if valid metadata could not be read from PORT."
(commit (get 'commit)))))) (commit (get 'commit))))))
dependencies) dependencies)
news-file news-file
keyring-reference))) keyring-reference
url)))
((and ('channel ('version version) _ ...) sexp) ((and ('channel ('version version) _ ...) sexp)
(raise (condition (raise (condition
(&message (message "unsupported '.guix-channel' version")) (&message (message "unsupported '.guix-channel' version"))
@ -253,7 +256,7 @@ doesn't exist."
read-channel-metadata)) read-channel-metadata))
(lambda args (lambda args
(if (= ENOENT (system-error-errno args)) (if (= ENOENT (system-error-errno args))
(channel-metadata "/" '() #f %default-keyring-reference) (channel-metadata "/" '() #f %default-keyring-reference #f)
(apply throw args))))) (apply throw args)))))
(define (channel-instance-metadata instance) (define (channel-instance-metadata instance)
@ -463,6 +466,11 @@ been tampered with and is trying to force a roll-back, preventing you from
getting the latest updates. If you think this is not the case, explicitly getting the latest updates. If you think this is not the case, explicitly
allow non-forward updates.")))))))))) allow non-forward updates."))))))))))
(define (channel-instance-primary-url instance)
"Return the primary URL advertised for INSTANCE, or #f if there is no such
information."
(channel-metadata-url (channel-instance-metadata instance)))
(define* (latest-channel-instances store channels (define* (latest-channel-instances store channels
#:key #:key
(current-channels '()) (current-channels '())
@ -518,6 +526,19 @@ depending on the policy it implements."
validate-pull validate-pull
#:starting-commit #:starting-commit
current))) current)))
(when authenticate?
;; CHANNEL is authenticated so we can trust the
;; primary URL advertised in its metadata and warn
;; about possibly stale mirrors.
(let ((primary-url (channel-instance-primary-url
instance)))
(unless (or (not primary-url)
(channel-commit channel)
(string=? primary-url (channel-url channel)))
(warning (G_ "pulled channel '~a' from a mirror \
of ~a, which might be stale~%")
(channel-name channel)
primary-url))))
(let-values (((new-instances new-channels) (let-values (((new-instances new-channels)
(loop (channel-instance-dependencies instance) (loop (channel-instance-dependencies instance)