[bug#36699] [PATCH 4/4] channels: Reject directories with '..' in '.guix-channel' file.

["Ludovic Courtès" <ludo@gnu.org>]

* guix/channels.scm (read-channel-metadata)[sexp, location]: New
variables.
[sane-directory]: New procedure.
Call it when DIRECTORY is true.
* tests/channels.scm (instance--fishy-directory): New variable.
("channel-instance-metadata and fishy directory"): New test.
---
 guix/channels.scm  | 30 ++++++++++++++++++++----------
 tests/channels.scm | 11 +++++++++++
 2 files changed, 31 insertions(+), 10 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index 415246cbd1..641dee8dbb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -124,14 +124,28 @@
   "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)
+  (define sexp
+    (read port))
+
+  (define location
+    (source-properties->location (source-properties sexp)))
+
+  (define (sane-directory directory)
+    ;; If DIRECTORY contains '..', raise an error; otherwise return it.
+    (when (member ".." (string-split directory #\/))
+      (raise (condition
+              (&message (message "channel sub-directory must not contain '..'"))
+              (&error-location (location location)))))
+    directory)
+
+  (match sexp
     (('channel ('version 0) properties ...)
      (let ((directory    (and=> (assoc-ref properties 'directory) first))
            (dependencies (or (assoc-ref properties 'dependencies) '())))
        (channel-metadata
         (cond ((not directory) "/")
-              ((string-prefix? "/" directory) directory)
-              (else (string-append "/" directory)))
+              ((string-prefix? "/" directory) (sane-directory directory))
+              (else (string-append "/" (sane-directory directory))))
         (map (lambda (item)
                (let ((get (lambda* (key #:optional default)
                             (or (and=> (assoc-ref item key) first) default))))
@@ -144,18 +158,14 @@ if valid metadata could not be read from PORT."
                     (url url)
                     (commit (get 'commit))))))
              dependencies))))
-    ((and ('channel ('version version) _ ...) sexp)
+    (('channel ('version version) _ ...)
      (raise (condition
              (&message (message "unsupported '.guix-channel' version"))
-             (&error-location
-              (location (source-properties->location
-                         (source-properties sexp)))))))
+             (&error-location (location location)))))
     (sexp
      (raise (condition
              (&message (message "invalid '.guix-channel' file"))
-             (&error-location
-              (location (source-properties->location
-                         (source-properties sexp)))))))))
+             (&error-location (location location)))))))
 
 (define (read-channel-metadata-from-source source)
   "Return a channel-metadata record read from channel's SOURCE/.guix-channel
diff --git a/tests/channels.scm b/tests/channels.scm
index e83b5437d3..402025dea3 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -59,6 +59,11 @@
 (define instance--sub-directory
   (make-instance #:spec
                  '(channel (version 0) (directory "modules"))))
+(define instance--fishy-directory
+  (make-instance #:spec
+                 '(channel (version 0)
+                           (directory "../../../../../etc"))))
+
 (define instance--simple
   (make-instance #:spec
                  '(channel
@@ -106,6 +111,12 @@
   (channel-metadata-directory
    (channel-instance-metadata instance--sub-directory)))
 
+(test-assert "channel-instance-metadata and fishy directory"
+  (guard (c ((and (message-condition? c) (error-location? c))
+             #t))
+    (channel-instance-metadata instance--fishy-directory)
+    #f))
+
 (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))
-- 
2.22.0