misc portability fixes

vii · Sep 21, 2008 · 90026a5 · 90026a5
1 parent e1d8483
commit 90026a5
Show file tree

Hide file tree

Showing 12 changed files with 83 additions and 32 deletions.
diff --git a/src/http/dispatcher.lisp b/src/http/dispatcher.lisp
@@ -30,7 +30,7 @@
 	  (f
 	   (funcall f me con done path params))
 	  (t
-	   (format *error-output* "LOST ~A~&--- ~A~&" (strcat (my canonical-name) "/" path))
+	   (format *error-output* "LOST ~A~&" (strcat (my canonical-name) "/" path))
 	   (respond-http con done :code  404 :banner  "Not found"
 			 :body (funcall (my error-responder) me path params))))
       (error (e)

diff --git a/src/http/request.lisp b/src/http/request.lisp
@@ -67,10 +67,9 @@
 
 
 (defun http-connection-cache-timeout ()
-  55)
+  25)
 
 (defun add-to-connection-cache (con key)
-  (reset-timeout con (http-connection-cache-timeout))
   (con-clear-failure-callbacks con)
   (unless (con-dead? con)
     (con-when-ready-to-read con (lambda() (con-fail con))) 
@@ -79,8 +78,10 @@
 				(declare (ignore args))
 				(debug-assert (member con (gethash key *connection-cache*)))
 				(deletef con (gethash key *connection-cache*))))
+    (reset-timeout con (http-connection-cache-timeout))
     (push con (gethash key *connection-cache*))))
 
+#+tpd2-http-no-connection-cache
 (defun add-to-connection-cache (con key)
   (declare (ignore key))
   (con-clear-failure-callbacks con)
@@ -92,7 +93,11 @@
 	   (con-clear-failure-callbacks con)
 	   (reset-timeout con)
 	   (debug-assert (not (con-dead? con)))
-	   con)
+	   (cond ((con-connected? con)
+		  con)
+		 (t
+		  (hangup con)
+		  (get-http-request-con address port))))
 	  (t
 	   (make-con-connect :address address :port port)))))
 

diff --git a/src/http/serve.lisp b/src/http/serve.lisp
@@ -30,7 +30,6 @@
 				      ("keep-alive" (setf connection-close nil))) ))
 		       value))))))
 	(io 'process-headers con #'process-header))
-
       (let ((request-body
 	     (unless (zerop request-content-length)
 	       (io 'recv con request-content-length))))

diff --git a/src/io/con.lisp b/src/io/con.lisp
@@ -23,7 +23,7 @@
   (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 (lambda() (my fail 'timeout))))))
 
 (my-defun con fail (&optional (e (make-condition 'socket-explicitly-hungup)))
   (let ((c (my err)))
@@ -192,3 +192,6 @@
 
 (my-defun con dead? ()
   (not (my socket)))
+
+(my-defun con connected? ()
+  (not (not (socket-peer (my socket)))))
diff --git a/src/io/posix-socket.lisp b/src/io/posix-socket.lisp
@@ -90,3 +90,12 @@
     (case-= s
 	    (-1 nil)
 	    (t s))))
+
+
+(defmethod socket-peer ((fd integer))
+  (cffi:with-foreign-object (sa 'sockaddr_in)
+    (cffi:with-foreign-object (len :int)
+      (setf (cffi:mem-aref len :int) (cffi:foreign-type-size 'sockaddr_in))
+      (when (zerop (getpeername fd sa len))
+	(sockaddr-address-string sa)))))
+
diff --git a/src/io/sendbuf.lisp b/src/io/sendbuf.lisp
@@ -97,7 +97,7 @@
     (let ((count (min +max-iovecs+ (my num-bufs))))
       (cffi:with-foreign-object (vecs 'iovec count)
 	(loop for i below count
-	      for buf in (my head)
+		  for buf in (my head)
 	      do 
 	      (with-pointer-to-vector-data (ptr buf)
 		(cffi:with-foreign-slots ((base len) (cffi:mem-aref vecs 'iovec i) iovec)

diff --git a/src/io/socket.lisp b/src/io/socket.lisp
@@ -32,3 +32,8 @@
 (defmethod socket-sendto (socket address buf)
   (declare (ignore address))
   (socket-write socket buf))
+
+(defgeneric socket-peer (socket))
+
+(defmethod socket-peer ((socket null))
+  (declare (ignore socket)))
diff --git a/src/io/syscalls.lisp b/src/io/syscalls.lisp
@@ -1,5 +1,11 @@
 (in-package #:tpd2.io)
 
+(eval-always
+  #+linux (pushnew :tpd2-linux *features*)
+  #+CLC-OS-DEBIAN (pushnew :tpd2-linux *features*)
+  #+freebsd (pushnew :tpd2-freebsd *features*))
+
+
 ;;; A simple syscall is one which returns -1 on error and sticks the
 ;;; error in *errno* (of course, this is just the glibc interface to
 ;;; the syscall).
@@ -13,7 +19,7 @@
   `(defconstant ,symbol ,number
     ,description))
 
-#+linux
+#+tpd2-linux
 (progn
   (syscall-error-number +EPERM+  1 "Operation not permitted")
   (syscall-error-number +ENOENT+  2 "No such file or directory")
@@ -51,19 +57,19 @@
   (syscall-error-number +ERANGE+ 34 "Math result not representable")
   (syscall-error-number +EINPROGRESS+ 115 "Operation now in progress"))
 
-#+freebsd
+#+tpd2-freebsd
 (progn
   (syscall-error-number +EAGAIN+ 35 "Try again")
   (syscall-error-number +EINTR+  4 "Interrupted system call")
   (syscall-error-number +EINPROGRESS+ 36 "Operation now in progress"))
 
-#+linux
+#+tpd2-linux
 (cffi:defcstruct (sockaddr_in :size 16)
   (family :uint16)
   (port :uint16)
   (addr :uint32))
 
-#+freebsd
+#+tpd2-freebsd
 (cffi:defcstruct (sockaddr_in :size 16)
   (len :uint8)
   (family :uint8)
@@ -362,7 +368,7 @@
   (dst :pointer)
   (cnt :int))
 
-#+linux
+#+tpd2-linux
 (cffi:defcstruct addrinfo
   (flags :int)
   (family :int)
@@ -373,7 +379,7 @@
   (canonname :string)
   (next :pointer))
 
-#+freebsd
+#+tpd2-freebsd
 (cffi:defcstruct addrinfo
   (flags :int)
   (family :int)
@@ -428,7 +434,7 @@
 		       str-size)
       (error "Cannot convert address: ~A" (strerror +syscall-error-number+)))))
 
-#+mopoko-old-sockaddr-address-string
+#+tpd2-old-sockaddr-address-string
 (defun sockaddr-address-string (sa)
   (declare (optimize speed))
   (let ((addr (cffi:foreign-slot-value sa 'sockaddr_in 'addr)))
@@ -562,3 +568,9 @@
   (data epoll-data :offset 4))
 
 (assert (= (cffi:foreign-type-size 'tpd2.io::epoll-event) 12))
+
+(cffi:defcfun getpeername
+    :int
+  (fd :int)
+  (sockaddr :pointer)
+  (socklen :pointer))
diff --git a/src/lib/one-liners.lisp b/src/lib/one-liners.lisp
@@ -74,13 +74,19 @@
   `(locally ,@body))
 
 (defmacro debug-assert (&rest args)
+  `(progn
+     ,(first args)
+     (values))
+
+  #+tpd2-debug-assert
   (with-unique-names (block)
     `(without-call/cc
        (block ,block
 	 (restart-case (assert ,@args)
 	   (debug-assert-skip ()
 	     :report "Accept that the assertion will fail this time and continue"
-	     (return-from ,block 'debug-assert-skip)))))))
+	     (return-from ,block 'debug-assert-skip)))
+	 (values)))))
 
 (defmacro debug-unreachable ()
   `(debug-assert (not 'reached-here)))
diff --git a/src/lib/utils.lisp b/src/lib/utils.lisp
@@ -79,14 +79,15 @@
 
 
 
-
-(let ((v (make-byte-vector 10)) q)
-  (with-pointer-to-vector-data (p v)
-    (setf q p))
-  (with-pointer-to-vector-data (p0 v)
-    (with-pointer-to-vector-data (p1 v)
-      (when (and (cffi:pointer-eq p0 p1) (cffi:pointer-eq p0 q))
-	(pushnew :tpd2-byte-vectors-do-not-move-arbitrarily *features*)))))
+#-ccl
+(ignore-errors
+  (let ((v (make-byte-vector 10)) q)
+    (with-pointer-to-vector-data (p v)
+      (setf q p))
+    (with-pointer-to-vector-data (p0 v)
+      (with-pointer-to-vector-data (p1 v)
+	(when (and (cffi:pointer-eq p0 p1) (cffi:pointer-eq p0 q))
+	  (pushnew :tpd2-byte-vectors-do-not-move-arbitrarily *features*))))))
 
 
 
@@ -112,4 +113,5 @@
   (with-input-from-string (*standard-input* (force-string string)) (read-safely)))
 
 (defun backtrace-description (err)
-  (hunchentoot:get-backtrace err))
+  (format nil "ERROR ~A:~&~A" (with-output-to-string (*standard-output*) (describe err)) 
+	  (hunchentoot:get-backtrace err)))
diff --git a/src/packages.lisp b/src/packages.lisp
@@ -167,6 +167,7 @@
    #:make-con-listen
    #:make-con-bind
    #:con-dead?
+   #:con-connected?
    #:con-fail
    #:con-add-failure-callback
    #:con-clear-failure-callbacks
@@ -326,11 +327,9 @@
    #:defrecord
    #:datastore-use-file))
 
-(defpackage #:teepeedee2.sutp
-  (:nicknames #:tpd2.sutp)
-  (:use #:common-lisp #:teepeedee2.lib #:teepeedee2.io)
-  (:export
-   #:make-socket))
+(defpackage #:teepeedee2.munnel
+  (:nicknames #:tpd2.munnel)
+  (:use #:common-lisp #:teepeedee2.lib #:teepeedee2.io))
 
 (defpackage #:teepeedee2.blog
   (:nicknames #:tpd2.blog)

diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -2,14 +2,25 @@
   (:use #:cl))
 (cl:in-package #:teepeedee2.system)
 
-(loop for addon in #+openmcl (directory "addons/*" :directories t)
-      #-openmcl (directory "addons/*/") 
+#.(progn
+    (asdf:operate 'asdf:load-op 'cl-fad)
+    nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (asdf:operate 'asdf:load-op 'cl-fad))
+
+(loop for addon in (remove-if-not 'cl-fad:directory-pathname-p (cl-fad:list-directory "addons"))
       do
       (pushnew addon asdf:*central-registry* :test #'equal))
 
 (pushnew "../cl-irregsexp/" asdf:*central-registry* :test #'equal)
 
-(proclaim '(optimize debug))
+#+comment-out
+(progn
+  (proclaim '(optimize debug))
+  (pushnew :tpd2-debug-assert *features*))
+
+(proclaim '(optimize speed))
 
 (asdf:defsystem :teepeedee2
   :name "teepeedee2"