channel-location
channel-introduction?
- ;; <channel-introduction> accessors purposefully omitted for now.
+ make-channel-introduction
+ channel-introduction-first-signed-commit
+ channel-introduction-first-commit-signer
+
+ openpgp-fingerprint->bytevector
+ openpgp-fingerprint
%default-channels
guix-channel?
;; commit so that only them may emit this introduction. Introductions are
;; used to bootstrap trust in a channel.
(define-record-type <channel-introduction>
- (make-channel-introduction first-signed-commit first-commit-signer
- signature)
+ (%make-channel-introduction first-signed-commit first-commit-signer
+ signature)
channel-introduction?
(first-signed-commit channel-introduction-first-signed-commit) ;hex string
(first-commit-signer channel-introduction-first-commit-signer) ;bytevector
(signature channel-introduction-signature)) ;string
+(define (make-channel-introduction commit signer)
+ "Return a new channel introduction: COMMIT is the introductory where
+authentication starts, and SIGNER is the OpenPGP fingerprint (a bytevector) of
+the signer of that commit."
+ (%make-channel-introduction commit signer #f))
+
+(define (openpgp-fingerprint->bytevector str)
+ "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace),
+to the corresponding bytevector."
+ (base16-string->bytevector
+ (string-downcase (string-filter char-set:hex-digit str))))
+
+(define-syntax openpgp-fingerprint
+ (lambda (s)
+ "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace),
+to the corresponding bytevector."
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ (openpgp-fingerprint->bytevector (syntax->datum #'str)))
+ ((_ str)
+ #'(openpgp-fingerprint->bytevector str)))))
+
(define %guix-channel-introduction
;; Introduction of the official 'guix channel. The chosen commit is the
;; first one that introduces '.guix-authorizations' on the 'staging'
;; & co.
(make-channel-introduction
"9edb3f66fd807b096b48283debdcddccfea34bad" ;2020-05-26
- (base16-string->bytevector
- (string-downcase
- (string-filter char-set:hex-digit ;mbakke
- "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")))
- #f)) ;TODO: Add an intro signature so it can be exported.
+ (openpgp-fingerprint ;mbakke
+ "BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")))
+
+(define %default-channel-url
+ ;; URL of the default 'guix' channel.
+ "https://git.savannah.gnu.org/git/guix.git")
(define %default-channels
;; Default list of channels.
(list (channel
(name 'guix)
(branch "master")
- (url "https://git.savannah.gnu.org/git/guix.git")
+ (url %default-channel-url)
(introduction %guix-channel-introduction))))
(define (guix-channel? channel)
"Return true if CHANNEL is the 'guix' channel."
(eq? 'guix (channel-name channel)))
+(define (ensure-default-introduction chan)
+ "If CHAN represents the \"official\" 'guix' channel and lacks an
+introduction, add it."
+ (if (and (guix-channel? chan)
+ (not (channel-introduction chan))
+ (string=? (channel-url chan) %default-channel-url))
+ (channel (inherit chan)
+ (introduction %guix-channel-introduction))
+ chan))
+
(define-record-type <channel-instance>
(channel-instance channel commit checkout)
channel-instance?
(checkout channel-instance-checkout))
(define-record-type <channel-metadata>
- (channel-metadata directory dependencies news-file keyring-reference)
+ (channel-metadata directory dependencies news-file keyring-reference url)
channel-metadata?
(directory channel-metadata-directory) ;string with leading slash
(dependencies channel-metadata-dependencies) ;list of <channel>
(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
;; Default value of the 'keyring-reference' field.
(let ((directory (and=> (assoc-ref properties 'directory) first))
(dependencies (or (assoc-ref properties 'dependencies) '()))
(news-file (and=> (assoc-ref properties 'news-file) first))
+ (url (and=> (assoc-ref properties 'url) first))
(keyring-reference
(or (and=> (assoc-ref properties 'keyring-reference) first)
%default-keyring-reference)))
(commit (get 'commit))))))
dependencies)
news-file
- keyring-reference)))
+ keyring-reference
+ url)))
((and ('channel ('version version) _ ...) sexp)
(raise (condition
(&message (message "unsupported '.guix-channel' version"))
read-channel-metadata))
(lambda args
(if (= ENOENT (system-error-errno args))
- (channel-metadata "/" '() #f %default-keyring-reference)
+ (channel-metadata "/" '() #f %default-keyring-reference #f)
(apply throw args)))))
(define (channel-instance-metadata instance)
(define reporter
(progress-reporter/bar (length commits)))
- ;; When COMMITS is empty, it's either because AUTHENTICATED-COMMITS
- ;; contains END-COMMIT or because END-COMMIT is not a descendant of
- ;; START-COMMIT. Check that.
- (if (null? commits)
- (match (commit-relation start-commit end-commit)
- ((or 'self 'ancestor 'descendant) #t) ;nothing to do!
- ('unrelated
- (raise
- (condition
- (&message
- (message
- (format #f (G_ "'~a' is not related to introductory \
-commit of channel '~a'~%")
- (oid->string (commit-id end-commit))
- (channel-name channel))))))))
- (begin
- (format (current-error-port)
- (G_ "Authenticating channel '~a', \
+ ;; When COMMITS is empty, it's because END-COMMIT is in the closure of
+ ;; START-COMMIT and/or AUTHENTICATED-COMMITS, in which case it's known to
+ ;; be authentic already.
+ (unless (null? commits)
+ (format (current-error-port)
+ (G_ "Authenticating channel '~a', \
commits ~a to ~a (~h new commits)...~%")
- (channel-name channel)
- (commit-short-id start-commit)
- (commit-short-id end-commit)
- (length commits))
-
- ;; If it's our first time, verify CHANNEL's introductory commit.
- (when (null? authenticated-commits)
- (verify-introductory-commit repository
- (channel-introduction channel)
- keyring))
-
- (call-with-progress-reporter reporter
- (lambda (report)
- (authenticate-commits repository commits
- #:keyring keyring
- #:report-progress report)))
-
- (cache-authenticated-commit cache-key
- (oid->string
- (commit-id end-commit)))))))
+ (channel-name channel)
+ (commit-short-id start-commit)
+ (commit-short-id end-commit)
+ (length commits))
+
+ ;; If it's our first time, verify CHANNEL's introductory commit.
+ (when (null? authenticated-commits)
+ (verify-introductory-commit repository
+ (channel-introduction channel)
+ keyring))
+
+ (call-with-progress-reporter reporter
+ (lambda (report)
+ (authenticate-commits repository commits
+ #:keyring keyring
+ #:report-progress report)))
+
+ (cache-authenticated-commit cache-key
+ (oid->string
+ (commit-id end-commit))))))
(define* (latest-channel-instance store channel
#:key (patches %patches)
starting-commit
+ (authenticate? #f)
(validate-pull
ensure-forward-channel-update))
"Return the latest channel instance for CHANNEL. When STARTING-COMMIT is
true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
-their relation."
+their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated."
(define (dot-git? file stat)
(and (string=? (basename file) ".git")
(eq? 'directory (stat:type stat))))
- (let-values (((checkout commit relation)
+ (let-values (((channel)
+ (ensure-default-introduction channel))
+ ((checkout commit relation)
(update-cached-checkout (channel-url channel)
#:ref (channel-reference channel)
#:starting-commit starting-commit)))
(when relation
(validate-pull channel starting-commit commit relation))
- (if (channel-introduction channel)
- (authenticate-channel channel checkout commit)
- ;; TODO: Warn for all the channels once the authentication interface
- ;; is public.
- (when (guix-channel? channel)
- (warning (G_ "channel '~a' lacks an introduction and \
-cannot be authenticated~%")
- (channel-name channel))))
+ (if authenticate?
+ (if (channel-introduction channel)
+ (authenticate-channel channel checkout commit)
+ ;; TODO: Warn for all the channels once the authentication interface
+ ;; is public.
+ (when (guix-channel? channel)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "channel '~a' lacks an \
+introduction and cannot be authenticated~%")
+ (channel-name channel))))
+ (&fix-hint
+ (hint (G_ "Add the missing introduction to your
+channels file to address the issue. Alternatively, you can pass
+@option{--disable-authentication}, at the risk of running unauthenticated and
+thus potentially malicious code.")))))))
+ (warning (G_ "channel authentication disabled~%")))
(when (guix-channel? channel)
;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is
getting the latest updates. If you think this is not the case, explicitly
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
#:key
(current-channels '())
+ (authenticate? #t)
(validate-pull
ensure-forward-channel-update))
"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,
(let* ((current (current-commit (channel-name channel)))
(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
+ ;; 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)
(loop (channel-instance-dependencies instance)
HCoop / jackhill / guix / guix.git / blobdiff