262 lines
8.0 KiB
Scheme
262 lines
8.0 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)
|
|
(message response-message)
|
|
(seconds response-seconds)
|
|
(mime response-mime)
|
|
(extras response-extras)
|
|
(body response-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-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)
|
|
(
|
|
(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 (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 [message . 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 is only used
|
|
;;; for 400 BAD-REQUEST error report.
|
|
|
|
(define (make-error-response code req . args)
|
|
(let* ((message (and (pair? args) (car args)))
|
|
(extras (if (pair? args) (cdr args) '()))
|
|
|
|
(generic-title (lambda (port)
|
|
(title-html port
|
|
(status-code-message code))))
|
|
(send-message (lambda (port)
|
|
(if message
|
|
(format port "<BR>~%Further Information: ~A<BR>~%" message))))
|
|
(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 code
|
|
#f
|
|
(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 (eq? code (status-code moved-temp))
|
|
(eq? code (status-code 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 (eq? code (status-code moved-temp))
|
|
"temporarily"
|
|
"permanently")
|
|
message)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code 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)
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code unauthorized))
|
|
(create-response
|
|
(list (cons 'WWW-Authenticate message)) ; Vas is das?
|
|
;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
|
|
;; message should be a challenge(?)
|
|
(lambda (port options)
|
|
(title-html port "Authorization Required")
|
|
(write-string "<P>Browser not authentication-capable or\n" port)
|
|
(write-string "authentication failed.\n" port)
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code 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))
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code 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)
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code internal-error))
|
|
(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.~%"
|
|
(or (httpd-options-server-admin options)
|
|
"[no mail address available]"))
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code 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))
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((eq? code (status-code bad-gateway))
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(format port "An error occured while waiting for the
|
|
response of a gateway.~%")
|
|
(send-message port)
|
|
(close-html port)))))))
|
|
|
|
(define (title-html out message)
|
|
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
|
|
(format out "<BODY>~%<H1>~A</H1>~%" 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" "new-location").
|
|
(define (make-redirect-response new-location)
|
|
(make-response
|
|
(status-code redirect)
|
|
#f
|
|
(time)
|
|
""
|
|
'()
|
|
(make-redirect-body new-location)))
|