(define-module (guix channels)
#:use-module (git)
#:use-module (guix git)
+ #:use-module (guix git-authenticate)
+ #:use-module ((guix openpgp)
+ #:select (openpgp-public-key-fingerprint
+ openpgp-format-fingerprint))
+ #:use-module (guix base16)
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix monads)
#:use-module (guix profiles)
#:use-module (guix packages)
+ #:use-module (guix progress)
#:use-module (guix derivations)
#:use-module (guix combinators)
#:use-module (guix diagnostics)
#:use-module (guix sets)
#:use-module (guix store)
#:use-module (guix i18n)
- #:use-module ((guix utils)
- #:select (source-properties->location
- &error-location
- &fix-hint))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:autoload (guix quirks) (%quirks %patches applicable-patch? apply-patch)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module ((ice-9 rdelim) #:select (read-string))
+ #:use-module ((rnrs bytevectors) #:select (bytevector=?))
#:export (channel
channel?
channel-name
channel-url
channel-branch
channel-commit
+ channel-introduction
channel-location
+ channel-introduction?
+ make-channel-introduction
+ channel-introduction-first-signed-commit
+ channel-introduction-first-commit-signer
+
+ openpgp-fingerprint->bytevector
+ openpgp-fingerprint
+
%default-channels
guix-channel?
channel-instance-commit
channel-instance-checkout
+ authenticate-channel
latest-channel-instances
checkout->channel-instance
latest-channel-derivation
(url channel-url)
(branch channel-branch (default "master"))
(commit channel-commit (default #f))
+ (introduction channel-introduction (default #f))
(location channel-location
(default (current-source-location)) (innate)))
+;; Channel introductions. A "channel introduction" provides a commit/signer
+;; pair that specifies the first commit of the authentication process as well
+;; as its signer's fingerprint. Introductions are used to bootstrap trust in
+;; a channel.
+(define-record-type <channel-introduction>
+ (%make-channel-introduction first-signed-commit first-commit-signer)
+ channel-introduction?
+ (first-signed-commit channel-introduction-first-signed-commit) ;hex string
+ (first-commit-signer channel-introduction-first-commit-signer)) ;bytevector
+
+(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))
+
+(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'
+ ;; branch that was eventually merged in 'master'. Any branch starting
+ ;; before that commit cannot be merged or it will be rejected by 'guix pull'
+ ;; & co.
+ (make-channel-introduction
+ "9edb3f66fd807b096b48283debdcddccfea34bad" ;2020-05-26
+ (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)
+ (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
+ (news-file channel-metadata-news-file) ;string | #f
+ (keyring-reference channel-metadata-keyring-reference) ;string
+ (url channel-metadata-url)) ;string | #f
+
+(define %default-keyring-reference
+ ;; Default value of the 'keyring-reference' field.
+ "keyring")
(define (channel-reference channel)
"Return the \"reference\" for CHANNEL, an sexp suitable for
(#f `(branch . ,(channel-branch channel)))
(commit `(commit . ,(channel-commit channel)))))
+(define sexp->channel-introduction
+ (match-lambda
+ (('channel-introduction ('version 0)
+ ('commit commit) ('signer signer)
+ _ ...)
+ (make-channel-introduction commit (openpgp-fingerprint signer)))
+ (x #f)))
+
(define (read-channel-metadata port)
"Read from PORT channel metadata in the format expected for the
'.guix-channel' file. Return a <channel-metadata> record, or raise an error
(('channel ('version 0) properties ...)
(let ((directory (and=> (assoc-ref properties 'directory) first))
(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
+ (or (and=> (assoc-ref properties 'keyring-reference) first)
+ %default-keyring-reference)))
(channel-metadata
(cond ((not directory) "/") ;directory
((string-prefix? "/" directory) directory)
(name name)
(branch branch)
(url url)
- (commit (get 'commit))))))
+ (commit (get 'commit))
+ (introduction (and=> (get 'introduction)
+ sexp->channel-introduction))))))
dependencies)
- news-file))) ;news-file
+ news-file
+ 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)
+ (channel-metadata "/" '() #f %default-keyring-reference #f)
(apply throw args)))))
(define (channel-instance-metadata instance)
(apply-patch patch checkout))
(loop rest)))))
+(define commit-short-id
+ (compose (cut string-take <> 7) oid->string commit-id))
+
+(define* (authenticate-channel channel checkout commit
+ #:key (keyring-reference-prefix "origin/"))
+ "Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a
+directory containing a CHANNEL checkout. Raise an error if authentication
+fails."
+ (define intro
+ (channel-introduction channel))
+
+ (define cache-key
+ (string-append "channels/" (symbol->string (channel-name channel))))
+
+ (define keyring-reference
+ (channel-metadata-keyring-reference
+ (read-channel-metadata-from-source checkout)))
+
+ (define (make-reporter start-commit end-commit 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))
+
+ (progress-reporter/bar (length commits)))
+
+ ;; XXX: Too bad we need to re-open CHECKOUT.
+ (with-repository checkout repository
+ (authenticate-repository repository
+ (string->oid
+ (channel-introduction-first-signed-commit intro))
+ (channel-introduction-first-commit-signer intro)
+ #:end (string->oid commit)
+ #:keyring-reference
+ (string-append keyring-reference-prefix
+ keyring-reference)
+ #:make-reporter make-reporter
+ #:cache-key cache-key)))
+
(define* (latest-channel-instance store channel
#:key (patches %patches)
- starting-commit)
- "Return two values: the latest channel instance for CHANNEL, and its
-relation to STARTING-COMMIT when provided."
+ 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. 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 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 (make-compound-condition
+ (formatted-message (G_ "channel '~a' lacks an \
+introduction and cannot be authenticated~%")
+ (channel-name channel))
+ (condition
+ (&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
;; safe to do because 'switch-to-ref' eventually does a hard reset.
(let* ((name (url+commit->name (channel-url channel) commit))
(checkout (add-to-store store name #t "sha256" checkout
#:select? (negate dot-git?))))
- (values (channel-instance channel commit checkout)
- relation))))
+ (channel-instance channel commit checkout))))
-(define (ensure-forward-channel-update channel start instance relation)
+(define (ensure-forward-channel-update channel start commit relation)
"Raise an error if RELATION is not 'ancestor, meaning that START is not an
-ancestor of the commit in INSTANCE, unless CHANNEL specifies a commit.
+ancestor of COMMIT, unless CHANNEL specifies a commit.
This procedure implements a channel update policy meant to be used as a
#:validate-pull argument."
('ancestor #t)
('self #t)
(_
- (raise (apply make-compound-condition
- (condition
- (&message (message
- (format #f (G_ "\
+ (raise (make-compound-condition
+ (condition
+ (&message (message
+ (format #f (G_ "\
aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
- (channel-name channel)
- (channel-instance-commit instance)
- start))))
-
- ;; Don't show the hint when the user explicitly specified a
- ;; commit in CHANNEL.
- (if (channel-commit channel)
- '()
- (list (condition
- (&fix-hint
- (hint (G_ "This could indicate that the channel has
+ (channel-name channel)
+ commit start))))
+
+ ;; If the user asked for a specific commit, they might want
+ ;; that to happen nevertheless, so tell them about the
+ ;; relevant 'guix pull' option.
+ (if (channel-commit channel)
+ (condition
+ (&fix-hint
+ (hint (G_ "Use @option{--allow-downgrades} to force
+this downgrade."))))
+ (condition
+ (&fix-hint
+ (hint (G_ "This could indicate that the channel has
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
-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
#: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,
(G_ "Updating channel '~a' from Git repository at '~a'...~%")
(channel-name channel)
(channel-url channel))
- (let*-values (((current)
- (current-commit (channel-name channel)))
- ((instance relation)
- (latest-channel-instance store channel
- #:starting-commit
- current)))
- (when relation
- (validate-pull channel current instance relation))
+ (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)
"Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
(define (instance->entry instance drv)
- (let ((commit (channel-instance-commit instance))
- (channel (channel-instance-channel instance)))
+ (let* ((commit (channel-instance-commit instance))
+ (channel (channel-instance-channel instance))
+ (intro (channel-introduction channel)))
(manifest-entry
(name (symbol->string (channel-name channel)))
(version (string-take commit 7))
(version 0)
(url ,(channel-url channel))
(branch ,(channel-branch channel))
- (commit ,commit))))))))
+ (commit ,commit)
+ ,@(if intro
+ `((introduction
+ (channel-introduction
+ (version 0)
+ (commit
+ ,(channel-introduction-first-signed-commit
+ intro))
+ (signer
+ ,(openpgp-format-fingerprint
+ (channel-introduction-first-commit-signer
+ intro))))))
+ '()))))))))
(mlet* %store-monad ((derivations (channel-instance-derivations instances))
(entries -> (map instance->entry instances derivations)))
('url url)
('branch branch)
('commit commit)
- _ ...))
+ rest ...))
(channel (name (string->symbol
(manifest-entry-name entry)))
(url url)
- (commit commit)))
+ (commit commit)
+ (introduction
+ (match (assq 'introduction rest)
+ (#f #f)
+ (('introduction intro)
+ (sexp->channel-introduction intro))))))
;; No channel information for this manifest entry.
;; XXX: Pre-0.15.0 Guix did not provide that information,
HCoop / jackhill / guix / guix.git / blobdiff