mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
guix: Add support for channel dependencies.
* guix/channels.scm (<channel-metadata>): New record. (read-channel-metadata, channel-instance-dependencies): New procedures. (latest-channel-instances): Include channel dependencies; add optional argument PREVIOUS-CHANNELS. (channel-instance-derivations): Build derivation for additional channels and add it as dependency to the channel instance derivation. * doc/guix.texi (Channels): Add subsection "Declaring Channel Dependencies". * tests/channels.scm: New file. * Makefile.am (SCM_TESTS): Add it.
This commit is contained in:
Ricardo Wurmus
parent
d7e2465242
commit
af12790bdd
4 changed files with 279 additions and 16 deletions
|
|
@ -329,6 +329,7 @@ SCM_TESTS = \
|
|||
tests/base16.scm \
|
||||
tests/base32.scm \
|
||||
tests/base64.scm \
|
||||
tests/channels.scm \
|
||||
tests/cpan.scm \
|
||||
tests/cpio.scm \
|
||||
tests/crate.scm \
|
||||
|
|
|
|||
|
|
@ -3037,6 +3037,39 @@ the new and upgraded packages that are listed, some like @code{my-gimp} and
|
|||
@code{my-emacs-with-cool-features} might come from
|
||||
@code{my-personal-packages}, while others come from the Guix default channel.
|
||||
|
||||
@cindex dependencies, channels
|
||||
@cindex meta-data, channels
|
||||
@subsection Declaring Channel Dependencies
|
||||
|
||||
Channel authors may decide to augment a package collection provided by other
|
||||
channels. They can declare their channel to be dependent on other channels in
|
||||
a meta-data file @file{.guix-channel}, which is to be placed in the root of
|
||||
the channel repository.
|
||||
|
||||
The meta-data file should contain a simple S-expression like this:
|
||||
|
||||
@lisp
|
||||
(channel
|
||||
(version 0)
|
||||
(dependencies
|
||||
(channel
|
||||
(name 'some-collection)
|
||||
(url "https://example.org/first-collection.git"))
|
||||
(channel
|
||||
(name 'some-other-collection)
|
||||
(url "https://example.org/second-collection.git")
|
||||
(branch "testing"))))
|
||||
@end lisp
|
||||
|
||||
In the above example this channel is declared to depend on two other channels,
|
||||
which will both be fetched automatically. The modules provided by the channel
|
||||
will be compiled in an environment where the modules of all these declared
|
||||
channels are available.
|
||||
|
||||
For the sake of reliability and maintainability, you should avoid dependencies
|
||||
on channels that you don't control, and you should aim to keep the number of
|
||||
dependencies to a minimum.
|
||||
|
||||
@subsection Replicating Guix
|
||||
|
||||
@cindex pinning, channels
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -27,6 +28,7 @@ (define-module (guix channels)
|
|||
#: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)
|
||||
|
|
@ -73,7 +75,6 @@ (define-record-type* <channel> channel make-channel
|
|||
(commit channel-commit (default #f))
|
||||
(location channel-location
|
||||
(default (current-source-location)) (innate)))
|
||||
;; TODO: Add a way to express dependencies among channels.
|
||||
|
||||
(define %default-channels
|
||||
;; Default list of channels.
|
||||
|
|
@ -93,6 +94,12 @@ (define-record-type <channel-instance>
|
|||
(commit channel-instance-commit)
|
||||
(checkout channel-instance-checkout))
|
||||
|
||||
(define-record-type <channel-metadata>
|
||||
(channel-metadata version dependencies)
|
||||
channel-metadata?
|
||||
(version channel-metadata-version)
|
||||
(dependencies channel-metadata-dependencies))
|
||||
|
||||
(define (channel-reference channel)
|
||||
"Return the \"reference\" for CHANNEL, an sexp suitable for
|
||||
'latest-repository-commit'."
|
||||
|
|
@ -100,20 +107,90 @@ (define (channel-reference channel)
|
|||
(#f `(branch . ,(channel-branch channel)))
|
||||
(commit `(commit . ,(channel-commit channel)))))
|
||||
|
||||
(define (latest-channel-instances store channels)
|
||||
(define (read-channel-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))))))
|
||||
|
||||
(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)))
|
||||
|
||||
(define* (latest-channel-instances store channels #:optional (previous-channels '()))
|
||||
"Return a list of channel instances corresponding to the latest checkouts of
|
||||
CHANNELS."
|
||||
(map (lambda (channel)
|
||||
(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))))
|
||||
(channel-instance channel commit checkout)))
|
||||
channels))
|
||||
CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list
|
||||
of previously processed channels."
|
||||
;; Only process channels that are unique, or that are more specific than a
|
||||
;; previous channel specification.
|
||||
(define (ignore? channel others)
|
||||
(member channel others
|
||||
(lambda (a b)
|
||||
(and (eq? (channel-name a) (channel-name b))
|
||||
(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* (checkout->channel-instance checkout
|
||||
#:key commit
|
||||
|
|
@ -235,8 +312,21 @@ (define dependencies
|
|||
(lambda (instance)
|
||||
(if (eq? instance core-instance)
|
||||
(return core)
|
||||
(build-channel-instance instance
|
||||
(cons core dependencies))))
|
||||
(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 (whole-package-for-legacy name modules)
|
||||
|
|
|
|||
139
tests/channels.scm
Normal file
139
tests/channels.scm
Normal file
|
|
@ -0,0 +1,139 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (test-channels)
|
||||
#:use-module (guix channels)
|
||||
#:use-module ((guix build syscalls) #:select (mkdtemp!))
|
||||
#:use-module (guix tests)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
(test-begin "channels")
|
||||
|
||||
(define* (make-instance #:key
|
||||
(name 'fake)
|
||||
(commit "cafebabe")
|
||||
(spec #f))
|
||||
(define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX"))
|
||||
(and spec
|
||||
(with-output-to-file (string-append instance-dir "/.guix-channel")
|
||||
(lambda _ (format #t "~a" spec))))
|
||||
((@@ (guix channels) channel-instance)
|
||||
name commit instance-dir))
|
||||
|
||||
(define instance--boring (make-instance))
|
||||
(define instance--no-deps
|
||||
(make-instance #:spec
|
||||
'(channel
|
||||
(version 0)
|
||||
(dependencies
|
||||
(channel
|
||||
(name test-channel)
|
||||
(url "https://example.com/test-channel"))))))
|
||||
(define instance--simple
|
||||
(make-instance #:spec
|
||||
'(channel
|
||||
(version 0)
|
||||
(dependencies
|
||||
(channel
|
||||
(name test-channel)
|
||||
(url "https://example.com/test-channel"))))))
|
||||
(define instance--with-dupes
|
||||
(make-instance #:spec
|
||||
'(channel
|
||||
(version 0)
|
||||
(dependencies
|
||||
(channel
|
||||
(name test-channel)
|
||||
(url "https://example.com/test-channel"))
|
||||
(channel
|
||||
(name test-channel)
|
||||
(url "https://example.com/test-channel")
|
||||
(commit "abc1234"))
|
||||
(channel
|
||||
(name test-channel)
|
||||
(url "https://example.com/test-channel-elsewhere"))))))
|
||||
|
||||
(define read-channel-metadata
|
||||
(@@ (guix channels) read-channel-metadata))
|
||||
|
||||
|
||||
(test-equal "read-channel-metadata returns #f if .guix-channel does not exist"
|
||||
#f
|
||||
(read-channel-metadata instance--boring))
|
||||
|
||||
(test-assert "read-channel-metadata returns <channel-metadata>"
|
||||
(every (@@ (guix channels) channel-metadata?)
|
||||
(map read-channel-metadata
|
||||
(list instance--no-deps
|
||||
instance--simple
|
||||
instance--with-dupes))))
|
||||
|
||||
(test-assert "read-channel-metadata dependencies are channels"
|
||||
(let ((deps ((@@ (guix channels) channel-metadata-dependencies)
|
||||
(read-channel-metadata instance--simple))))
|
||||
(match deps
|
||||
(((? channel? dep)) #t)
|
||||
(_ #f))))
|
||||
|
||||
(test-assert "latest-channel-instances includes channel dependencies"
|
||||
(let* ((channel (channel
|
||||
(name 'test)
|
||||
(url "test")))
|
||||
(test-dir (channel-instance-checkout instance--simple)))
|
||||
(mock ((guix git) latest-repository-commit
|
||||
(lambda* (store url #:key ref)
|
||||
(match url
|
||||
("test" (values test-dir 'whatever))
|
||||
(_ (values "/not-important" 'not-important)))))
|
||||
(let ((instances (latest-channel-instances #f (list channel))))
|
||||
(and (eq? 2 (length instances))
|
||||
(lset= eq?
|
||||
'(test test-channel)
|
||||
(map (compose channel-name channel-instance-channel)
|
||||
instances)))))))
|
||||
|
||||
(test-assert "latest-channel-instances excludes duplicate channel dependencies"
|
||||
(let* ((channel (channel
|
||||
(name 'test)
|
||||
(url "test")))
|
||||
(test-dir (channel-instance-checkout instance--with-dupes)))
|
||||
(mock ((guix git) latest-repository-commit
|
||||
(lambda* (store url #:key ref)
|
||||
(match url
|
||||
("test" (values test-dir 'whatever))
|
||||
(_ (values "/not-important" 'not-important)))))
|
||||
(let ((instances (latest-channel-instances #f (list channel))))
|
||||
(and (eq? 2 (length instances))
|
||||
(lset= eq?
|
||||
'(test test-channel)
|
||||
(map (compose channel-name channel-instance-channel)
|
||||
instances))
|
||||
;; only the most specific channel dependency should remain,
|
||||
;; i.e. the one with a specified commit.
|
||||
(find (lambda (instance)
|
||||
(and (eq? (channel-name
|
||||
(channel-instance-channel instance))
|
||||
'test-channel)
|
||||
(eq? (channel-commit
|
||||
(channel-instance-channel instance))
|
||||
'abc1234)))
|
||||
instances))))))
|
||||
|
||||
(test-end "channels")
|
||||
Loading…
Reference in a new issue