sunet/scheme/httpd/response.scm

225 lines
7.1 KiB
Scheme

;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; 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-record-type :http-reader-writer-body
(make-reader-writer-body proc)
reader-writer-body?
(proc reader-writer-body-proc))
(define-record-type :http-redirect-body
(make-redirect-body location)
redirect-body?
(location redirect-body-location))
(define (display-http-body body iport oport options)
(cond
((writer-body? body)
((writer-body-proc body) oport options))
((reader-writer-body? body)
((reader-writer-body-proc body) iport oport 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")
(redirect -301 "Internal redirect"))
(define (status-code->text code)
(cdr (assv code http-status-text-table)))
;;; (make-http-error-response status-code req [message . extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Take an http-error condition, and format it into a response to the client.
;;;
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
;;; even had a chance to parse and construct the request. This is only used
;;; for 400 BAD-REQUEST error report.
(define (make-http-error-response status-code req . args)
(http-log req status-code)
(let* ((message (and (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '()))
(generic-title (lambda (port)
(title-html port
(status-code->text status-code))))
(close-html (lambda (port)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" port)))
(create-response
(lambda (headers writer-proc)
(make-response status-code
(status-code->text status-code)
(time)
"text/html"
headers
(make-writer-body writer-proc)))))
(cond
;; This error response requires two args: message is the new URI: field,
;; and the first EXTRA is the older Location: field.
((or (= status-code http-status/moved-temp)
(= status-code http-status/moved-perm))
(create-response
(list (cons 'uri message)
(cons 'location (car extras)))
(lambda (port options)
(title-html port "Document moved")
(format port
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
(if (= status-code http-status/moved-temp) "temporarily" "permanently")
message)
(close-html port))))
((= status-code http-status/bad-request)
(create-response
'()
(lambda (port options)
(generic-title port)
(write-string "<P>Client sent a query that this server could not understand.\n"
port)
(if message (format port "<BR>~%Reason: ~A~%" message))
(close-html port))))
((= status-code http-status/unauthorized)
(create-response
(list (cons 'WWW-Authenticate message)) ; Vas is das?
(lambda (port options)
(title-html port "Authorization Required")
(write-string "<P>Browser not authentication-capable or\n" port)
(write-string "authentication failed.\n" port)
(if message (format port "~a~%" message))
(close-html port))))
((= status-code http-status/forbidden)
(create-response
'()
(lambda (port options)
(title-html port "Request not allowed.")
(format port
"Your client does not have permission to perform a ~A~%"
(request:method req))
(format port "operation on url ~a.~%" (request:uri req))
(if message (format port "<P>~%~a~%" message))
(close-html port))))
((= status-code http-status/not-found)
(create-response
'()
(lambda (port options)
(title-html port "URL not found")
(write-string
"<P>The requested URL was not found on this server.\n"
port)
(if message (format port "<P>~%~a~%" message))
(close-html port))))
((= status-code http-status/internal-error)
(http-syslog (syslog-level error) "internal-error: ~A" message)
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "The server encountered an internal error or
misconfiguration and was unable to complete your request.
<P>
Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occured.~%"
(httpd-options-server-admin options))
(if message (format port "<P>~%~a~%" message))
(close-html port))))
((= status-code http-status/not-implemented)
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "This server does not currently implement
the requested method (~A).~%"
(request:method req))
(if message (format port "<P>~a~%" message))
(close-html port))))
(else
(http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code)
(create-response
'()
(lambda (port options)
(generic-title port)
(close-html port)))))))
(define (title-html out message)
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
(format out "<BODY>~%<H1>~A</H1>~%" message))
(define (time->http-date-string time)
(format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
;; Creates a redirect response. The server will serve the new file indicated by
;; NEW-LOCATION. NEW-LOCATION must be uri-encoded and begin with a slash.
(define (make-redirect-response new-location)
(make-response
http-status/redirect
(status-code->text http-status/redirect)
(time)
""
'()
(make-redirect-body new-location)))