- Fix a bug where if multiple content strings were added to an HTTP-REPLY
authorMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 2 Sep 2011 22:34:02 +0000 (22:34 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 2 Sep 2011 22:34:02 +0000 (22:34 +0000)
  object they would be flushed in reverse-order.  This did not occur,
  because the code currently doesn't add more than one string.
- Minor cleanups

mmsoftware/cl/server/test-httpd.lisp

index 0c2086b..33969e1 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: test-httpd.lisp,v 1.22 2011/09/02 13:53:05 mmondor Exp $
+;;;; $Id: test-httpd.lisp,v 1.23 2011/09/02 22:34:02 mmondor Exp $
 
 #|
 
@@ -32,6 +32,10 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;; XXX TODO XXX
 ;;;; - Maybe cleanup all those HTTP-ERROR followed by RETURN-FROM cases
 ;;;;   where HTTP-ERROR could signal a condition instead.
+;;;;   In fact, HTTP-REPLY-FLUSH should probably be the point signalling
+;;;;   the condition, so that we may return to the main loop (in case
+;;;;   if Keep-Alive, it'd read for a new request, or would close
+;;;;   otherwise).
 ;;;; - Perhaps make the interface to HTTP-REPLY, HTTP-REPLY-SEND and
 ;;;;   HTTP-ERROR better so that user code doesn't always have to carry
 ;;;;   and care about STREAM, etc.  *CONNECTION* already holds it...
@@ -64,7 +68,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (in-package :httpd)
 
 (defparameter *rcsid*
-  "$Id: test-httpd.lisp,v 1.22 2011/09/02 13:53:05 mmondor Exp $")
+  "$Id: test-httpd.lisp,v 1.23 2011/09/02 22:34:02 mmondor Exp $")
 
 (defparameter *server-version*
   (let ((parts (string-split *rcsid*
@@ -419,7 +423,8 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
         stream)))
     (unless size
       (loop
-        for s in content
+        with rcontent = (reverse content)
+        for s in rcontent
         do (write-string s stream)))
     (finish-output stream))
   t)
@@ -648,13 +653,14 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   agent
   referer
   (keep-alive 0)
-  (connection "close" :type string)
+  (connection "close")
   content-type
   (content-length -1 :type integer)
   modified-since
   unmodified-since
   range)
 
+;;; XXX Also generate hash table and compare performance
 ;;; List of headers we care about and functions to fill them.
 ;;; CLOS could have been used instead after interning a keyword symbol
 ;;; from the header variable string, but that would probably be slower.
@@ -749,23 +755,22 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 ;;; Used to parse the HTTP version
 (defun parse-float (string)
-  (block nil
-    (when (char= #\. (char string 0))
-      (setf string (concatenate 'string "0" string)))
-    (let ((w (string-split string :separators '(#\.) :max 2)))
-      (unless (= 2 (length w))
-       (return nil))
-      (let ((i1 (handler-case
-                   (parse-integer (aref w 0))
-                 (t ()
-                   nil)))
-           (i2 (handler-case
-                   (parse-integer (aref w 1))
-                 (t ()
-                   nil))))
-       (unless (and i1 i2)
-         (return nil))
-       (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))))))
+  (when (char= #\. (char string 0))
+    (setf string (concatenate 'string "0" string)))
+  (let ((w (string-split string :separators '(#\.) :max 2)))
+    (if (= 2 (length w))
+       (let ((i1 (handler-case
+                     (parse-integer (aref w 0))
+                   (t ()
+                     nil)))
+             (i2 (handler-case
+                     (parse-integer (aref w 1))
+                   (t ()
+                     nil))))
+         (if (and i1 i2)
+             (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))
+             nil))
+       nil)))
 
 ;;; Parse supplied HTTP version STRING, returning NIL on error or
 ;;; a floating point representing the number.
@@ -786,15 +791,16 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
       (setf (http-request-raw req) lines)
 
       ;; Request method/path/protocol
-      (let ((words (string-split request :max 4)))
-       (cond ((< (length words) 3)
+      (let* ((words (string-split request :max 4))
+            (nwords (length words)))
+       (cond ((< nwords 3)
               (setf (http-request-method req) (method-keyword
                                                (svref words 0))
                     (http-request-path req) (if (= 2 (length words))
                                                 (svref words 1)
                                                 "/")
                     valid t))
-             ((= 3 (length words))
+             ((= 3 nwords)
               (setf (http-request-protocol req) (version-parse
                                                  (svref words 2))
                     (http-request-method req) (method-keyword
@@ -1055,6 +1061,11 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (defun http-dynamic-dispatch (req connection path)
 
+  ;;; XXX Perform some sanity checking
+  ;;; - Only allow GET/POST for HTTP < 1.0
+  ;;; - For >= 1.0 verify what is handled by user methods, but
+  ;;;   also only allow 1.1 supported methods.
+
   (when (debug-feature :test)
     (when (string= "/test" (path-virtual path))
       (html-test-page req connection)
@@ -1161,6 +1172,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
             while (= seqsize len))
          (finish-output stream))))))
 
+;;; Actual entry point from SERVER
 (defun http-serve (connection)
   (when (debug-feature :beep)
     (beep))
@@ -1218,8 +1230,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
        (unless (http-dynamic-dispatch req connection path)
          (http-static-dispatch req connection path))))))
 
-
-;;; Function called to serve exceeded connections.
+;;; Second entry point from SERVER to handle errors
 (defun http-overflow (connection reason)
   (declare (ignore reason))
   (let ((stream (connection-stream connection)))
@@ -1227,6 +1238,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
        "Connection limit exceeded for your address.  Try again later.")))
 
 
+
+;;; Test
+
 (defun httpd-init ()
   (vhost-register :name "gw.pulsar-zone.net"
                  :aliases '("behemoth.xisop" "localhost")