diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-10-08 19:24:34 +0200 |
commit | d1f3b333e6176a7879ab3742bbebb2a99f61a528 (patch) | |
tree | 8bd82ce68bd2534a48bf13c7256997f82dd1b3f4 /guix/channels.scm | |
parent | e01d384efcdaf564bbb221e43b81e087c8e2af06 (diff) | |
parent | 861907f01efb1cae7f260e8cb7b991d5034a486a (diff) | |
download | guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar.gz |
Merge branch 'master' into staging
Diffstat (limited to 'guix/channels.scm')
-rw-r--r-- | guix/channels.scm | 223 |
1 files changed, 212 insertions, 11 deletions
diff --git a/guix/channels.scm b/guix/channels.scm index 415246cbd1..2c28dccbcb 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -19,6 +19,7 @@ ;;; 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 records) #:use-module (guix gexp) @@ -26,9 +27,11 @@ #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) + #:use-module (guix packages) #: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) @@ -38,12 +41,14 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #: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 #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module ((ice-9 rdelim) #:select (read-string)) #:export (channel channel? channel-name @@ -65,7 +70,17 @@ latest-channel-derivation channel-instances->manifest %channel-profile-hooks - channel-instances->derivation)) + channel-instances->derivation + + 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: ;;; @@ -108,10 +123,11 @@ (checkout channel-instance-checkout)) (define-record-type <channel-metadata> - (channel-metadata directory dependencies) + (channel-metadata directory dependencies news-file) channel-metadata? (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 (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for @@ -127,12 +143,13 @@ 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) '()))) + (dependencies (or (assoc-ref properties 'dependencies) '())) + (news-file (and=> (assoc-ref properties 'news-file) first))) (channel-metadata - (cond ((not directory) "/") + (cond ((not directory) "/") ;directory ((string-prefix? "/" directory) directory) (else (string-append "/" directory))) - (map (lambda (item) + (map (lambda (item) ;dependencies (let ((get (lambda* (key #:optional default) (or (and=> (assoc-ref item key) first) default)))) (and-let* ((name (get 'name)) @@ -143,7 +160,8 @@ if valid metadata could not be read from PORT." (branch branch) (url url) (commit (get 'commit)))))) - dependencies)))) + dependencies) + news-file))) ;news-file ((and ('channel ('version version) _ ...) sexp) (raise (condition (&message (message "unsupported '.guix-channel' version")) @@ -167,7 +185,7 @@ doesn't exist." read-channel-metadata)) (lambda args (if (= ENOENT (system-error-errno args)) - (channel-metadata "/" '()) + (channel-metadata "/" '() #f) (apply throw args))))) (define (channel-instance-metadata instance) @@ -290,6 +308,46 @@ to '%package-module-path'." (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." + (let loop ((quirks quirks)) + (match quirks + (() + #f) + (((predicate . guile) rest ...) + (if (predicate source) (guile) (loop rest)))))) + (define* (build-from-source name source #:key core verbose? commit (dependencies '())) @@ -311,15 +369,19 @@ package modules under SOURCE using CORE, an instance of Guix." ;; about it. (parameterize ((guix-warning-port (%make-void-port "w"))) - (primitive-load script)))))) + (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)) + (mbegin %store-monad + (mwhen guile + (set-guile-for-build guile)) + (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))) @@ -534,3 +596,142 @@ channel instances." latest instances of CHANNELS." (mlet %store-monad ((instances (latest-channel-instances* channels))) (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) + _ ...)) + (channel (name (string->symbol + (manifest-entry-name entry))) + (url url) + (commit commit))) + + ;; 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))))) + + +;;; +;;; 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))))) |