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

@@ -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))
 

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

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 "&lt;" stream))
+	    (#\> (write-string "&gt;" stream))
+	    (#\& (write-string "&amp;" stream))
+	    (#\" (write-string "&quot;" stream))
+	    (t (write-char char stream))))))

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
-					    "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>" 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
+				   "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>"
+				   (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 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>~3D ~A</TITLE>~%</HEAD>~%<BODY>~%<H1>~2:*~3D ~A</H1>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>"
 				    (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
-				      "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>" condition)))))))
+				      "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">~%<HTML><HEAD>~%<TITLE>500 Internal Server Error</TITLE>~%</HEAD>~%<BODY>~%<H1>Internal Server Error</H1>~%<P>An internal server error occured:</P>~%<PRE>~%~A~%</PRE>~%</BODY></HTML>"
+				      (escape-text-for-html
+				       (princ-to-string condition)))))))))
       (write-response server connection response)))
   (throw 'exit-connection nil))