tidy up the COMET so it uses a JavaScript watchdog, and make sure tha…

…t long requests can reuse the same HTTP connexion
vii · Sep 19, 2009 · d03a28a · d03a28a
1 parent 2243cfc
commit d03a28a
Show file tree

Hide file tree

Showing 17 changed files with 137 additions and 180 deletions.
diff --git a/src/blog/main.lisp b/src/blog/main.lisp
@@ -1,117 +0,0 @@
-(in-package #:tpd2.blog)
-
-(defvar *root-dir* "/home/john/Junk/mopoko/")
-(defvar *blog-dir* (strcat *root-dir* "/Blog/"))
-
-(datastore-use-file (strcat *root-dir* "tpd2-datastore.log.lisp"))
-
-(make-blog 
-
-(defun css ()
-  (let ((unimportant-color "#888888"))
-    (css-html-style
-      ((".inherit" <input <a)
-       :text-decoration "inherit" :color "inherit" :background-color "inherit" :font-size "inherit" :font-weight "inherit"
-       :font-family "inherit" 
-       :border "none" :padding "0 0 0 0" :margin "0 0 0 0")
-      (<body :font-family "verdana, sans-serif" :word-spacing "0.075em" :letter-spacing "0.010em" :color "black" :background-color "white")
-      ("p + p" :text-indent "1em")
-      ("p" :line-height "1.4em" :letter-spacing "0.007em" :word-spacing "0.0025em")
-      ((<h1 <h2 <h3 <h4 <h5 <h6) :letter-spacing "0.05em" :font-weight "normal" :margin "0 0 0 0" :padding "0 0 0 0")
-      ((<span <div <h1 <h2 <h3 <h4 <h5 <h6 <p <a <input) :direction "ltr" :unicode-bidi "bidi-override")
-      ("h2.estaircase" :text-align "right" :border-bottom "thin solid black" :margin-bottom "0.5em" :color unimportant-color)
-      (<h1 :font-size "3em")
-      (<h2 :font-size "2em")
-      (".blog-entry"
-       :margin-left "5%" :margin-right "5%"
-       :font-family "georgia, serif"
-       :x-column-width "20em"
-       :x-column-gap "2em")
-      ("input[type=text]" 
-       :display "inline"
-       :border-bottom "thin dashed black" 
-       :font-style "italic" )
-      (".robot" :font-style "italic")
-      ("[onclick],a,input[type=submit]" 
-       :cursor "pointer"
-       :color "blue")
-      ("p.time" 
-       :color unimportant-color))))
-
-
-(defrecord location
-    (time :initform (get-universal-time))
-  description 
-  latitude
-  longitude)
-
-(defrecord phone-contact
-    string)
-
-(my-defun location coordinates ()
-  (tpd2.io:with-sendbuf ()
-    (abs (my longitude))
-    (if (> 0 (my longitude)) "S"
-	"N")
-    (abs (my latitude))
-    (if (> 0 (my latitude)) "E"
-	"W")))
-
-(my-defun location 'object-to-ml ()
-  (<p :class "location"
-      (<a :href 
-	  (tpd2.io:sendbuf-to-byte-vector 
-	   (tpd2.io:with-sendbuf () "http://maps.google.com/?q="
-			 (tpd2.http:percent-hexpair-encode
-			  (if (my latitude)
-			      (tpd2.io:sendbuf-to-byte-vector (my coordinates))
-			      (my description)))))
-	  (my description)
-
-	  (when (my latitude)
-	    (<span :class "coordinates"
-		   (my coordinates))))
-      " as of " (time-string (my time)) "."))
-
-(my-defun phone-contact 'object-to-ml ()
-  (<p :class "phone-number" (my string)))
-
-
-(with-site (:dispatcher "127.0.0.1:8888"
-			:page-body-start 
-			(lambda(title)
-			  `(<div :class "header"
-				      (<h2 :class "estaircase" 
-					   (<A :href (page-link "/") 
-					       :class "inherit" "E Staircase"))
-				      (<h1 :class "title" ,title)))
-			:page-head (lambda(title)
-				     `(<head
-					(<title ,title)
-					(css)
-					(webapp-default-page-head-contents))))
-
-  (defpage "/" ()
-    (webapp "The E Staircase Blog"
-      (<p (<A :href (page-link "FAQ") "What is this?") " " 
-	  (<A :href (page-link "Location") "Where am I?") " " 
-	  (<a :href "http://john.fremlin.org" "Who am I?"))
-      (loop for i below 10
-	    for b in *blog-entries*
-	    do
-	    (output-object-to-ml b))))
-
-  (defpage "/FAQ" ()
-    (webapp "About the blog"
-      (<p "This blog is firstly to keep my family and friends updated about my travels, "
-	  "and secondly to disseminate information and ideas that deserve to be better known.")
-      (<p "It is named for E Staircase and the people there.")))
-
-  (defpage "/Location" ()
-    (webapp "Where I am"
-      (loop for l in (datastore-retrieve-all 'location 10) do
-	    (output-object-to-ml l))
-
-      (loop for l in (datastore-retrieve-all 'phone-contact 1) do
-	    (<h2 "What telephone number to call to talk to me")
-	    (output-object-to-ml l)))))

diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -195,7 +195,7 @@
 
 	(<div :class "talk"
 	      (html-action-form "Talk " 
-		  (text)
+		  ((text nil :reset ""))
 		(without-ml-output
 		  (game-talk (my game-state) me text))))))
 

diff --git a/src/http/dispatcher.lisp b/src/http/dispatcher.lisp
@@ -19,33 +19,34 @@
     body))
 
 
-(defun-speedy respond-http (con done &key (code (force-byte-vector 200)) (banner (force-byte-vector "OK"))
-		     headers body)
+(defun-speedy respond-http (con done &key (code #.(force-byte-vector 200)) (banner #.(force-byte-vector "OK"))
+		     (headers #.(byte-vector-cat "Content-Type: text/html;charset=utf-8" tpd2.io:+newline+)) body)
   (declare (type sendbuf body))
   (declare (dynamic-extent body))
   (send con done (build-http-response :code code :banner banner :headers headers :body body)))
 
-
 (my-defun dispatcher respond (con done path params)
   (let ((f (gethash path (my paths))))
     (handler-case 
 	(cond  
 	  (f
-	   (funcall f me con done path params))
+	   (locally (declare (optimize speed) (type function f))
+	    (funcall f me con done path params)
+	    (values)))
 	  (t
 	   ;(format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
-	   (respond-http con done :code  404 :banner  "Not found"
+	   (respond-http con done :code  404 :banner "Not found"
 			 :body (funcall (my error-responder) me path params))))
       (error (e)
-	(format *error-output* "ERROR ~A~&--- ~A~&" (strcat (my canonical-name) path) 
+	(format *error-output* "~&PAGE ERROR ~A~&--- ~A~&" (strcat (my canonical-name) path) 
 		(backtrace-description e))
 	(respond-http con done
 		      :body (with-sendbuf () "<h1>I programmed this thoughtlessly. Sorry for the inconvenience.</h1>")
 		      :code 500
 		      :banner "Internal error")))))
 
 (my-defun dispatcher register-path (path func)
-  (setf (gethash (force-byte-vector path) (my paths)) func))
+  (setf (gethash (force-byte-vector path) (my paths)) (alexandria:ensure-function func)))
 
 (my-defun dispatcher 'default-http-error-page (path params)
   (declare (ignore params path))
@@ -57,7 +58,7 @@
 (defvar *dispatchers* nil)
 
 (defun find-dispatcher-go (host)
-  (alist-get *dispatchers* host :test 'equalp))
+  (alist-get *dispatchers* host :test #'equalp))
 
 (defun find-dispatcher (host)
   (or (find-dispatcher-go host) *default-dispatcher*))

diff --git a/src/http/serve.lisp b/src/http/serve.lisp
@@ -44,6 +44,7 @@
 					     ("x-forwarded-for" 
 					      (setf request-origin
 						    (match-x-forwarded-for value)))))))
+	(declare (dynamic-extent #'handle-header))
        (match-bind (macrolet ((lws () `(or #\Space #\Tab))) 
 		     (progn
 		       method-tmp (+ (lws))

diff --git a/src/io/con.lisp b/src/io/con.lisp
@@ -1,5 +1,6 @@
 (in-package #:tpd2.io)
 
+(declaim (inline %make-con))
 (defstruct (con (:constructor %make-con))
   socket
   (peer-info nil :type (or null byte-vector))
@@ -22,15 +23,19 @@
     con))
 
 (my-defun con init ()
-  (unless (my err)
-    (my clear-failure-callbacks))
   (unless (my timeout)
-    (setf (my timeout) (make-timeout :func (lambda() (my fail 'timeout))))))
+    (setf (my timeout) (make-timeout :func (my default-timeout-function)))))
+
+(my-defun con default-timeout-function ()
+  (lambda() 
+    (my fail 'timeout)))
 
 (my-defun con fail (&optional (e (make-condition 'socket-explicitly-hungup)))
   (let ((c (my err)))
     (my clear-failure-callbacks)
-    (funcall c e))) 
+    (when c
+      (funcall c e)))
+  (my 'hangup))
 
 (defgeneric normal-connection-error (e))
 (defmethod normal-connection-error (e)
@@ -42,6 +47,10 @@
 (defmethod normal-connection-error ((e syscall-failed))
   t)
 
+(defun report-unless-normal-connection-error (e)
+  (unless (normal-connection-error e)
+    (report-error e)))
+
 (my-defun con run ()
   (restart-case
       (handler-bind ((error 
@@ -66,16 +75,14 @@
     (setf (my err) 
 	  (if old
 	      (lambda(e)
-		(funcall old e)
-		(funcall func e))
+		(funcall func e)
+		(funcall old e))
 	      func))
     (values)))
 
 (my-defun con clear-failure-callbacks ()
   (setf (my err) 
-	(lambda(err)
-	  (declare (ignore err))
-	  (my 'hangup))))
+	nil))
 
 (my-defun con 'recv (done amount)
   (declare (type fixnum amount))
@@ -136,13 +143,14 @@
      (r t)))
 
 (my-defun con 'send (done sendbuf)
+  (my-declare-fast-inline)
   (cond
     ((sendbuf-done sendbuf)
      (funcall done))
     (t
      (if (socket-supports-writev (my socket))
-	 (sendbuf-send-writev sendbuf me #'my-call)
-	 (sendbuf-send-write sendbuf me #'my-call)))))
+	 (sendbuf-send-writev sendbuf me done)
+	 (sendbuf-send-write sendbuf me done)))))
 
 (my-defun con 'accept (done)
   (acond 

diff --git a/src/io/epoll.lisp b/src/io/epoll.lisp
@@ -90,6 +90,7 @@
 	     (my ctl +EPOLL_CTL_ADD+ fd events))))))
 
 (defun deregister-fd (fd)
+  (declare (optimize speed))
   (with-shorthand-accessor (my epoll *epoll*)
     (my 'mux-del fd)))
 

diff --git a/src/io/mux.lisp b/src/io/mux.lisp
@@ -13,12 +13,14 @@
 
 (my-defun mux find-fd (fd)
   (my-declare-fast-inline)	  
+  (declare (type (or null fixnum) fd))
   (when fd
     (when (> (length (my fd-to-con)) fd)
       (aref (my fd-to-con) fd))))
 
 (my-defun mux add (con)
   (let ((fd (con-socket con)))
+    (declare (type (or null fixnum) fd))
     (when fd
       (debug-assert (not (my find-fd fd)))
       (when (>= fd (length (my fd-to-con)))
@@ -31,6 +33,8 @@
       (setf (aref (my fd-to-con) fd) con))))
 
 (my-defun mux del (fd)
+  (my-declare-fast-inline)
+  (declare (fixnum fd))
   (when (my find-fd fd)
     (debug-assert (= (con-socket (aref (my fd-to-con) fd)) fd))
     (setf (aref (my fd-to-con) fd) nil)))

diff --git a/src/io/posix-socket.lisp b/src/io/posix-socket.lisp
@@ -48,9 +48,10 @@
 	(case-= s
 		(-1 nil)
 		(t
+;		 (socket-set-tcp-nodelay s)
+;		 (socket-cork s)
 		 #-tpd2-untransformed-io
 		 (set-fd-nonblock s)
-		 (socket-set-tcp-nodelay s)
 		 (make-con 
 		  :socket s
 		  :peer-info (sockaddr-address-bv sa))))))))

diff --git a/src/io/sendbuf.lisp b/src/io/sendbuf.lisp
@@ -152,8 +152,10 @@
   (my check-done con done #'my-call))
 
 (my-defun sendbuf send-writev (con done)
+  (my-declare-fast-inline)
   (unless (my done)
     (let ((count (min +max-iovecs+ (my num-bufs))))
+      (declare (type (integer 0 #.+max-iovecs+) count))
       (cffi:with-foreign-object (vecs 'iovec count)
 	(loop for i below count
 		  for buf of-type simple-byte-vector in (my head)

diff --git a/src/io/syscalls.lisp b/src/io/syscalls.lisp
@@ -458,17 +458,10 @@
 
 
 (defun socket-cork (fd)
-  (declare (ignore fd)))
-(defun socket-uncork (fd)
-  (declare (ignore fd)))
-
-#+really-do-some-sort-of-socket-corking
-(progn
-  (defun socket-cork (fd)
-    (setsockopt-int fd +IPPROTO_TCP+ +TCP_CORK+ 1))
+  (setsockopt-int fd +IPPROTO_TCP+ +TCP_CORK+ 1))
 
-  (defun socket-uncork (fd)
-    (setsockopt-int fd +IPPROTO_TCP+ +TCP_CORK+ 0)))
+(defun socket-uncork (fd)
+  (setsockopt-int fd +IPPROTO_TCP+ +TCP_CORK+ 0))
 
 
 (defun socket-set-tcp-nodelay (fd)
@@ -591,7 +584,7 @@
 
 (alexandria:define-constant +octet-to-bv+
     (make-array 256 :element-type 'simple-byte-vector 
-		:initial-contents (loop for i from 0 below 256 collect (force-byte-vector (format nil "~3,'0D" i))))
+		:initial-contents (mapcar 'force-simple-byte-vector (loop for i from 0 below 256 collect (format nil "~3,'0D" i))))
   :test 'equalp)
 
 (defun-speedy bv-from-address (addr)

diff --git a/src/lib/timeout.lisp b/src/lib/timeout.lisp
@@ -3,6 +3,7 @@
 (defvar *timeouts* (make-quick-queue))
 (defvar *timeout-started* nil)
 
+(declaim (inline %make-timeout-internal))
 (defstruct (timeout (:include quick-queue-entry) (:constructor %make-timeout-internal))
   (time nil :type (or null integer))
   func)

diff --git a/src/lib/utils.lisp b/src/lib/utils.lisp
@@ -48,6 +48,23 @@
 (defun read-safely-from-string (string)
   (with-input-from-string (*standard-input* (force-string string)) (read-safely)))
 
-(defun backtrace-description (err)
-  (format nil "ERROR ~A:~&~A" (with-output-to-string (*standard-output*) (describe err)) 
+(defun report-error (err &key (stream *error-output*))
+  (format stream "~&ERROR ~A, ~A:~%~A~&" 
+	  (ignore-errors (princ-to-string err))
+	  (with-output-to-string (*standard-output*) (describe err)) 
 	  (trivial-backtrace:backtrace-string)))
+
+(defun backtrace-description (err)
+  (report-error err :stream nil))
+
+(defmacro with-ignored-errors ((&optional (report-function ''backtrace-description) ) &body body)
+  (with-unique-names (safe func)
+    `(block ,safe
+       (flet ((,func (e)
+		(,report-function e)
+		(return-from ,safe (values nil e))))
+	 (declare (dynamic-extent #',func))
+	 (handler-bind 
+	     ((error #',func))
+	   ,@body)))))
+