dan
/
haunt
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
David Thompson 2015-04-11 17:51:39 -04:00
parent 46d38aab9d
commit ad9c4b23dd
1 changed files with 26 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
haunt/serve/web-server.scm
View File

@ -29,6 +29,7 @@
#:use-module (ice-9 popen) #:use-module (ice-9 popen)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (sxml simple) #:use-module (sxml simple)
#:use-module (web server) #:use-module (web server)
#:use-module (web request) #:use-module (web request)
@ -66,6 +67,18 @@
directory WORK-DIR." directory WORK-DIR."
(string-append work-dir path)) (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) (define (resolve-file-name file-name)
"If FILE-NAME is a directory with an 'index.html' file, "If FILE-NAME is a directory with an 'index.html' file,
return that file name. If FILE-NAME does not exist, return #f. return that file name. If FILE-NAME does not exist, return #f.
@ -94,11 +107,19 @@ FILE-NAME."
(define (render-directory path dir) (define (render-directory path dir)
"Render the contents of DIR represented by the URI PATH." "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 (define render-child
(match-lambda (match-lambda
((file-name directory?) ((file-name directory?)
`(li `(li
(a (@ (href ,(string-append path "/" file-name))) (a (@ (href ,(concat+uri-encode path file-name)))
,(if directory? ,(if directory?
(string-append file-name "/") (string-append file-name "/")
file-name)))))) file-name))))))
@ -115,7 +136,6 @@ FILE-NAME."
(title ,title)) (title ,title))
(body (body
(h1 ,title) (h1 ,title)
(h2 "<i>foobar</i>")
(ul ,@(map render-child children)))))) (ul ,@(map render-child children))))))
(values '((content-type . (text/html))) (values '((content-type . (text/html)))
(lambda (port) (lambda (port)
@ -140,9 +160,10 @@ FILE-NAME."
(define (make-handler work-dir) (define (make-handler work-dir)
(lambda (request body) (lambda (request body)
"Serve the file asked for in REQUEST." "Serve the file asked for in REQUEST."
(let ((path (uri-path (request-uri request)))) (format #t "~a ~a~%"
(format #t "~a ~a~%" (request-method request) path) (request-method request)
(serve-file work-dir path)))) (uri-path (request-uri request)))
(serve-file work-dir (request-file-name request))))
(define* (serve work-dir #:key (open-params '())) (define* (serve work-dir #:key (open-params '()))
"Run a simple HTTP server that serves files in WORK-DIR." "Run a simple HTTP server that serves files in WORK-DIR."