From: Tim Vaughan <plugd@thelambdalab.xyz>
Date: Tue, 26 May 2020 20:49:42 +0000 (+0200)
Subject: Redirect dir -> dir/
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=2f2d3ea456c393f1647c6778d4f58f4b4ede3564;p=rags.git

Redirect dir -> dir/
---

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)))