;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
(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))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-35)
#: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
channel-instances->manifest
%channel-profile-hooks
channel-instances->derivation
+ ensure-forward-channel-update
profile-channels
(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)
channel INSTANCE."
(channel-metadata-dependencies (channel-instance-metadata instance)))
-(define* (latest-channel-instances store channels #:optional (previous-channels '()))
+(define (apply-patches checkout commit patches)
+ "Apply the matching PATCHES to CHECKOUT, modifying files in place. The
+result is unspecified."
+ (let loop ((patches patches))
+ (match patches
+ (() #t)
+ ((patch rest ...)
+ (when (applicable-patch? patch checkout commit)
+ (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
+ (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 (((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.
+ (apply-patches checkout commit patches))
+
+ (let* ((name (url+commit->name (channel-url channel) commit))
+ (checkout (add-to-store store name #t "sha256" checkout
+ #:select? (negate dot-git?))))
+ (channel-instance channel commit checkout))))
+
+(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 COMMIT, unless CHANNEL specifies a commit.
+
+This procedure implements a channel update policy meant to be used as a
+#:validate-pull argument."
+ (match relation
+ ('ancestor #t)
+ ('self #t)
+ (_
+ (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)
+ 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."))))))))))
+
+(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. PREVIOUS-CHANNELS is a list
-of previously processed channels."
+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."
;; Only process channels that are unique, or that are more specific than a
;; previous channel specification.
(define (ignore? channel others)
(not (or (channel-commit a)
(channel-commit b))))))))
- ;; Accumulate a list of instances. A list of processed channels is also
- ;; accumulated to decide on duplicate channel specifications.
- (define-values (resulting-channels instances)
- (fold2 (lambda (channel previous-channels instances)
- (if (ignore? channel previous-channels)
- (values previous-channels instances)
- (begin
- (format (current-error-port)
- (G_ "Updating channel '~a' from Git repository at '~a'...~%")
- (channel-name channel)
- (channel-url channel))
- (let-values (((checkout commit)
- (latest-repository-commit store (channel-url channel)
- #:ref (channel-reference
- channel))))
- (let ((instance (channel-instance channel commit checkout)))
+ (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))
+
+ (let loop ((channels channels)
+ (previous-channels '()))
+ ;; Accumulate a list of instances. A list of processed channels is also
+ ;; accumulated to decide on duplicate channel specifications.
+ (define-values (resulting-channels instances)
+ (fold2 (lambda (channel previous-channels instances)
+ (if (ignore? channel previous-channels)
+ (values previous-channels instances)
+ (begin
+ (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)))
+ (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)
- (latest-channel-instances
- store
- (channel-instance-dependencies instance)
- previous-channels)))
+ (loop (channel-instance-dependencies instance)
+ previous-channels)))
(values (append (cons channel new-channels)
previous-channels)
(append (cons instance new-instances)
- instances))))))))
- previous-channels
- '() ;instances
- channels))
-
- (let ((instance-name (compose channel-name channel-instance-channel)))
- ;; Remove all earlier channel specifications if they are followed by a
- ;; more specific one.
- (values (delete-duplicates instances
- (lambda (a b)
- (eq? (instance-name a) (instance-name b))))
- resulting-channels)))
+ instances)))))))
+ previous-channels
+ '() ;instances
+ channels))
+
+ (let ((instance-name (compose channel-name channel-instance-channel)))
+ ;; Remove all earlier channel specifications if they are followed by a
+ ;; more specific one.
+ (values (delete-duplicates instances
+ (lambda (a b)
+ (eq? (instance-name a) (instance-name b))))
+ resulting-channels))))
(define* (checkout->channel-instance checkout
#:key commit
(gexp->derivation-in-inferior name build core)))
-(define (syscalls-reexports-local-variables? source)
- "Return true if (guix build syscalls) contains the bug described at
-<https://bugs.gnu.org/36723>."
- (catch 'system-error
- (lambda ()
- (define content
- (call-with-input-file (string-append source
- "/guix/build/syscalls.scm")
- read-string))
-
- ;; The faulty code would use the 're-export' macro, causing the
- ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using
- ;; Guile > 2.2.4.
- (string-contains content "(re-export variable)"))
- (lambda args
- (if (= ENOENT (system-error-errno args))
- #f
- (apply throw args)))))
-
-(define (guile-2.2.4)
- (module-ref (resolve-interface '(gnu packages guile))
- 'guile-2.2.4))
-
-(define %quirks
- ;; List of predicate/package pairs. This allows us provide information
- ;; about specific Guile versions that old Guix revisions might need to use
- ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
- ;; <https://bugs.gnu.org/37506>
- `((,syscalls-reexports-local-variables? . ,guile-2.2.4)))
-
(define* (guile-for-source source #:optional (quirks %quirks))
"Return the Guile package to use when building SOURCE or #f if the default
'%guile-for-build' should be good enough."
(((predicate . guile) rest ...)
(if (predicate source) (guile) (loop rest))))))
+(define (call-with-guile guile thunk)
+ (lambda (store)
+ (values (parameterize ((%guile-for-build
+ (if guile
+ (package-derivation store guile)
+ (%guile-for-build))))
+ (run-with-store store (thunk)))
+ store)))
+
+(define-syntax-rule (with-guile guile exp ...)
+ "Set GUILE as the '%guile-for-build' parameter for the dynamic extent of
+EXP, a series of monadic expressions."
+ (call-with-guile guile (lambda ()
+ (mbegin %store-monad exp ...))))
+
+(define (with-trivial-build-handler mvalue)
+ "Run MVALUE, a monadic value, with a \"trivial\" build handler installed
+that unconditionally resumes the continuation."
+ (lambda (store)
+ (with-build-handler (lambda (continue . _)
+ (continue #t))
+ (values (run-with-store store mvalue)
+ store))))
+
(define* (build-from-source name source
#:key core verbose? commit
(dependencies '()))
;; Note: BUILD can return #f if it does not support %PULL-VERSION. In
;; the future we'll fall back to a previous version of the protocol
;; when that happens.
- (mbegin %store-monad
- (mwhen guile
- (set-guile-for-build guile))
- (build source #:verbose? verbose? #:version commit
- #:pull-version %pull-version)))
+ (with-guile guile
+ ;; BUILD is usually quite costly. Install a "trivial" build handler
+ ;; so we don't bounce an outer build-accumulator handler that could
+ ;; cause us to redo half of the BUILD computation several times just
+ ;; to realize it gives the same result.
+ (with-trivial-build-handler
+ (build source #:verbose? verbose? #:version commit
+ #:pull-version %pull-version))))
;; Build a set of modules that extend Guix using the standard method.
(standard-module-derivation name source core dependencies)))
(raise (apply make-compound-condition
(condition
(&message (message "'guix' channel is lacking")))
+ (condition
+ (&fix-hint (hint (G_ "Make sure your list of channels
+contains one channel named @code{guix} providing the core of Guix."))))
(if loc
(list (condition (&error-location (location loc))))
'())))))
;; In the "old style", %SELF-BUILD-FILE would simply return a
;; derivation that builds modules. We have to infer what the
;; dependencies of these modules were.
- (list guile-json guile-git guile-bytestructures
+ (list guile-json-3 guile-git guile-bytestructures
(ssh -> guile-ssh) (tls -> gnutls)))))
(define (old-style-guix? drv)
"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)))
(define (package-cache-file manifest)
"Build a package cache file for the instance in MANIFEST. This is meant to
be used as a profile hook."
- (mlet %store-monad ((profile (profile-derivation manifest
- #:hooks '())))
-
+ (let ((profile (profile (content manifest) (hooks '()))))
(define build
#~(begin
(use-modules (gnu packages))
(define latest-channel-instances*
(store-lift latest-channel-instances))
-(define* (latest-channel-derivation #:optional (channels %default-channels))
+(define* (latest-channel-derivation #:optional (channels %default-channels)
+ #:key
+ (current-channels '())
+ (validate-pull
+ ensure-forward-channel-update))
"Return as a monadic value the derivation that builds the profile for the
-latest instances of CHANNELS."
- (mlet %store-monad ((instances (latest-channel-instances* channels)))
+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-instances->derivation instances)))
(define (profile-channels profile)
('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,
(if (= GIT_ENOTFOUND (git-error-code error))
'()
(apply throw key error rest)))))
+
+;;; Local Variables:
+;;; eval: (put 'with-guile 'scheme-indent-function 1)
+;;; End:
HCoop / jackhill / guix / guix.git / blobdiff