summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2015-04-11 17:51:39 -0400
committerDavid Thompson <dthompson2@worcester.edu>2015-04-11 17:53:00 -0400
commitad9c4b23dd57da1cfe0e9d05414d06a5056a5b6e (patch)
tree8681904e426ea199622395de2ad2dc136eb62fbb
parent46d38aab9dc96cb531d6150ae6cf43bbf3b47711 (diff)
server: web-server: Fix directory view.
* haunt/serve/web-server.scm (request-path-components, request-file-name): New procedures. (render-directory): URI encode href attributes. Properly concatenate file paths. (make-handler): Decode URI before using it as a relative file name.
-rw-r--r--haunt/serve/web-server.scm31
1 files changed, 26 insertions, 5 deletions
diff --git a/haunt/serve/web-server.scm b/haunt/serve/web-server.scm
index b6d001b..f66046c 100644
--- a/haunt/serve/web-server.scm
+++ b/haunt/serve/web-server.scm
@@ -29,6 +29,7 @@
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (sxml simple)
#:use-module (web server)
#:use-module (web request)
@@ -66,6 +67,18 @@
directory WORK-DIR."
(string-append work-dir path))
+(define (request-path-components request)
+ "Split the URI path of REQUEST into a list of component strings. For
+example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (request-file-name request)
+ "Return the relative file name corresponding to the REQUEST URI."
+ (let ((components (request-path-components request)))
+ (if (null? components)
+ "/"
+ (string-join components "/" 'prefix))))
+
(define (resolve-file-name file-name)
"If FILE-NAME is a directory with an 'index.html' file,
return that file name. If FILE-NAME does not exist, return #f.
@@ -94,11 +107,19 @@ FILE-NAME."
(define (render-directory path dir)
"Render the contents of DIR represented by the URI PATH."
+ (define (concat+uri-encode . file-names)
+ "Concatenate FILE-NAMES, preserving the correct file separators."
+ (string-join (map uri-encode
+ (remove string-null?
+ (string-split (string-concatenate file-names)
+ #\/)))
+ "/" 'prefix))
+
(define render-child
(match-lambda
((file-name directory?)
`(li
- (a (@ (href ,(string-append path "/" file-name)))
+ (a (@ (href ,(concat+uri-encode path file-name)))
,(if directory?
(string-append file-name "/")
file-name))))))
@@ -115,7 +136,6 @@ FILE-NAME."
(title ,title))
(body
(h1 ,title)
- (h2 "<i>foobar</i>")
(ul ,@(map render-child children))))))
(values '((content-type . (text/html)))
(lambda (port)
@@ -140,9 +160,10 @@ FILE-NAME."
(define (make-handler work-dir)
(lambda (request body)
"Serve the file asked for in REQUEST."
- (let ((path (uri-path (request-uri request))))
- (format #t "~a ~a~%" (request-method request) path)
- (serve-file work-dir path))))
+ (format #t "~a ~a~%"
+ (request-method request)
+ (uri-path (request-uri request)))
+ (serve-file work-dir (request-file-name request))))
(define* (serve work-dir #:key (open-params '()))
"Run a simple HTTP server that serves files in WORK-DIR."