;;; This file is part of the Scheme Untergrund Networking package.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define http-version '(1 . 1));server's HTTP-version is only hardcoded here!
(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
;;TODO: mime shouldn't be a field in http-response, because it needn't be present for
;;responses which don't include a message-body.
;;Instead treat mime-type like any other header.
;;(Not urgent, as RFC 2616 doesn't prohibit presence of Content-Type header field
;;in body-less responses).
;; 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))
;; the concept of http-reader-writer-body doesn't work: status-line
;; and headers of the response (i.e. the whole http-response record)
;; have to be built _before_ we have seen the entity-body of the
;; request. (Not until display-http-body hands over the iport to
;; reader-writer-body the entity-body can be read in). If the
;; entity-body is erroneous or if we encounter a server internal error
;; while reading in the entity-body we are not able to send an
;; appropriate response. (At that point of time we already sent
;; status-line and response-headers!)
(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))
;; type for responses which MUST NOT include a body (101, 204, 304)
(define-enumerated-type no-body :no-body
no-body?
no-body-elements
no-body-name
no-body-index
(none))
(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/>~%~A~%" x)) args)
(format port "</p>~%</body>~%</html>~%")))
(create-response
(lambda (headers body)
(make-response code
#f
(time)
"text/html"
headers
body)))
(create-writer-body-response
(lambda (headers writer-proc)
(create-response headers (make-writer-body writer-proc))))
(create-no-body-response
(lambda (headers)
(create-response headers (no-body none)))))
(cond
;;this response requires one arg:
;;the value of the Upgrade field header,
;;which must be a string listing the protocols which are being switched
;;for example "HTTP/2.0, IRC/6.9"
((eq? code (status-code switch-protocol));; server currently doesn't have ability to switch protocols
(assert 1)
(create-no-body-response
(list (cons 'upgrade (car extras))
(cons 'connection "upgrade")))) ;; need this, because Upgrade header field only applies to immediate connection
((eq? code (status-code no-content))
(create-no-body-response '()))
;; 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-writer-body-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 not-mod))
(create-no-body-response '())) ;;see RCF 2616 10.3.5: this is only a valid answer if the server never sends
;;any of the headers Expires, Cache-Control, Vary for this resource
((eq? code (status-code bad-request))
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "The request the client sent could not be understood by this server due to malformed syntax.~% Report to client maintainer.~%")
(close-html port extras))))
;; This error response requires one arg:
;; the value of the Allow field header,
;; which must be a string listing the valid methods for the requested resource
;; Ex.: "GET, HEAD, POST"
((eq? code (status-code method-not-allowed))
(assert 1)
(create-writer-body-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) (http-url->url-string (request-url 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-writer-body-response
(list (cons 'WWW-Authenticate (car extras)))
(lambda (port options)
(title-html port "Authentication Required")
(format port "Client not authentication-capable or authentication failed.~%")
(close-html port (cdr extras)))))
((eq? code (status-code forbidden))
(create-writer-body-response
'()
(lambda (port options)
(title-html port "Request not allowed.")
(format port "The request the client sent is not allowed.~% Retrying won't help.~%")
(close-html port extras))))
((eq? code (status-code not-found))
(create-writer-body-response
'()
(lambda (port options)
(title-html port "Resource not found")
(format port "The requested resource ~A was not found on this server.~%"
(http-url->url-string (request-url req)))
(close-html port extras))))
((eq? code (status-code internal-error))
(create-writer-body-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-writer-body-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-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
(close-html port extras))))
((eq? code (status-code version-not-supp))
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is 1.~%"
(car (request-version req)))
; (format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is ~D.~%"
; (car (request-version req))
; (car http-version))
(close-html port extras)))))))
(define (title-html out message)
;;produce valid XHTML 1.0 Strict
(emit-prolog out)
(emit-tag out 'html xmlnsdecl-attr)
(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)))