From: "Ludovic Courtès" <ludo@gnu.org>
To: 36699@debbugs.gnu.org
Subject: [bug#36699] [PATCH 3/4] channels: Always provide a <channel-metadata> record.
Date: Wed, 17 Jul 2019 01:24:32 +0200 [thread overview]
Message-ID: <20190716232433.16789-3-ludo@gnu.org> (raw)
In-Reply-To: <20190716232433.16789-1-ludo@gnu.org>
This simplifies the code since one no longer needs to think about
whether '.guix-channel' was present.
* guix/channels.scm (read-channel-metadata): Always pass a string as the
first argument to 'channel-metadata'.
(read-channel-metadata-from-source): Always return a <channel-metadata>
record.
(channel-instance-dependencies): Remove now unneeded 'match'.
(standard-module-derivation): Assume DIRECTORY is never #f and contains
a leading slash.
* tests/channels.scm (channel-metadata-directory)
(channel-metadata-dependencies): New procedures.
("channel-instance-metadata returns #f if .guix-channel does not
exist"): Remove.
("channel-instance-metadata returns default if .guix-channel does not
exist"): New test.
(make-instance): Use 'write' instead of 'display' when creating
'.guix-channel'.
(instance--no-deps): Remove dependencies.
(instance--sub-directory): New variable.
("channel-instance-metadata and default dependencies")
("channel-instance-metadata and directory"): New tests.
("latest-channel-instances excludes duplicate channel dependencies"):
Expect 'channel-commit' to return a string and adjust accordingly.
---
guix/channels.scm | 27 ++++++++++++---------------
tests/channels.scm | 45 +++++++++++++++++++++++++++++----------------
2 files changed, 41 insertions(+), 31 deletions(-)
diff --git a/guix/channels.scm b/guix/channels.scm
index 87ad729a70..415246cbd1 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -110,8 +110,8 @@
(define-record-type <channel-metadata>
(channel-metadata directory dependencies)
channel-metadata?
- (directory channel-metadata-directory)
- (dependencies channel-metadata-dependencies))
+ (directory channel-metadata-directory) ;string with leading slash
+ (dependencies channel-metadata-dependencies)) ;list of <channel>
(define (channel-reference channel)
"Return the \"reference\" for CHANNEL, an sexp suitable for
@@ -129,7 +129,9 @@ if valid metadata could not be read from PORT."
(let ((directory (and=> (assoc-ref properties 'directory) first))
(dependencies (or (assoc-ref properties 'dependencies) '())))
(channel-metadata
- directory
+ (cond ((not directory) "/")
+ ((string-prefix? "/" directory) directory)
+ (else (string-append "/" directory)))
(map (lambda (item)
(let ((get (lambda* (key #:optional default)
(or (and=> (assoc-ref item key) first) default))))
@@ -157,29 +159,26 @@ if valid metadata could not be read from PORT."
(define (read-channel-metadata-from-source source)
"Return a channel-metadata record read from channel's SOURCE/.guix-channel
-description file, or return #F if SOURCE/.guix-channel does not exist."
+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))
- #f
+ (channel-metadata "/" '())
(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."
+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 (channel-instance-metadata instance)
- (#f '())
- (($ <channel-metadata> directory 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
@@ -261,7 +260,7 @@ 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 (and=> metadata channel-metadata-directory)))
+ (directory (channel-metadata-directory metadata)))
(define build
;; This is code that we'll run in CORE, a Guix instance, with its own
@@ -281,9 +280,7 @@ to '%package-module-path'."
(string-append #$output "/share/guile/site/"
(effective-version)))
- (let* ((subdir (if #$directory
- (string-append "/" #$directory)
- ""))
+ (let* ((subdir #$directory)
(source (string-append #$source subdir)))
(compile-files source go (find-files source "\\.scm$"))
(mkdir-p (dirname scm))
diff --git a/tests/channels.scm b/tests/channels.scm
index 1f1357fca7..e83b5437d3 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -42,9 +42,9 @@
(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))))
+ (when spec
+ (call-with-output-file (string-append instance-dir "/.guix-channel")
+ (lambda (port) (write spec port))))
(checkout->channel-instance instance-dir
#:commit commit
#:name name))
@@ -55,12 +55,10 @@
'(channel (version 42) (dependencies whatever))))
(define instance--no-deps
(make-instance #:spec
- '(channel
- (version 0)
- (dependencies
- (channel
- (name test-channel)
- (url "https://example.com/test-channel"))))))
+ '(channel (version 0))))
+(define instance--sub-directory
+ (make-instance #:spec
+ '(channel (version 0) (directory "modules"))))
(define instance--simple
(make-instance #:spec
'(channel
@@ -87,11 +85,26 @@
(define channel-instance-metadata
(@@ (guix channels) channel-instance-metadata))
+(define channel-metadata-directory
+ (@@ (guix channels) channel-metadata-directory))
+(define channel-metadata-dependencies
+ (@@ (guix channels) channel-metadata-dependencies))
\f
-(test-equal "channel-instance-metadata returns #f if .guix-channel does not exist"
- #f
- (channel-instance-metadata instance--boring))
+(test-equal "channel-instance-metadata returns default if .guix-channel does not exist"
+ '("/" ())
+ (let ((metadata (channel-instance-metadata instance--boring)))
+ (list (channel-metadata-directory metadata)
+ (channel-metadata-dependencies metadata))))
+
+(test-equal "channel-instance-metadata and default dependencies"
+ '()
+ (channel-metadata-dependencies (channel-instance-metadata instance--no-deps)))
+
+(test-equal "channel-instance-metadata and directory"
+ "/modules"
+ (channel-metadata-directory
+ (channel-instance-metadata instance--sub-directory)))
(test-equal "channel-instance-metadata rejects unsupported version"
1 ;line number in the generated '.guix-channel'
@@ -141,7 +154,7 @@
("test" (values test-dir 'whatever))
(_ (values "/not-important" 'not-important)))))
(let ((instances (latest-channel-instances #f (list channel))))
- (and (eq? 2 (length instances))
+ (and (= 2 (length instances))
(lset= eq?
'(test test-channel)
(map (compose channel-name channel-instance-channel)
@@ -152,9 +165,9 @@
(and (eq? (channel-name
(channel-instance-channel instance))
'test-channel)
- (eq? (channel-commit
- (channel-instance-channel instance))
- 'abc1234)))
+ (string=? (channel-commit
+ (channel-instance-channel instance))
+ "abc1234")))
instances))))))
(test-assert "channel-instances->manifest"
--
2.22.0
next prev parent reply other threads:[~2019-07-16 23:25 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-07-16 23:20 [bug#36699] [PATCH 0/4] Strengthen '.guix-channel' file handling Ludovic Courtès
2019-07-16 23:24 ` [bug#36699] [PATCH 1/4] channels: Strictly check the version of '.guix-channel' Ludovic Courtès
2019-07-16 23:24 ` [bug#36699] [PATCH 2/4] channels: Remove unneeded 'version' field of <channel-metadata> Ludovic Courtès
2019-07-16 23:24 ` Ludovic Courtès [this message]
2019-07-16 23:24 ` [bug#36699] [PATCH 4/4] channels: Reject directories with '..' in '.guix-channel' file Ludovic Courtès
2019-07-16 23:29 ` Ludovic Courtès
2019-07-18 9:58 ` Danny Milosavljevic
2019-07-18 13:44 ` Ludovic Courtès
2019-07-19 9:54 ` bug#36699: [PATCH 0/4] Strengthen '.guix-channel' file handling Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190716232433.16789-3-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=36699@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).