298 lines
10 KiB
Scheme
298 lines
10 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 :http-response
|
|
(make-response code message seconds mime extras body)
|
|
response?
|
|
(code response-code) ;;HTTP status code
|
|
(message response-message);;reason phrase: textual description of
|
|
;;status-code, or #f (-> server sends
|
|
;;default reason phrase)
|
|
(seconds response-seconds);;time the content was created
|
|
(mime response-mime);;string indicating the MIME type of the response
|
|
(extras response-extras);;assoc list with extra headers to be
|
|
;;added to the response; its elements are
|
|
;;pairs, each of which consists of a symbol
|
|
;;representing the field name and a string
|
|
;;representing the field value.
|
|
(body response-body));; message-body
|
|
|
|
;; This is mainly for nph-... CGI scripts.
|
|
;; This means that the body will output the entire MIME message, not
|
|
;; just the part after the headers.
|
|
|
|
(define-record-type http-nph-response :http-nph-response
|
|
(make-nph-response body)
|
|
nph-response?
|
|
(body nph-response-body))
|
|
|
|
(define-record-type http-input-response :http-input-response
|
|
(make-input-response body-maker)
|
|
input-response?
|
|
(body-maker input-response-body-maker))
|
|
|
|
(define-record-type http-writer-body :http-writer-body
|
|
(make-writer-body proc)
|
|
writer-body?
|
|
(proc writer-body-proc))
|
|
|
|
(define-record-type http-reader-writer-body :http-reader-writer-body
|
|
(make-reader-writer-body proc)
|
|
reader-writer-body?
|
|
(proc reader-writer-body-proc))
|
|
|
|
(define-record-type http-redirect-body :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-finite-type status-code :http-status-code
|
|
(number message)
|
|
status-code?
|
|
status-codes
|
|
status-code-name
|
|
status-code-index
|
|
(number status-code-number)
|
|
(message status-code-message)
|
|
(
|
|
(continue 100 "Continue")
|
|
(switch-protocol 101 "Switching Protocols")
|
|
|
|
(ok 200 "OK")
|
|
(created 201 "Created")
|
|
(accepted 202 "Accepted")
|
|
(non-author-info 203 "Non-Authoritative Information")
|
|
(no-content 204 "No Content")
|
|
(reset-content 205 "Reset Content")
|
|
(partial-content 206 "Partial Content")
|
|
|
|
(mult-choice 300 "Multiple Choices")
|
|
(moved-perm 301 "Moved Permanently")
|
|
(found 302 "Found");;use 303 or 307 for unambiguity;
|
|
;;use 302 for compatibility with
|
|
;;pre-1.1-clients
|
|
(see-other 303 "See other");;client is expected to
|
|
;;perform a GET on new URI
|
|
(not-mod 304 "Not Modified")
|
|
(use-proxy 305 "Use Proxy")
|
|
(temp-redirect 307 "Temporary Redirect");;analogous to "302
|
|
;;Moved Temporarily"
|
|
;;in RFC1945
|
|
|
|
(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-auth-required 407 "Proxy Authentication Required")
|
|
(timeout 408 "Request Timeout")
|
|
(conflict 409 "Conflict")
|
|
(gone 410 "Gone")
|
|
(length-required 411 "Length Required")
|
|
(precon-failed 412 "Precondition Failed")
|
|
(req-ent-too-large 413 "Request Entity Too Large")
|
|
(req-uri-too-large 414 "Request URI Too Large")
|
|
(unsupp-media-type 415 "Unsupported Media Type")
|
|
(req-range-not-sat 416 "Requested Range Not Satisfiable")
|
|
(expectation-failed 417 "Expectation Failed")
|
|
|
|
(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")
|
|
(version-not-supp 505 "HTTP Version Not Supported")
|
|
|
|
(redirect -301 "Internal redirect")))
|
|
|
|
(define (name->status-code name)
|
|
(if (not (symbol? name))
|
|
(call-error name->status-code (list name))
|
|
(let loop ((i 0))
|
|
(cond ((= i (vector-length status-codes))
|
|
#f)
|
|
((eq? name
|
|
(status-code-name (vector-ref status-codes i)))
|
|
(vector-ref status-codes i))
|
|
(else
|
|
(loop (+ i 1)))))))
|
|
|
|
(define (number->status-code number)
|
|
(if (not (number? number))
|
|
(call-error number->status-code (list number))
|
|
(let loop ((i 0))
|
|
(cond ((= i (vector-length status-codes))
|
|
#f)
|
|
((= number
|
|
(status-code-number (vector-ref status-codes i)))
|
|
(vector-ref status-codes i))
|
|
(else
|
|
(loop (+ i 1)))))))
|
|
|
|
;;; (make-error-response status-code req [extras])
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;
|
|
;;; 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 can be the case for
|
|
;;; internal-error, bad-request, (possibly bad-gateway and ...?)
|
|
|
|
|
|
(define (make-error-response code req . extras)
|
|
(let*
|
|
;;catch server internal errors coming off by calls of make-error-response with too few arguments
|
|
((assert (lambda (n)
|
|
(if (< (length extras) n)
|
|
(make-error-response (status-code internal-error) req
|
|
"Too few arguments to make-error-response"))))
|
|
(generic-title (lambda (port)
|
|
(title-html port
|
|
(status-code-message code))))
|
|
(close-html (lambda (port args)
|
|
(if (not (null? args))
|
|
(format port "<br/>~%Further Information:~%"))
|
|
(for-each (lambda (x) (format port "<br/>~%~s~%" x)) args)
|
|
(write-string "</p>\n</body>\n</html>\n" port)))
|
|
|
|
(create-response
|
|
(lambda (headers writer-proc)
|
|
(make-response code
|
|
#f
|
|
(time)
|
|
"text/html"
|
|
headers
|
|
(make-writer-body writer-proc)))))
|
|
|
|
(cond
|
|
;; This error response requires one arg:
|
|
;; the value of the Location field header,
|
|
;; which must be a single absolute URI
|
|
((or (eq? code (status-code found));302
|
|
(eq? code (status-code see-other));303
|
|
(eq? code (status-code temp-redirect));307
|
|
(eq? code (status-code moved-perm)));301
|
|
(assert 1)
|
|
(create-response
|
|
(list (cons 'location (car extras)))
|
|
(lambda (port options)
|
|
(title-html port "Document moved")
|
|
(format port
|
|
"The requested resource has moved ~A to a <a href=\"~A\">new location</a>.~%"
|
|
(if (eq? code (status-code moved-perm))
|
|
"permanently"
|
|
"temporarily")
|
|
(car extras))
|
|
(close-html port (cdr extras)))))
|
|
|
|
((eq? code (status-code bad-request))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(write-string "The request the client sent could not be understood by this server due to malformed syntax.\n Report to client maintainer.\n" port)
|
|
(close-html port extras))))
|
|
|
|
;; This error response requires one arg:
|
|
;; the value of the Allow field header,
|
|
;; which must be a list of valid methods for the requested resource
|
|
((eq? code (status-code method-not-allowed))
|
|
(assert 1)
|
|
(create-response
|
|
(list (cons 'allow (car extras)))
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(format port "The method ~A is not allowed on the requested resource ~A.~%" (request-method req) (request-uri req))
|
|
(close-html port (cdr extras)))))
|
|
|
|
;; This error response requires one arg:
|
|
;; the value of the WWW-Authenticate header field,
|
|
;; which must be a challenge (as described in RFC 2617)
|
|
((eq? code (status-code unauthorized))
|
|
(assert 1)
|
|
(create-response
|
|
(list (cons 'WWW-Authenticate (car extras)))
|
|
(lambda (port options)
|
|
(title-html port "Authentication Required")
|
|
(write-string "Client not authentication-capable or authentication failed.\n" port)
|
|
(close-html port (cdr extras)))))
|
|
|
|
((eq? code (status-code forbidden))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(title-html port "Request not allowed.")
|
|
(write-string "The request the client sent is not allowed.\n Retrying won't help.\n" port)
|
|
(close-html port extras))))
|
|
|
|
((eq? code (status-code not-found))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(title-html port "Resource not found")
|
|
(format port "The requested resource ~A was not found on this server.\n" (request-uri req))
|
|
(close-html port extras))))
|
|
|
|
((eq? code (status-code internal-error))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(format port "This server encountered an internal error or misconfiguration and was unable to complete your request.~%<br/>~%Please inform the server administrator ~A of the circumstances leading to the error, and the time it occured.~%"
|
|
(or (httpd-options-server-admin options)
|
|
"[no mail address available]"))
|
|
(close-html port extras))))
|
|
|
|
((eq? code (status-code not-implemented))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(format port "This server does not recognize or does not implement the requested method \"~A\".~%"
|
|
(request-method req))
|
|
(close-html port extras))))
|
|
|
|
((eq? code (status-code bad-gateway))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(format port "This server recieved an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
|
|
(close-html port extras)))))))
|
|
|
|
(define (title-html out message)
|
|
;;produce valid XHTML 1.0 Strict
|
|
(write-string
|
|
"<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>
|
|
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
|
|
<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en\" xml:lang=\"en\">\n" out)
|
|
(format out "<head>~%<title>~%~A~%</title>~%</head>~%~%" message)
|
|
(format out "<body>~%<h1>~A</h1>~%<p>~%" message))
|
|
|
|
;; 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. This is intended for CGI scripts. Note that
|
|
;; the browser won't notice the redirect. Thus, it will keep the
|
|
;; original URL. For "real" redirections, use
|
|
;; (make-error-response (status-code moved-perm) req
|
|
;; "new-location").
|
|
(define (make-redirect-response new-location)
|
|
(make-response
|
|
(status-code redirect)
|
|
#f
|
|
(time)
|
|
""
|
|
'()
|
|
(make-redirect-body new-location)))
|