The Lambda Lab
/
projects
/
rags.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
fd37c59
)
Redirect dir -> dir/
author
Tim Vaughan
<plugd@thelambdalab.xyz>
Tue, 26 May 2020 20:49:42 +0000
(22:49 +0200)
committer
Tim Vaughan
<plugd@thelambdalab.xyz>
Tue, 26 May 2020 20:50:14 +0000
(22:50 +0200)
rags.scm
patch
|
blob
|
history
diff --git
a/rags.scm
b/rags.scm
index
1ec9bf7
..
a06be1c
100644
(file)
--- a/
rags.scm
+++ b/
rags.scm
@@
-11,7
+11,7
@@
(chicken process)
(chicken process-context)
(chicken process-context posix)
(chicken process)
(chicken process-context)
(chicken process-context posix)
- matchable srfi-13
+ matchable srfi-13
srfi-1
uri-common tcp6 openssl)
(define-record config
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."))
(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"))
(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-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)
(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)))
(if (directory-exists? path)
(make-pathname path "index.gmi")
path)))