mirror of git://git.savannah.gnu.org/guix.git
channels: Strictly check the version of '.guix-channel'.
Until now the 'version' field in '.guix-channel' could be omitted, or it
could be any value.
* guix/channels.scm (read-channel-metadata): Rename to...
(channel-instance-metadata): ... this.
(channel-instance-dependencies): Adjust accordingly.
(read-channel-metadata): New procedure. Use 'match'
to require a 'version' field. Provide proper error handling when the
channel sexp is malformed or when given an unsupported version number.
(read-channel-metadata-from-source): Use 'catch' and
'system-error-errno' instead of 'file-exists?'.
* tests/channels.scm (instance--unsupported-version): New variable.
(read-channel-metadata): Rename to...
(channel-instance-metadata): ... this. Rename tests accordingly.
("channel-instance-metadata rejects unsupported version"): New test.
This commit is contained in:
Ludovic Courtès
parent
bacfec8611
commit
45b903323e
|
|
@ -121,32 +121,55 @@
|
|||
(#f `(branch . ,(channel-branch channel)))
|
||||
(commit `(commit . ,(channel-commit channel)))))
|
||||
|
||||
(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) '())))
|
||||
(channel-metadata
|
||||
version
|
||||
directory
|
||||
(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))))
|
||||
((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 #F if SOURCE/.guix-channel does not exist."
|
||||
(let ((meta-file (string-append source "/.guix-channel")))
|
||||
(and (file-exists? meta-file)
|
||||
(let* ((raw (call-with-input-file meta-file read))
|
||||
(version (and=> (assoc-ref raw 'version) first))
|
||||
(directory (and=> (assoc-ref raw 'directory) first))
|
||||
(dependencies (or (assoc-ref raw 'dependencies) '())))
|
||||
(channel-metadata
|
||||
version
|
||||
directory
|
||||
(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))))))
|
||||
(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
|
||||
(apply throw args)))))
|
||||
|
||||
(define (read-channel-metadata instance)
|
||||
(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."
|
||||
|
|
@ -155,7 +178,7 @@ file."
|
|||
(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)
|
||||
(match (channel-instance-metadata instance)
|
||||
(#f '())
|
||||
(($ <channel-metadata> version directory dependencies)
|
||||
dependencies)))
|
||||
|
|
|
|||
|
|
@ -26,8 +26,12 @@
|
|||
#:use-module (guix derivations)
|
||||
#:use-module (guix sets)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module ((guix utils)
|
||||
#:select (error-location? error-location location-line))
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
|
|
@ -46,6 +50,9 @@
|
|||
#:name name))
|
||||
|
||||
(define instance--boring (make-instance))
|
||||
(define instance--unsupported-version
|
||||
(make-instance #:spec
|
||||
'(channel (version 42) (dependencies whatever))))
|
||||
(define instance--no-deps
|
||||
(make-instance #:spec
|
||||
'(channel
|
||||
|
|
@ -78,24 +85,30 @@
|
|||
(name test-channel)
|
||||
(url "https://example.com/test-channel-elsewhere"))))))
|
||||
|
||||
(define read-channel-metadata
|
||||
(@@ (guix channels) read-channel-metadata))
|
||||
(define channel-instance-metadata
|
||||
(@@ (guix channels) channel-instance-metadata))
|
||||
|
||||
|
||||
(test-equal "read-channel-metadata returns #f if .guix-channel does not exist"
|
||||
(test-equal "channel-instance-metadata returns #f if .guix-channel does not exist"
|
||||
#f
|
||||
(read-channel-metadata instance--boring))
|
||||
(channel-instance-metadata instance--boring))
|
||||
|
||||
(test-assert "read-channel-metadata returns <channel-metadata>"
|
||||
(test-equal "channel-instance-metadata rejects unsupported version"
|
||||
1 ;line number in the generated '.guix-channel'
|
||||
(guard (c ((and (message-condition? c) (error-location? c))
|
||||
(location-line (error-location c))))
|
||||
(channel-instance-metadata instance--unsupported-version)))
|
||||
|
||||
(test-assert "channel-instance-metadata returns <channel-metadata>"
|
||||
(every (@@ (guix channels) channel-metadata?)
|
||||
(map read-channel-metadata
|
||||
(map channel-instance-metadata
|
||||
(list instance--no-deps
|
||||
instance--simple
|
||||
instance--with-dupes))))
|
||||
|
||||
(test-assert "read-channel-metadata dependencies are channels"
|
||||
(test-assert "channel-instance-metadata dependencies are channels"
|
||||
(let ((deps ((@@ (guix channels) channel-metadata-dependencies)
|
||||
(read-channel-metadata instance--simple))))
|
||||
(channel-instance-metadata instance--simple))))
|
||||
(match deps
|
||||
(((? channel? dep)) #t)
|
||||
(_ #f))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue