- The HTTP server name is now "Crow"
authorMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 14 Sep 2012 21:43:14 +0000 (21:43 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 14 Sep 2012 21:43:14 +0000 (21:43 +0000)
- Fix a DECLARE TYPE typo in HTTP-REPLY-LOG-TIME
- Optimize URL-ENCODE (~50 times faster), URL-DECODE

mmsoftware/cl/server/httpd.lisp

index 2936898..749e441 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: httpd.lisp,v 1.22 2012/09/13 13:00:50 mmondor Exp $
+;;;; $Id: httpd.lisp,v 1.23 2012/09/14 21:43:14 mmondor Exp $
 
 #|
 
@@ -120,13 +120,13 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (in-package :httpd)
 
 (defparameter *rcsid*
-  "$Id: httpd.lisp,v 1.22 2012/09/13 13:00:50 mmondor Exp $")
+  "$Id: httpd.lisp,v 1.23 2012/09/14 21:43:14 mmondor Exp $")
 
 (defparameter *server-version*
   (let ((parts (string-split *rcsid*
                             :separators '(#\Space #\,))))
     (concatenate 'string
-                (svref parts 1) "/" (svref parts 3))))
+                "Crow" "/0." (svref parts 3))))
 
 
 (defstruct (httpd-config (:conc-name config-))
@@ -169,8 +169,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   (let ((out (make-array (1+ (length path))
                         :element-type 'character
                         :fill-pointer 0)))
-    (macrolet ((add-char (c)
-                `(vector-push ,c out)))
+    (flet ((add-char (c)
+            (vector-push c out)))
+      (declare (inline add-char))
       (add-char #\/)
       (if
        (loop
@@ -505,7 +506,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (defun http-reply-log-time (&optional (ut (server-time)))
   (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
                  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
-    (declare (type (simply-array string (12)) months))
+    (declare (type (simple-array string (12)) months))
     (multiple-value-bind
          (second minute hour date month year)
        (decode-universal-time ut 0)
@@ -760,7 +761,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;; HTTP request parsing
 
 ;;; Decodes the URL supplied in STRING to another string, returning it.
+;;; Slightly slower than encoding, but needs to be resilient to bad input.
 (defun url-decode (string)
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
   (macrolet ((get-octet ()
               `(if (= input-max input-pos)
                    (loop-finish)
@@ -776,50 +779,99 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
        with output = (make-array (length input)
                                 :element-type '(unsigned-byte 8)
                                 :fill-pointer 0)
+       with byte-string = (make-string 2)
+
        for o of-type (unsigned-byte 8) = (get-octet)
+
+       ;; Below, (map 'string #'identity `(,c1 ,c2)) is slower
        when (= 37 o) do (let ((c1 (code-char (get-octet)))
                              (c2 (code-char (get-octet))))
                          (when (and (digit-char-p c1 16)
                                     (digit-char-p c2 16))
-                           (put-octet (parse-integer
-                                       (map 'string #'identity `(,c1 ,c2))
-                                       :radix 16))))
+                           (setf (char byte-string 0) c1
+                                 (char byte-string 1) c2)
+                           (put-octet (parse-integer byte-string
+                                                     :radix 16))))
        else when (= 43 o) do (put-octet 32)
        else do (put-octet o)
+
        finally (return (utf-8-string-decode output)))))
 
+#|
 (defvar *url-safe-char-table*
   (make-valid-character-table
    (character-intervals '(#\A #\Z)
                        '(#\a #\z)
                        '(#\0 #\9))))
-
 ;;; Encodes the supplied URL in STRING to another string, returning it.
 (defun url-encode (string)
-  (flet ((url-encode-char (c)
-          (if (character-valid-p *url-safe-char-table* c)
-              c
-              (reduce #'(lambda (a b)
-                          (concatenate 'string a b))
-                      (map 'list #'(lambda (o)
-                                     (format nil "%~2,'0X" o))
-                           (utf-8-string-encode (string c)))))))
-    (with-output-to-string (out)
-      (with-input-from-string (in string)
-       (loop
-          for c = (handler-case
-                      (read-char in)
-                    (end-of-file ()
-                      nil))
-          for toc = (if c (url-encode-char c) nil)
-          while toc
-          when (characterp toc) do (write-char toc out)
-          else do (write-string toc out))))))
+  (let ((url-safe-char-table *url-safe-char-table*))
+    (flet ((url-encode-char (c)
+            (if (character-valid-p url-safe-char-table c)
+                c
+                (reduce #'(lambda (a b)
+                            (concatenate 'string a b))
+                        (map 'list #'(lambda (o)
+                                       (format nil "%~2,'0X" o))
+                             (utf-8-string-encode (string c)))))))
+      (declare (inline url-encode-char))
+      (with-output-to-string (out)
+       (with-input-from-string (in string)
+         (loop
+            for c = (handler-case
+                        (read-char in)
+                      (end-of-file ()
+                        nil))
+            for toc = (if c (url-encode-char c) nil)
+            while toc
+            when (characterp toc) do (write-char toc out)
+            else do (write-string toc out)))))))
+|#
+
+;; This implementation is way faster than the above (~50.8 times!), albeit
+;; slightly less elegant.
+(defun url-encode (string)
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-output-to-string (out)
+    (loop
+       with nibbles of-type (simple-vector 16) =
+        #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)
+       with bytes of-type (vector unsigned-byte-8 *) =
+        (utf-8-string-encode string)
+       with out-string = (make-string 3)
+
+       for byte of-type unsigned-byte-8 across bytes
+       for char of-type character = (code-char byte)
+
+       ;; Unfortunately using CHAR<= below causes function calls.
+       ;; Same if using BYTE instead of CODE.
+       when (let ((code (char-code char)))
+             (declare (type fixnum code))
+             (or (<= (char-code #\A) code (char-code #\Z))
+                 (<= (char-code #\a) code (char-code #\z))
+                 (<= (char-code #\0) code (char-code #\9))))
+       do (write-char char out)
+
+       else
+       do
+       (let ((n1 (the fixnum (ash (the fixnum (logand (the fixnum byte)
+                                                     (the fixnum #Xf0)))
+                                 -4)))
+            (n2 (the fixnum (logand (the fixnum byte)
+                                    (the fixnum #X0f)))))
+        (declare (type fixnum n1 n2))
+        (setf (char out-string 0) #\%
+              (char out-string 1) (svref nibbles n1)
+              (char out-string 2) (svref nibbles n2))
+        (write-string out-string out)))))
+
 
 ;;; Supplied with a hash table and a string set statement in the form
 ;;; "variable=value" or "variable[]=value", add the association binding.
 ;;; If the variable name terminates with "[]", it denotes that the variable
 ;;; is an array, in which case multiple values may be accumulated into it.
+;;; XXX It appears that using a [] suffix is a PHP convention, and that we
+;;; could use another indicator, such as a # prefix.
 (defun property-set (ht str)
   (let ((parts (string-split str :separators '(#\=) :max 2)))
     (when (= (length parts) 2)
@@ -1931,6 +1983,9 @@ REQ is bound to VAR."
          (server::config-buffer server-config) 65536
          (server::config-log-connections server-config) (debug-feature
                                                          :log-connections))
+    (with-accessors ((ident server::config-log-syslog-ident)) server-config
+      (when (string= "ecl-mp-server" ident)
+       (setf ident "crow-httpd")))
     (server-init server-config)
     (setf *config* config
          *initialized* t))