From 2f2d3ea456c393f1647c6778d4f58f4b4ede3564 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Tue, 26 May 2020 22:49:42 +0200 Subject: [PATCH] Redirect dir -> dir/ --- rags.scm | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/rags.scm b/rags.scm index 1ec9bf7..a06be1c 100644 --- a/rags.scm +++ b/rags.scm @@ -11,7 +11,7 @@ (chicken process) (chicken process-context) (chicken process-context posix) - matchable srfi-13 + matchable srfi-13 srfi-1 uri-common tcp6 openssl) (define-record config @@ -35,18 +35,36 @@ (fail-permanent "Path must be absolute.")) ((not (document-available? config uri)) (fail-permanent "Document not found.")) + ((and (document-path-directory? config uri) + (uri-lacks-trailing-slash? uri)) + (redirect-permanent (uri-with-trailing-slash uri))) (else (serve-document config uri))))) (define (fail-permanent reason) (print "50 " reason "\r")) +(define (redirect-permanent new-uri) + (print "30 " (uri->string new-uri) "\r")) + +(define (uri-lacks-trailing-slash? uri) + (not (string-null? (last (uri-path uri))))) + +(define (uri-with-trailing-slash uri) + (update-uri uri path: (append (uri-path uri) '("")))) + (define (document-available? config uri) (file-exists? (document-path config uri))) +(define (document-path-directory? config uri) + (directory-exists? (document-path-raw config uri))) + +(define (document-path-raw config uri) + (let* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri)))))) + (make-pathname (reverse (cdr crumbs)) (car crumbs)))) + (define (document-path config uri) - (let* ((crumbs (reverse (cons (config-root-dir config) (cdr (uri-path uri))))) - (path (make-pathname (reverse (cdr crumbs)) (car crumbs)))) + (let* ((path (document-path-raw config uri))) (if (directory-exists? path) (make-pathname path "index.gmi") path))) -- 2.20.1