#lang scheme/base
(require mzlib/trace
scheme/contract
web-server/http/request-structs
web-server/http/response-structs
web-server/http/redirect
net/url
xml
"request.ss"
"cookie.ss"
"depend.ss"
"base.ss"
)
(define http-status '((continue 100 "Continue")
(switching-protocols 101 "Switching Protocols")
(ok 200 "OK")
(created 201 "Created")
(accepted 202 "Accepted")
(non-authoritative-information 203 "Non-Authoritative Information")
(no-content 204 "No Content")
(reset-content 205 "Reset Content")
(partial-content 206 "Partial Content")
(multiple-choices 300 "Multiple Choices")
(moved-permanently 201 "Moved Permanently")
(found 302 "Found")
(see-other 303 "See Other")
(not-modified 304 "Not Modified")
(use-proxy 305 "Use Proxy")
(temporary-redirect 307 "Temporary Redirect")
(bad-request 400 "Bad Request")
(unauthorized 401 "Unauthorized")
(payment-required 402 "Payment Required")
(forbidden 403 "Forbidden")
(not-found 404 "Not Found")
(method-not-allowed 405 "Method Not Allowed")
(not-acceptable 406 "Not Acceptable")
(proxy-authentication-required 407 "Proxy Authentication Required")
(request-timeout 408 "Request Timeout")
(conflict 409 "Conflict")
(gone 410 "Gone")
(length-required 411 "Length Required")
(precondition-failed 412 "Precondition Failed")
(request-entity-too-large 413 "Request Entity Too Large")
(request-uri-too-long 414 "Request-URI Too Long")
(unsupported-media-type 415 "Unsupported Media Type")
(request-range-not-satisfied 416 "Requested Range Not Satisfiable")
(expectation-failed 417 "Expectation Failed")
(internal-server-error 500 "Internal Server Error")
(not-implemented 501 "Not Implemented")
(bad-gateway 502 "Bad Gateway")
(service-unavailable 503 "Service Unavailable")
(gateway-timeout 504 "Gateway Timeout")
(version-not-supported 505 "HTTP Version Not Supported")))
(define $response-headers (make-parameter '()))
(define $status (make-parameter 'ok))
(define (valid-status? status)
(assoc status http-status))
(define ($status->code (status ($status)))
(cadr (valid-status? status)))
(define ($status->text (status ($status)))
(string->bytes/utf-8 (caddr (valid-status? status))))
(define-struct http-result (status args))
(define (raise-http-result! code . args)
(raise (make-http-result code args)))
(define (raise-http-not-found! path)
(raise-http-result! 'not-found path))
(define (raise-http-internal-error! e)
(raise-http-result! 'internal-server-error e))
(provide/contract
(struct http-result ((status valid-status?)
(args (listof any/c))))
(raise-http-result!
(->* (valid-status?)
()
#:rest (listof any/c)
any))
(raise-http-not-found! (-> path-equiv? any))
(raise-http-internal-error! (-> any/c any))
)
(define $content-type (make-parameter "text/html; charset=utf-8"))
(define (header! key val (replace? #t))
($response-headers (cons (cons key val) ($headers))))
(define ($headers->headers)
(map (lambda (kv)
(make-header (string->bytes/utf-8 (car kv))
(string->bytes/utf-8 (cdr kv))))
($response-headers)))
(define (make-response output (status ($status)))
(cond ((bytes? output)
(make-response/full ($status->code status)
($status->text status)
(current-seconds)
(string->bytes/utf-8 ($content-type))
(append ($headers->headers)
($cookies->headers))
(list output)))
((xexpr? output)
(make-response (string->bytes/utf-8 (xexpr->string output)) status))
((input-port? output) (make-response (call-with-input-port output port->bytes) status))
((response/basic? output)
output)))
(define (redirect! url
#:status (status 'temporary-redirect)
#:headers (headers '()))
(define (header-helper h)
(cond ((header? h) h)
((pair? h) (make-header (string->bytes/utf-8 (car h))
(string->bytes/utf-8 (cdr h))))
((cookie? h)
(cookie->header h))))
(raise (redirect-to (if (url? url) (url->string url) url)
(case status
((found) permanently)
((see-other) see-other)
((temporary-redirect) temporarily))
#:headers (map header-helper headers))))
(provide/contract
($response-headers (parameter/c (listof any/c)))
($status (parameter/c valid-status?))
($status->code (->* ()
(valid-status?)
exact-nonnegative-integer?))
($status->text (->* ()
(valid-status?)
string?))
($content-type (parameter/c string?))
(header! (->* (string? string?)
(boolean?)
any))
(make-response (->* ((or/c bytes? xexpr? input-port? response/c))
(valid-status?)
response/c))
(redirect! (->* ((or/c string? url?))
(#:status (or/c 'found 'see-other 'temporary-redirect)
#:headers (listof (or/c (cons/c string? string?)
header?
cookie?)))
any))
)