;;; 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>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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 discovery)
#: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 (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
- #:autoload (guix self) (whole-package)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #: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?
channel-instance-channel
channel-instance-commit
channel-instance-checkout
+ authenticate-channel
latest-channel-instances
checkout->channel-instance
latest-channel-derivation
channel-instances->manifest
- channel-instances->derivation))
+ %channel-profile-hooks
+ channel-instances->derivation
+ ensure-forward-channel-update
+
+ profile-channels
+
+ channel-news-entry?
+ channel-news-entry-commit
+ channel-news-entry-tag
+ channel-news-entry-title
+ channel-news-entry-body
+
+ channel-news-for-commit))
;;; Commentary:
;;;
(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 version dependencies)
+ (channel-metadata directory dependencies news-file keyring-reference url)
channel-metadata?
- (version channel-metadata-version)
- (dependencies channel-metadata-dependencies))
+ (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
+ (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 (read-channel-metadata instance)
+(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
+if valid metadata could not be read from PORT."
+ (match (read port)
+ (('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))
+ (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)
+ (else (string-append "/" directory)))
+ (map (lambda (item) ;dependencies
+ (let ((get (lambda* (key #:optional default)
+ (or (and=> (assoc-ref item key) first) default))))
+ (and-let* ((name (get 'name))
+ (url (get 'url))
+ (branch (get 'branch "master")))
+ (channel
+ (name name)
+ (branch branch)
+ (url url)
+ (commit (get 'commit))
+ (introduction (and=> (get 'introduction)
+ sexp->channel-introduction))))))
+ dependencies)
+ news-file
+ keyring-reference
+ url)))
+ ((and ('channel ('version version) _ ...) sexp)
+ (raise (condition
+ (&message (message "unsupported '.guix-channel' version"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties sexp)))))))
+ (sexp
+ (raise (condition
+ (&message (message "invalid '.guix-channel' file"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties sexp)))))))))
+
+(define (read-channel-metadata-from-source source)
+ "Return a channel-metadata record read from channel's SOURCE/.guix-channel
+description file, or return the default channel-metadata record if that file
+doesn't exist."
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file (string-append source "/.guix-channel")
+ read-channel-metadata))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (channel-metadata "/" '() #f %default-keyring-reference #f)
+ (apply throw args)))))
+
+(define (channel-instance-metadata instance)
"Return a channel-metadata record read from the channel INSTANCE's
-description file, or return #F if the channel instance does not include the
-file."
- (let* ((source (channel-instance-checkout instance))
- (meta-file (string-append source "/.guix-channel")))
- (and (file-exists? meta-file)
- (and-let* ((raw (call-with-input-file meta-file read))
- (version (and=> (assoc-ref raw 'version) first))
- (dependencies (or (assoc-ref raw 'dependencies) '())))
- (channel-metadata
- version
- (map (lambda (item)
- (let ((get (lambda* (key #:optional default)
- (or (and=> (assoc-ref item key) first) default))))
- (and-let* ((name (get 'name))
- (url (get 'url))
- (branch (get 'branch "master")))
- (channel
- (name name)
- (branch branch)
- (url url)
- (commit (get 'commit))))))
- dependencies))))))
+description file or its default value."
+ (read-channel-metadata-from-source (channel-instance-checkout instance)))
(define (channel-instance-dependencies instance)
"Return the list of channels that are declared as dependencies for the given
channel INSTANCE."
- (match (read-channel-metadata instance)
- (#f '())
- (($ <channel-metadata> version dependencies)
- dependencies)))
+ (channel-metadata-dependencies (channel-instance-metadata instance)))
+
+(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* (latest-channel-instances store channels #:optional (previous-channels '()))
+ (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)
(or (channel-commit b)
(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.
- (match (fold (lambda (channel acc)
- (match acc
- ((#:channels previous-channels #:instances instances)
- (if (ignore? channel previous-channels)
- acc
- (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)))
- (let-values (((new-instances new-channels)
- (latest-channel-instances
- store
- (channel-instance-dependencies instance)
- previous-channels)))
- `(#:channels
- ,(append (cons channel new-channels)
- previous-channels)
- #:instances
- ,(append (cons instance new-instances)
- instances))))))))))
- `(#:channels ,previous-channels #:instances ())
- channels)
- ((#:channels channels #:instances instances)
- (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))))
- channels)))))
+
+ (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)
+ (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))))
(define* (checkout->channel-instance checkout
#:key commit
;; place a set of compiled Guile modules in ~/.config/guix/latest.
1)
-(define (standard-module-derivation name source dependencies)
- "Return a derivation that builds the Scheme modules in SOURCE and that
-depend on DEPENDENCIES, a list of lowerable objects. The assumption is that
-SOURCE contains package modules to be added to '%package-module-path'."
- (define modules
- (scheme-modules* source))
-
- ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow
- ;; channel publishers to specify things such as the sub-directory where .scm
- ;; files live, files to exclude from the channel, preferred substitute URLs,
- ;; etc.
- (mlet* %store-monad ((compiled
- (compiled-modules modules
- #:name name
- #:module-path (list source)
- #:extensions dependencies)))
-
- (gexp->derivation name
- (with-extensions dependencies
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
-
- (let ((go (string-append #$output "/lib/guile/"
- (effective-version)
- "/site-ccache"))
- (scm (string-append #$output
- "/share/guile/site/"
- (effective-version))))
- (mkdir-p (dirname go))
- (symlink #$compiled go)
- (mkdir-p (dirname scm))
- (symlink #$source scm))))))))
+(define (standard-module-derivation name source core dependencies)
+ "Return a derivation that builds with CORE, a Guix instance, the Scheme
+modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
+objects. The assumption is that SOURCE contains package modules to be added
+to '%package-module-path'."
+
+ (let* ((metadata (read-channel-metadata-from-source source))
+ (directory (channel-metadata-directory metadata)))
+
+ (define build
+ ;; This is code that we'll run in CORE, a Guix instance, with its own
+ ;; modules and so on. That way, we make sure these modules are built for
+ ;; the right Guile version, with the right dependencies, and that they get
+ ;; to see the right (gnu packages …) modules.
+ (with-extensions dependencies
+ #~(begin
+ (use-modules (guix build compile)
+ (guix build utils)
+ (srfi srfi-26))
+
+ (define go
+ (string-append #$output "/lib/guile/" (effective-version)
+ "/site-ccache"))
+ (define scm
+ (string-append #$output "/share/guile/site/"
+ (effective-version)))
+
+ (let* ((subdir #$directory)
+ (source (string-append #$source subdir)))
+ (compile-files source go (find-files source "\\.scm$"))
+ (mkdir-p (dirname scm))
+ (symlink (string-append #$source subdir) scm))
+
+ scm)))
+
+ (gexp->derivation-in-inferior name build core)))
+
+(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."
+ (let loop ((quirks quirks))
+ (match quirks
+ (()
+ #f)
+ (((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 verbose? commit
+ #:key core verbose? commit
(dependencies '()))
"Return a derivation to build Guix from SOURCE, using the self-build script
-contained therein. Use COMMIT as the version string."
+contained therein; use COMMIT as the version string. When CORE is true, build
+package modules under SOURCE using CORE, an instance of Guix."
;; Running the self-build script makes it easier to update the build
;; procedure: the self-build script of the Guix-to-be-installed contains the
;; right dependencies, build procedure, etc., which the Guix-in-use may not
(if (file-exists? script)
(let ((build (save-module-excursion
(lambda ()
- (primitive-load script)))))
+ ;; Disable deprecation warnings; it's OK for SCRIPT to
+ ;; use deprecated APIs and the user doesn't have to know
+ ;; about it.
+ (parameterize ((guix-warning-port
+ (%make-void-port "w")))
+ (primitive-load script)))))
+ (guile (guile-for-source source)))
;; BUILD must be a monadic procedure of at least one argument: the
;; source tree.
;;
;; 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.
- (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 dependencies)))
+ (standard-module-derivation name source core dependencies)))
-(define* (build-channel-instance instance #:optional (dependencies '()))
+(define* (build-channel-instance instance
+ #:optional core (dependencies '()))
"Return, as a monadic value, the derivation for INSTANCE, a channel
instance. DEPENDENCIES is a list of extensions providing Guile modules that
INSTANCE depends on."
(channel-name (channel-instance-channel instance)))
(channel-instance-checkout instance)
#:commit (channel-instance-commit instance)
+ #:core core
#:dependencies dependencies))
+(define (resolve-dependencies instances)
+ "Return a procedure that, given one of the elements of INSTANCES, returns
+list of instances it depends on."
+ (define channel-instance-name
+ (compose channel-name channel-instance-channel))
+
+ (define table ;map a name to an instance
+ (fold (lambda (instance table)
+ (vhash-consq (channel-instance-name instance)
+ instance table))
+ vlist-null
+ instances))
+
+ (define edges
+ (fold (lambda (instance edges)
+ (fold (lambda (channel edges)
+ (let ((name (channel-name channel)))
+ (match (vhash-assq name table)
+ ((_ . target)
+ (vhash-consq instance target edges)))))
+ edges
+ (channel-instance-dependencies instance)))
+ vlist-null
+ instances))
+
+ (lambda (instance)
+ (vhash-foldq* cons '() instance edges)))
+
(define (channel-instance-derivations instances)
"Return the list of derivations to build INSTANCES, in the same order as
INSTANCES."
(guix-channel? (channel-instance-channel instance)))
instances))
- (define dependencies
- ;; Dependencies of CORE-INSTANCE.
- ;; FIXME: It would be best not to hard-wire this information here and
- ;; instead query it to CORE-INSTANCE.
- (list (module-ref (resolve-interface '(gnu packages gnupg))
- 'guile-gcrypt)
- (module-ref (resolve-interface '(gnu packages guile))
- 'guile-git)
- (module-ref (resolve-interface '(gnu packages guile))
- 'guile-bytestructures)))
-
- (mlet %store-monad ((core (build-channel-instance core-instance)))
- (mapm %store-monad
- (lambda (instance)
- (if (eq? instance core-instance)
- (return core)
- (match (channel-instance-dependencies instance)
- (()
- (build-channel-instance instance
- (cons core dependencies)))
- (channels
- (mlet %store-monad ((dependencies-derivation
- (latest-channel-derivation
- ;; %default-channels is used here to
- ;; ensure that the core channel is
- ;; available for channels declared as
- ;; dependencies.
- (append channels %default-channels))))
- (build-channel-instance instance
- (cons dependencies-derivation
- (cons core dependencies))))))))
- instances)))
+ (define edges
+ (resolve-dependencies instances))
+
+ (define (instance->derivation instance)
+ (mlet %store-monad ((system (current-system)))
+ (mcached (if (eq? instance core-instance)
+ (build-channel-instance instance)
+ (mlet %store-monad ((core (instance->derivation core-instance))
+ (deps (mapm %store-monad instance->derivation
+ (edges instance))))
+ (build-channel-instance instance core deps)))
+ instance
+ system)))
+
+ (unless core-instance
+ (let ((loc (and=> (any (compose channel-location channel-instance-channel)
+ instances)
+ source-properties->location)))
+ (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))))
+ '())))))
+
+ (mapm %store-monad instance->derivation instances))
(define (whole-package-for-legacy name modules)
"Return a full-blown Guix package for MODULES, a derivation that builds Guix
;; 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)
;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
;; dated May 30, 2018) did not depend on "guix-command.drv".
(not (find (lambda (input)
- (string-suffix? "-guix-command.drv"
- (derivation-input-path input)))
+ (string=? "guix-command"
+ (derivation-name
+ (derivation-input-derivation input))))
(derivation-inputs drv))))
(define (channel-instances->manifest instances)
"Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
- (define instance->entry
- (match-lambda
- ((instance drv)
- (let ((commit (channel-instance-commit instance))
- (channel (channel-instance-channel instance)))
- (with-monad %store-monad
- (return (manifest-entry
- (name (symbol->string (channel-name channel)))
- (version (string-take commit 7))
- (item (if (guix-channel? channel)
- (if (old-style-guix? drv)
- (whole-package-for-legacy
- (string-append name "-" version)
- drv)
- drv)
- drv))
- (properties
- `((source (repository
- (version 0)
- (url ,(channel-url channel))
- (branch ,(channel-branch channel))
- (commit ,commit))))))))))))
+ (define (instance->entry instance drv)
+ (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))
+ (item (if (guix-channel? channel)
+ (if (old-style-guix? drv)
+ (whole-package-for-legacy (string-append name "-" version)
+ drv)
+ drv)
+ drv))
+ (properties
+ `((source (repository
+ (version 0)
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (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 (mapm %store-monad instance->entry
- (zip instances derivations))))
+ (entries -> (map instance->entry instances derivations)))
(return (manifest entries))))
+(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."
+ (let ((profile (profile (content manifest) (hooks '()))))
+ (define build
+ #~(begin
+ (use-modules (gnu packages))
+
+ (if (defined? 'generate-package-cache)
+ (begin
+ ;; Delegate package cache generation to the inferior.
+ (format (current-error-port)
+ "Generating package cache for '~a'...~%"
+ #$profile)
+ (generate-package-cache #$output))
+ (mkdir #$output))))
+
+ (gexp->derivation-in-inferior "guix-package-cache" build
+ profile
+
+ ;; If the Guix in PROFILE is too old and
+ ;; lacks 'guix repl', don't build the cache
+ ;; instead of failing.
+ #:silent-failure? #t
+
+ #:properties '((type . profile-hook)
+ (hook . package-cache))
+ #:local-build? #t)))
+
+(define %channel-profile-hooks
+ ;; The default channel profile hooks.
+ (cons package-cache-file %default-profile-hooks))
+
(define (channel-instances->derivation instances)
"Return the derivation of the profile containing INSTANCES, a list of
channel instances."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
- (profile-derivation manifest)))
+ (profile-derivation manifest
+ #:hooks %channel-profile-hooks)))
(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)
+ "Return the list of channels corresponding to entries in PROFILE. If
+PROFILE is not a profile created by 'guix pull', return the empty list."
+ (filter-map (lambda (entry)
+ (match (assq 'source (manifest-entry-properties entry))
+ (('source ('repository ('version 0)
+ ('url url)
+ ('branch branch)
+ ('commit commit)
+ rest ...))
+ (channel (name (string->symbol
+ (manifest-entry-name entry)))
+ (url url)
+ (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,
+ ;; but there's not much we can do in that case.
+ (_ #f)))
+
+ ;; Show most recently installed packages last.
+ (reverse
+ (manifest-entries (profile-manifest profile)))))
+
+\f
+;;;
+;;; News.
+;;;
+
+;; Channel news.
+(define-record-type <channel-news>
+ (channel-news entries)
+ channel-news?
+ (entries channel-news-entries)) ;list of <channel-news-entry>
+
+;; News entry, associated with a specific commit of the channel.
+(define-record-type <channel-news-entry>
+ (channel-news-entry commit tag title body)
+ channel-news-entry?
+ (commit channel-news-entry-commit) ;hex string | #f
+ (tag channel-news-entry-tag) ;#f | string
+ (title channel-news-entry-title) ;list of language tag/string pairs
+ (body channel-news-entry-body)) ;list of language tag/string pairs
+
+(define (sexp->channel-news-entry entry)
+ "Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
+ (define (pair language message)
+ (cons (symbol->string language) message))
+
+ (match entry
+ (('entry ((and (or 'commit 'tag) type) commit-or-tag)
+ ('title ((? symbol? title-tags) (? string? titles)) ...)
+ ('body ((? symbol? body-tags) (? string? bodies)) ...)
+ _ ...)
+ (channel-news-entry (and (eq? type 'commit) commit-or-tag)
+ (and (eq? type 'tag) commit-or-tag)
+ (map pair title-tags titles)
+ (map pair body-tags bodies)))
+ (_
+ (raise (condition
+ (&message (message "invalid channel news entry"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties entry)))))))))
+
+(define (read-channel-news port)
+ "Read a channel news feed from PORT and return it as a <channel-news>
+record."
+ (match (false-if-exception (read port))
+ (('channel-news ('version 0) entries ...)
+ (channel-news (map sexp->channel-news-entry entries)))
+ (('channel-news ('version version) _ ...)
+ ;; This is an unsupported version from the future. There's nothing wrong
+ ;; with that (the user may simply need to upgrade the 'guix' channel to
+ ;; be able to read it), so silently ignore it.
+ (channel-news '()))
+ (#f
+ (raise (condition
+ (&message (message "syntactically invalid channel news file")))))
+ (sexp
+ (raise (condition
+ (&message (message "invalid channel news file"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties sexp)))))))))
+
+(define (resolve-channel-news-entry-tag repository entry)
+ "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup
+ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to
+the field its 'tag' refers to. A 'git-error' exception is raised if the tag
+cannot be found."
+ (if (channel-news-entry-commit entry)
+ entry
+ (let* ((tag (channel-news-entry-tag entry))
+ (reference (string-append "refs/tags/" tag))
+ (oid (reference-name->oid repository reference)))
+ (channel-news-entry (oid->string oid) tag
+ (channel-news-entry-title entry)
+ (channel-news-entry-body entry)))))
+
+(define* (channel-news-for-commit channel new #:optional old)
+ "Return a list of <channel-news-entry> for CHANNEL between commits OLD and
+NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL."
+ (catch 'git-error
+ (lambda ()
+ (let* ((checkout (update-cached-checkout (channel-url channel)
+ #:ref `(commit . ,new)))
+ (metadata (read-channel-metadata-from-source checkout))
+ (news-file (channel-metadata-news-file metadata))
+ (news-file (and news-file
+ (string-append checkout "/" news-file))))
+ (if (and news-file (file-exists? news-file))
+ (with-repository checkout repository
+ (let* ((news (call-with-input-file news-file
+ read-channel-news))
+ (entries (map (lambda (entry)
+ (resolve-channel-news-entry-tag repository
+ entry))
+ (channel-news-entries news))))
+ (if old
+ (let* ((new (commit-lookup repository (string->oid new)))
+ (old (commit-lookup repository (string->oid old)))
+ (commits (list->set
+ (map (compose oid->string commit-id)
+ (commit-difference new old)))))
+ (filter (lambda (entry)
+ (set-contains? commits
+ (channel-news-entry-commit entry)))
+ entries))
+ entries)))
+ '())))
+ (lambda (key error . rest)
+ ;; If commit NEW or commit OLD cannot be found, then something must be
+ ;; wrong (for example, the history of CHANNEL was rewritten and these
+ ;; commits no longer exist upstream), so quietly return the empty list.
+ (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