diff options
| -rw-r--r-- | src/guile/cantius.scm | 25 | ||||
| -rw-r--r-- | tests/guile/cantius-test.scm | 17 |
2 files changed, 42 insertions, 0 deletions
diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm index 601427e..648a5a2 100644 --- a/src/guile/cantius.scm +++ b/src/guile/cantius.scm @@ -41,6 +41,31 @@ (s35:define-condition-type &forbidden s35:&condition forbidden-condition?) +(define-public (normalize-path path) + (define absolute? + (eqv? #\/ (string-ref path 0))) + + (let loop ((parent-walks 0) + (processed '()) + (to-process (string-split path #\/))) + (match (list parent-walks processed to-process) + ((0 () ()) + (if absolute? "/" ".")) + ((_ _ ()) + (string-join (append (map (const "..") (iota parent-walks)) + (reverse processed)) + "/" + (if absolute? 'prefix 'infix))) + ((_ _ ((? (cut member <> '("" "."))) + . rest)) + (loop parent-walks processed rest)) + ((_ () (".." . rest)) + (loop (1+ parent-walks) '() rest)) + ((_ (_ . processed-rest) (".." . rest)) + (loop parent-walks processed-rest rest)) + ((_ _ (segment . rest)) + (loop parent-walks (cons segment processed) rest))))) + (export find-resource-file) (define* (find-resource-file file #:optional (root-path (%resource-root-path))) (unless (legal-path? file) diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm index 0e4b2ca..e497bfe 100644 --- a/tests/guile/cantius-test.scm +++ b/tests/guile/cantius-test.scm @@ -220,3 +220,20 @@ (tu:test-assert (eval '(begin (thread-terminate! server-thread) (close server-sock)) (test-env 'nonfree-site)))) + +(tu:test-group "normalize-path" + (tu:test-equal "a/b/c/d" + ((@ (cantius) normalize-path) "a//b/./c//c1/../d")) + + (tu:test-equal "." + ((@ (cantius) normalize-path) "aa/bb/cc/../../..")) + + (tu:test-equal "/" + ((@ (cantius) normalize-path) "/dd/ee/ff/../../..")) + + (tu:test-equal "/../../g/h/i" + ((@ (cantius) normalize-path) + "/ignored0/../ignored1/../.././ignored2/../../g/h/i")) + + (tu:test-equal "../j/k/l" + ((@ (cantius) normalize-path) "../j/k/l"))) |