Normalize resource path in `find-resource-file`.

`..` and `.` are now legal as long as long as the path does not reference the
resource root directory's parent.

2 files changed, 18 insertions, 25 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index 648a5a2..247807b 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -24,13 +24,6 @@
 
 
 
-(define %illegal-path-regex
-  ;; Forbid `.` and `..` segments in paths.
-  (make-regexp "^(.*/)?[.][.]?(/.*)?$"))
-
-(define legal-path?
-  (negate (cut regexp-exec %illegal-path-regex <>)))
-
 (export &not-found)
 (export not-found-condition?)
 (s35:define-condition-type &not-found s35:&condition
@@ -66,9 +59,16 @@
       ((_ _ (segment . rest))
        (loop parent-walks (cons segment processed) rest)))))
 
+(define %illegal-path-regex
+  ;; Assume normalized path, forbid parent directory ref.
+  (make-regexp "^/?[.][.](/.*)?$"))
+
 (export find-resource-file)
 (define* (find-resource-file file #:optional (root-path (%resource-root-path)))
-  (unless (legal-path? file)
+  (define normalized-file
+    (normalize-path file))
+
+  (when (regexp-exec %illegal-path-regex normalized-file)
     (raise (s35:condition
             (&forbidden)
             (s35:&message
@@ -83,7 +83,7 @@
                 (message (format #f "Resource not found ~a" file))))))
       ((? string?)
        (loop (list root-path)))
-      (((= (cut format #f "~a/~a" <> file) file-path)
+      (((= (cut format #f "~a/~a" <> normalized-file) file-path)
         . paths-rest)
        (or (and (stat file-path #f) file-path)
            (loop paths-rest))))))
diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm
index e497bfe..328573c 100644
--- a/tests/guile/cantius-test.scm
+++ b/tests/guile/cantius-test.scm
@@ -189,22 +189,15 @@
     (tu:test-assert (string-prefix? ";;; " (cadr valid-resource-result))))
 
   (tu:test-group "illegal-static-resources"
-    (for-each (lambda (resource-path)
-                (define illegal-resource-result
-                  (get resource-path))
-
-                (tu:test-eqv 403
-                             (rsp:response-code (car illegal-resource-result)))
-
-                ;; Default handler for illegal resource accesses is expected to
-                ;; ignore the value of the `%default-headers` parameter.
-                (tu:test-equal '(text/plain (charset . "utf-8"))
-                               (rsp:response-content-type
-                                (car illegal-resource-result))))
-
-              '("/static/../../../../../etc/passwd"
-                "/static/stylesheets/."
-                "/static/nonfree/../scripts/main.js")))
+    (define illegal-resource-result
+      (get "/static/stylesheets/../../../../../../etc/passwd"))
+
+    (tu:test-eqv 403 (rsp:response-code (car illegal-resource-result)))
+
+    ;; Default handler for illegal resource accesses is expected to ignore the
+    ;; value of the `%default-headers` parameter.
+    (tu:test-equal '(text/plain (charset . "utf-8"))
+                   (rsp:response-content-type (car illegal-resource-result))))
 
   (tu:test-group "missing-static-resources"
     (define missing-resource-result