sunet/scheme/httpd/response.scm

;;; This file is part of the Scheme Untergrund Networking package.

;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

(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)))