;;; 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 records)
#:use-module (guix gexp)
#: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)
#:select (source-properties->location
- &error-location))
+ &error-location
+ &fix-hint))
#:use-module (srfi srfi-1)
#: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
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:
;;;
(checkout channel-instance-checkout))
(define-record-type <channel-metadata>
- (channel-metadata version dependencies)
+ (channel-metadata directory dependencies news-file)
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
(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 (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)))
+ (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))))))
+ dependencies)
+ news-file))) ;news-file
+ ((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)
+ (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* (latest-channel-instances store channels #:optional (previous-channels '()))
"Return a list of channel instances corresponding to the latest checkouts of
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'."
- ;; 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.
-
- (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)))
- (compile-files #$source go
- (find-files #$source "\\.scm$"))
- (mkdir-p (dirname scm))
- (symlink #$source scm)
- scm)))
+ (let* ((metadata (read-channel-metadata-from-source source))
+ (directory (channel-metadata-directory metadata)))
- (gexp->derivation-in-inferior name build core))
+ (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 (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
;; 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)))
(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)
;; "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)
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)))))
+
+\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)))))
HCoop / jackhill / guix / guix.git / blobdiff