(module response mzscheme
(provide (all-defined))
(require (lib "kw.ss")
(lib "private/response-structs.ss" "web-server")
(lib "private/request-structs.ss" "web-server")
"cookie.scm"
"doctype.scm")
(define current-response-code (make-parameter 200))
(define current-response-message (make-parameter "Okay"))
(define current-response-seconds (make-parameter (current-seconds)))
(define current-response-mime (make-parameter (string->bytes/utf-8 "text/html")))
(define current-response-extras (make-parameter '()))
(define current-redirect-permanently (make-parameter #f)) (define current-redirect-temporarily (make-parameter #f)) (define current-redirect-see-other (make-parameter #f))
(define/kw (make-response
document #:key
(code (current-response-code))
(message (current-response-message))
(seconds (current-response-seconds))
(mime (current-response-mime)))
(let* ([cookies
(map (lambda (c) (make-header #"Set-Cookie" (string->bytes/utf-8 c)))
(current-output-cookies))]
[extras
(append cookies
(current-response-extras))])
(begin (display (list (current-redirect-permanently)
(current-redirect-temporarily)
(current-redirect-see-other)))
(newline))
(cond
[(or (current-redirect-permanently)
(current-redirect-temporarily)
(current-redirect-see-other))
(let-values
([(code message url)
(cond
[(current-redirect-permanently) => (λ (url) (values 301 "Moved Permanently" url))]
[(current-redirect-temporarily) => (λ (url) (values 302 "Moved Temporarily" url))]
[(current-redirect-see-other) => (λ (url) (values 303 "See Other" url))])])
(make-response/full code message seconds mime
(append (list (make-header #"Location" (string->bytes/utf-8 url)))
(list (make-header #"Pragma" #"No-cache")
(make-header #"Cache-Control" #"no-cache")
(make-header #"Expires" #"Thu, 01 Jan 1970 00:00:00 GMT"))
extras)
(list (current-doctype)
document)))]
[else
(make-response/full code message seconds mime
(append (list (make-header #"Pragma" #"No-cache")
(make-header #"Cache-Control" #"no-cache")
(make-header #"Expires" #"Thu, 01 Jan 1970 00:00:00 GMT"))
extras)
(list (current-doctype)
document))])))
)