suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding support for additional headers with redirect-to

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/web-server/dispatchers/dispatch-files.ss
View File

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

1
collects/web-server/dispatchers/dispatch-servlets.ss
View File

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

19
collects/web-server/private/servlet-helpers.ss
View File

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

1
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -65,6 +65,7 @@
(define (begin-session conn req) (define (begin-session conn req)
(define uri (request-uri req)) (define uri (request-uri req))
(define-values (a-path url-servlet-path url-path-suffix) (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)) (url->servlet-path htdocs-path uri))
(if a-path (if a-path
(parameterize ([current-directory (directory-part a-path)]) (parameterize ([current-directory (directory-part a-path)])