From c97bbfc1db908e11f868796a468bf1426bd6f676 Mon Sep 17 00:00:00 2001 From: sperber Date: Tue, 27 Aug 2002 09:39:05 +0000 Subject: [PATCH] Move MAKE-HTTP-ERROR-RESPONSE from HTTPD-CORE to HTTPD-RESPONSES. Elide REALLY-MAKE-HTTP-ERROR-RESPONSE in the process. --- scheme/httpd/core.scm | 141 -------------------------------------- scheme/httpd/response.scm | 133 ++++++++++++++++++++++++++++++++++- scheme/packages.scm | 17 +++-- 3 files changed, 144 insertions(+), 147 deletions(-) diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 715b948..69e79d9 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -305,147 +305,6 @@ (write-crlf port)) headers)) -(define (time->http-date-string time) - (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0))) - -;;; (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. - -;;; MAKE-HTTP-ERROR-RESPONSE is called from error handlers, so to avoid -;;; infinite looping, if an error occurs while it is running, we just -;;; silently return. (We no longer need to do this; I have changed -;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll -;;; leave it in to play it safe.) - -(define (make-http-error-response status-code req . args) - (ignore-errors - (lambda () ; Ignore errors -- see note above. - (apply really-make-http-error-response status-code req args)))) - -(define (really-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)))) - (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) - (if message (format port "
~%Reason: ~A~%" message)) - (close-html port)))) - - ((= status-code http-status/unauthorized) - (create-response - (list (cons 'WWW-Authenticate message)) ; Vas is das? - (lambda (port options) - (title-html port "Authorization Required") - (write-string "

Browser not authentication-capable or\n" port) - (write-string "authentication failed.\n" port) - (if message (format port "~a~%" message)) - (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)) - (if message (format port "

~%~a~%" message)) - (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) - (if message (format port "

~%~a~%" message)) - (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.~%" - (httpd-options-server-admin options)) - (if message (format port "

~%~a~%" message)) - (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)) - (if message (format port "

~a~%" message)) - (close-html port)))) - - (else - (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code) - (create-response - '() - (lambda (port options) - (generic-title port) - (close-html port))))))) - -(define (title-html out message) - (format out "~%~%~A~%~%~%~%" message) - (format out "~%

~A

~%" message)) - ;;; Return my Internet host name (my fully-qualified domain name). ;;; This works only if an actual resolver is behind host-info. ;;; diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index dd18256..d45c363 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -1,5 +1,6 @@ ;;; 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. @@ -62,4 +63,134 @@ (gateway-timeout 504 "Gateway Timeout")) (define (status-code->text code) - (cdr (assv code http-status-text-table))) \ No newline at end of file + (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)))) + (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) + (if message (format port "
~%Reason: ~A~%" message)) + (close-html port)))) + + ((= status-code http-status/unauthorized) + (create-response + (list (cons 'WWW-Authenticate message)) ; Vas is das? + (lambda (port options) + (title-html port "Authorization Required") + (write-string "

Browser not authentication-capable or\n" port) + (write-string "authentication failed.\n" port) + (if message (format port "~a~%" message)) + (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)) + (if message (format port "

~%~a~%" message)) + (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) + (if message (format port "

~%~a~%" message)) + (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.~%" + (httpd-options-server-admin options)) + (if message (format port "

~%~a~%" message)) + (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)) + (if message (format port "

~a~%" message)) + (close-html port)))) + + (else + (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code) + (create-response + '() + (lambda (port options) + (generic-title 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))) diff --git a/scheme/packages.scm b/scheme/packages.scm index 048521a..54e380f 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -254,9 +254,7 @@ ;; Web server (define-interface httpd-core-interface - (export httpd - make-http-error-response - time->http-date-string)) + (export httpd)) (define-interface httpd-make-options-interface (export make-httpd-options @@ -362,7 +360,10 @@ http-status/not-implemented http-status/bad-gateway http-status/service-unavailable - http-status/gateway-timeout)) + http-status/gateway-timeout + + make-http-error-response + time->http-date-string)) (define-interface httpd-basic-handlers-interface (export make-request-handler @@ -751,8 +752,14 @@ (define-structure httpd-responses httpd-responses-interface (open scheme + (subset scsh (format-date write-string time date)) + syslog srfi-9 - defenum-package) + defenum-package + formats + httpd-request + httpd-logging + httpd-read-options) (files (httpd response))) (define-structure httpd-basic-handlers httpd-basic-handlers-interface