242 lines
7.5 KiB
Scheme
242 lines
7.5 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))))
|
|
(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 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)
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((= status-code http-status/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))))
|
|
|
|
((= 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))
|
|
(send-message port)
|
|
(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)
|
|
(send-message port)
|
|
(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.~%"
|
|
(or (httpd-options-server-admin options)
|
|
"[no mail address available]"))
|
|
(send-message port)
|
|
(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))
|
|
(send-message port)
|
|
(close-html port))))
|
|
|
|
((= status-code http-status/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))))
|
|
|
|
(else
|
|
(http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code)
|
|
(create-response
|
|
'()
|
|
(lambda (port options)
|
|
(generic-title port)
|
|
(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))
|
|
|
|
(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))) |