;;; 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 "
~%Further Information: ~A
~%" message)))) (close-html (lambda (port) (for-each (lambda (x) (format port "
~s~%" x)) extras) (write-string "\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 new location.~%" (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 "

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 "

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 "

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.

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 "~%~%~A~%~%~%~%" message) (format out "~%

~A

~%" 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)))