;;; 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 "
~%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 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 new location.~%" (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 "

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 "

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 "

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.

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

~A

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