04/06: channels: Strictly check the version of '.guix-channel'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 45b903323e0fecb7947926d2c14103d47fea624a
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jul 17 00:04:41 2019 +0200

    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.
---
 guix/channels.scm  | 71 ++++++++++++++++++++++++++++++++++++------------------
 tests/channels.scm | 29 ++++++++++++++++------
 2 files changed, 68 insertions(+), 32 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index bfe6963..e92148a 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -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))))))
-
-(define (read-channel-metadata instance)
+  (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 (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)))
diff --git a/tests/channels.scm b/tests/channels.scm
index 8540aef..1f1357f 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -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-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 "read-channel-metadata returns <channel-metadata>"
+(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))))