sunet/scheme/httpd/response.scm

59 lines
1.7 KiB
Scheme

(define-record-type :http-response
(make-response code message seconds mime extras body)
response?
(code response-code)
(message response-message)
(seconds response-seconds)
(mime response-mime)
(extras response-extras)
(body response-body))
(define-record-type :http-writer-body
(make-writer-body proc)
writer-body?
(proc writer-body-proc))
(define (display-http-body body port options)
((writer-body-proc body) port options))
(define-syntax define-http-status-codes
(syntax-rules ()
((define-http-status-codes table set (name val msg) ...)
(begin (define table '((val . msg) ...))
(define-enum-constant set name val)
...))))
(define-http-status-codes http-status-text-table http-status
(ok 200 "OK")
(created 201 "Created")
(accepted 202 "Accepted")
(prov-info 203 "Provisional Information")
(no-content 204 "No Content")
(mult-choice 300 "Multiple Choices")
(moved-perm 301 "Moved Permanently")
(moved-temp 302 "Moved Temporarily")
(method 303 "Method (obsolete)")
(not-mod 304 "Not Modified")
(bad-request 400 "Bad Request")
(unauthorized 401 "Unauthorized")
(payment-req 402 "Payment Required")
(forbidden 403 "Forbidden")
(not-found 404 "Not Found")
(method-not-allowed 405 "Method Not Allowed")
(none-acceptable 406 "None Acceptable")
(proxy-auth-required 407 "Proxy Authentication Required")
(timeout 408 "Request Timeout")
(conflict 409 "Conflict")
(gone 410 "Gone")
(internal-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"))
(define (status-code->text code)
(cdr (assv code http-status-text-table)))