From a803c62958b0dc30a2e6c916bf3702b931b315a8 Mon Sep 17 00:00:00 2001 From: "Pierre R. Mai" Date: Wed, 7 Feb 2001 14:06:14 +0000 Subject: [PATCH] Improved error response generation. We now keep track of the last request read on a connection, which allows us to generate the correct type of response in case of an error which is handled through `handle-server-error'. Also added code to correctly escape text that is inserted into error messages. This is also a first step towards preventing cross-scripting attacks through CLASH, although most of the code still has to be audited for unfiltered passing through of user-supplied text. --- src/main/connection.cl | 3 ++- src/main/messages.cl | 9 ++++---- src/main/parsing.cl | 17 ++++++++++++++ src/main/server.cl | 51 +++++++++++++++++++++++++++--------------- 4 files changed, 56 insertions(+), 24 deletions(-) diff --git a/src/main/connection.cl b/src/main/connection.cl index 5811cdf..3ef78a5 100644 --- a/src/main/connection.cl +++ b/src/main/connection.cl @@ -25,7 +25,8 @@ "List of states that a connection can be in.") (defclass connection () - ((state :initarg :state :initform :fresh :accessor connection-state))) + ((state :initarg :state :initform :fresh :accessor connection-state) + (last-request :initform nil :accessor connection-last-request))) (defgeneric connection-stream (connection)) diff --git a/src/main/messages.cl b/src/main/messages.cl index 2f90b92..12afda4 100644 --- a/src/main/messages.cl +++ b/src/main/messages.cl @@ -96,6 +96,7 @@ request object, which references the given server and connection.")) :server server :method method :url url))) + (setf (connection-last-request connection) request) (parse-request-remainder request stream) request)))) @@ -198,7 +199,7 @@ string pairs for further parsing." specified by the clauses, and return as values the list of processed headers and the rest a-list of unprocessed headers. -The clauses are of the form ((string key) . body). For each header in +The clauses are of the form ((key string) . body). For each header in the a-list, if a clause with a matching (string-equal) string form, which is evaluated, is found, then body is evaluated in an environment where the variables named via `header' and `value' are bound to the @@ -217,10 +218,8 @@ is appended to the list of unprocessed headers." x (cons x nil))) clauses) - for string = (string (if (consp clause) (car clause) clause)) - for key = (if (and (consp clause) (cadr clause)) - (cadr clause) - (intern (string-upcase string) "KEYWORD")) + for string = (string (if (consp clause) (cadr clause) clause)) + for key = (if (consp clause) (car clause) clause) collect `((string-equal ,header ,string) (list ,key (progn ,value ,@body)))))) `(loop for (,header . ,value) in ,headers diff --git a/src/main/parsing.cl b/src/main/parsing.cl index 6d063da..22c9183 100644 --- a/src/main/parsing.cl +++ b/src/main/parsing.cl @@ -232,3 +232,20 @@ the list of values. All other entries are kept." (cons value (cdr entry)) (list value (cdr entry)))) (push (cons key value) result)))) + +;;; HTML escaping for error messages. + +;;; This is especially important to avoid cross-scripting client +;;; attacks through our server. + +(defun escape-text-for-html (text) + (declare (type simple-string text)) + (with-output-to-string (stream) + (loop for char of-type character across text + do + (case char + (#\< (write-string "<" stream)) + (#\> (write-string ">" stream)) + (#\& (write-string "&" stream)) + (#\" (write-string """ stream)) + (t (write-char char stream)))))) diff --git a/src/main/server.cl b/src/main/server.cl index f80698c..b8986cd 100644 --- a/src/main/server.cl +++ b/src/main/server.cl @@ -92,7 +92,8 @@ passed to `make-instance'.")) (:documentation "Forward the calculated response object to the connection.")) - +(defgeneric get-error-response-class-using-server (server connection condition) + (:documentation "Calculate the response class for the error response.")) (defgeneric handle-server-error (server connection condition) (:documentation @@ -160,6 +161,13 @@ Server Response-Header.")) :status-code status-code args)) +(defmethod get-error-response-class-using-server (server connection condition) + (declare (ignore condition)) + (let ((last-request (connection-last-request connection))) + (if last-request + (get-response-class-using-server server last-request) + (find-class 'response/0.9)))) + ;;; Basic 0.9 server (defclass http-server/0.9 (simple-http-server) @@ -180,16 +188,18 @@ Server Response-Header.")) (defmethod handle-server-error ((server http-server/0.9) connection condition) (ignore-errors - (let ((response (make-instance - 'response/0.9 - :server server - :status-code - +HTTP-Code-Internal-Server-Error+ - :entity - (make-instance 'string-entity - :body - (format nil - "~%~%500 Internal Server Error~%~%~%

Internal Server Error

~%

An internal server error occured:

~%
~%~A~%
~%" condition))))) + (let ((response + (make-instance + (get-error-response-using-server server connection condition) + :server server + :status-code +HTTP-Code-Internal-Server-Error+ + :entity + (make-instance 'string-entity + :body + (format nil + "~%~%500 Internal Server Error~%~%~%

Internal Server Error

~%

An internal server error occured:

~%
~%~A~%
~%" + (escape-text-for-html + (princ-to-string condition))))))) (write-response server connection response))) (throw 'exit-connection nil)) @@ -228,7 +238,8 @@ Server Response-Header.")) (typecase condition (clash-error (apply #'make-instance - 'response/1.0 + (get-error-response-class-using-server + server connection condition) :server server :status-code (clash-error-code condition) :entity @@ -237,20 +248,24 @@ Server Response-Header.")) :body (format nil "~%~%~3D ~A~%~%~%

~2:*~3D ~A

~%
~%~A~%
~%" (clash-error-code condition) - (HTTP-Code-Description (clash-error-code condition)) - condition) + (HTTP-Code-Description + (clash-error-code condition)) + (escape-text-for-html + (princ-to-string condition))) (clash-error-entity-initargs condition)) (clash-error-response-initargs condition))) (error (make-instance - 'response/1.0 + (get-error-response-class-using-server + server connection condition) :server server - :status-code - +HTTP-Code-Internal-Server-Error+ + :status-code +HTTP-Code-Internal-Server-Error+ :entity (make-instance 'string-entity :body (format nil - "~%~%500 Internal Server Error~%~%~%

Internal Server Error

~%

An internal server error occured:

~%
~%~A~%
~%" condition))))))) + "~%~%500 Internal Server Error~%~%~%

Internal Server Error

~%

An internal server error occured:

~%
~%~A~%
~%" + (escape-text-for-html + (princ-to-string condition))))))))) (write-response server connection response))) (throw 'exit-connection nil))