Adding support for additional headers with redirect-to
svn: r6403
This commit is contained in:
parent
4cdddaec1a
commit
ce4c6fac38
|
@ -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
|
||||
|
|
|
@ -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)))))
|
||||
|
|
|
@ -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?]
|
||||
|
|
|
@ -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)])
|
||||
|
|
Loading…
Reference in New Issue
Block a user