Adding support for additional headers with redirect-to

svn: r6403
This commit is contained in:
Jay McCarthy 2007-05-30 15:19:44 +00:00
parent 4cdddaec1a
commit ce4c6fac38
4 changed files with 14 additions and 8 deletions

View File

@ -52,6 +52,7 @@
;; serve-file : connection symbol uri host -> void
;; to find the file, including searching for implicit index files, and serve it out
(define path
; XXX Abstract this
(url-path->path htdocs-path
(uri-decode (url-path->string (url-path uri)))))
(cond

View File

@ -116,6 +116,7 @@
(raise (make-exn:fail:filesystem:exists:servlet
(exn-message e)
(exn-continuation-marks e))))])
; XXX Abstract this
(url-path->path
servlet-root
(url-path->string (url-path uri)))))

View File

@ -1,6 +1,6 @@
(module servlet-helpers mzscheme
(require (lib "contract.ss")
(lib "etc.ss")
(lib "kw.ss")
(lib "plt-match.ss")
(lib "base64.ss" "net")
(lib "uri-codec.ss" "net"))
@ -36,12 +36,15 @@
(define see-other (make-redirection-status 303 "See Other"))
; : str [redirection-status] -> response
(define redirect-to
(opt-lambda (uri [perm/temp permanently])
(make-response/full (redirection-status-code perm/temp)
(redirection-status-message perm/temp)
(current-seconds) #"text/html"
`((Location . ,uri)) (list))))
(define/kw (redirect-to uri
#:optional
[perm/temp permanently]
#:key
[headers (list)])
(make-response/full (redirection-status-code perm/temp)
(redirection-status-message perm/temp)
(current-seconds) #"text/html"
`((Location . ,uri) ,@headers) (list)))
; with-errors-to-browser
; to report exceptions that occur later to the browser
@ -87,11 +90,11 @@
(provide ; all-from
with-errors-to-browser
redirect-to
(rename uri-decode translate-escapes))
(provide/contract
; XXX contract maybe
[extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]
[redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
[permanently redirection-status?]
[temporarily redirection-status?]
[see-other redirection-status?]

View File

@ -65,6 +65,7 @@
(define (begin-session conn req)
(define uri (request-uri req))
(define-values (a-path url-servlet-path url-path-suffix)
; XXX Abstract this, so they don't need to live on disk.
(url->servlet-path htdocs-path uri))
(if a-path
(parameterize ([current-directory (directory-part a-path)])