- Add debugging notification
authorMatthew Mondor <mmondor@pulsar-zone.net>
Tue, 30 Aug 2011 01:23:59 +0000 (01:23 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Tue, 30 Aug 2011 01:23:59 +0000 (01:23 +0000)
- Use the new ECL sequence streams and implement a working URL decoder

mmsoftware/cl/server/test-httpd.lisp

index 4be28ed..9163b0c 100644 (file)
@@ -1,4 +1,4 @@
-;;;; $Id: test-httpd.lisp,v 1.10 2011/08/28 00:56:42 mmondor Exp $
+;;;; $Id: test-httpd.lisp,v 1.11 2011/08/30 01:23:59 mmondor Exp $
 ;;;;
 ;;;; Test/exemple minimal HTTP server
 ;;;;
 (in-package :httpd)
 
 (defparameter *rcsid*
-  "$Id: test-httpd.lisp,v 1.10 2011/08/28 00:56:42 mmondor Exp $")
+  "$Id: test-httpd.lisp,v 1.11 2011/08/30 01:23:59 mmondor Exp $")
 
 
 (defparameter *request-timeout* 60)
 (defparameter *request-max-size* 4096)
+(defvar *vhost-default* nil)
 
 
 (defstruct vhost
@@ -32,7 +33,6 @@
 
 (defvar *vhosts* (make-hash-table :test #'equal))
 (defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
-(defvar *vhost-default* nil)
 
 (defun vhost-register (&key
                       (name "")
                 (svref parts 1) "/" (svref parts 3))))
 
 
-;;; XXX We have a problem: Say we unescape UTF-8 characters, they still
-;;; consist of bytes which we should convert back to actual UTF-8 characters
-;;; in the case of UTF-8 EXTERNAL-FORMAT...  Which means that ideally, we
-;;; should write/decode the string to bytes, escape it then read/reencode
-;;; the result.  Perhaps that there's a way using READ-BYTE/WRITE-BYTE?
-;;; Given STRING is % HEX HEX encoded, decode it while also returning
-;;; a string of characters according to EXTERNAL-FORMAT.
-;;; For current tests and to continue development immediately, assume
-;;; LATIN-1 only.
+;;; URL Decoding
+
+(defun utf-8-string-encode (string)
+  (let ((v (make-array (+ 5 (length string)) ; Best case but we might grow
+                      :element-type '(unsigned-byte 8)
+                      :adjustable t
+                      :fill-pointer 0)))
+    (with-open-stream (s (ext:make-sequence-output-stream
+                         v :external-format :utf-8))
+      (loop
+        for c across string
+        do
+          (write-char c s)
+          (let ((d (array-dimension v 0)))
+            (when (< (- d (fill-pointer v)) 5)
+              (adjust-array v (* 2 d))))))
+    v))
+
+(defun utf-8-string-decode (bytes)
+  (macrolet ((add-char (c)
+              `(vector-push-extend ,c string 1024)))
+    (with-open-stream (s (ext:make-sequence-input-stream
+                         bytes :external-format :utf-8))
+      (loop
+        with string = (make-array 1024
+                                  :element-type 'character
+                                  :adjustable t
+                                  :fill-pointer 0)
+        for c of-type character =
+          (handler-bind
+              ((ext:stream-decoding-error
+                #'(lambda (e)
+                    (mapc #'(lambda (o)
+                              ;; Assume LATIN-1 and import
+                              (add-char (code-char o)))
+                          (ext:character-decoding-error-octets e))
+                    (invoke-restart 'continue)))
+               (end-of-file
+                #'(lambda (e)
+                    (declare (ignore e))
+                    (loop-finish))))
+            (read-char s))
+        do (add-char c)
+        finally (return string)))))
+
 (defun url-decode (string)
-  (with-output-to-string (out)
-    (with-input-from-string (in string)
-      (handler-case
-         (loop
-            for c of-type character = (read-char in)
-            when (char= #\% c)
-            do (let ((c1 (read-char in))
-                     (c2 (read-char in)))
-                 (when (and (digit-char-p c1 16)
-                            (digit-char-p c2 16))
-                   (write-char (code-char
-                                (parse-integer
-                                 (map 'string #'identity `(,c1 ,c2))
-                                 :radix 16))
-                               out)))
-            else
-            when (char= #\+ c)
-            do (write-char #\Space out)
-            else
-            do (write-char c out))
-       (end-of-file ()
-         nil)))))
+  (macrolet ((get-octet ()
+              `(if (= input-max input-pos)
+                   (loop-finish)
+                   (prog1
+                       (aref input input-pos)
+                     (the fixnum (incf (the fixnum input-pos))))))
+            (put-octet (o)
+              `(vector-push ,o output)))
+    (loop
+       with input = (utf-8-string-encode string)
+       with input-pos of-type fixnum = 0
+       with input-max of-type fixnum = (length input)
+       with output = (make-array (length input)
+                                :element-type '(unsigned-byte 8)
+                                :fill-pointer 0)
+       for o of-type '(unsigned-byte 8) = (get-octet)
+       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))))
+       else when (= 43 o) do (put-octet 32)
+       else do (put-octet o)
+       finally (return (utf-8-string-decode output)))))
+
 
 ;;; Supplied with a hash table and a string set statement in the form
 ;;; "variable=value" or "variable[]=value", add the association binding.
@@ -483,6 +524,12 @@ code message #\Return
 
 
 ;;; XXX Debugging
+(defun beep ()
+  (handler-case
+      (with-open-file (s "/dev/speaker" :direction :output)
+       (write-string "O1L15D" s))
+    (t ()
+      nil)))
 (defun dump-vars (ht)
   (with-output-to-string (out)
     (maphash #'(lambda (k v)
@@ -514,6 +561,7 @@ code message #\Return
 ;;; XXX Should dispatch requests to known resources as needed
 ;;; XXX Should probably display HTTP errors for unhandled Lisp conditions
 (defun http-serve (connection)
+  (beep)
   (let ((stream (connection-stream connection)))
     (multiple-value-bind (status lines)
        (http-request-read stream)