checkpoint

ChangeLog

@@ -1,3 +1,15 @@
+2000-06-25  jkf  <jkf@main.verada.com>
+
+	* keep track all of all ip addresses by which the server
+	  is contacted (this is simpler than trying to figure them
+	  out in advance).
+	* add function to find a response object given the code.
+	* keep track of the raw uri by which a request was made
+	  (as distinguished from the uri in which we've added the
+	  host and port values).  This is necessary to distriguish
+	  when we must proxy.
+	* in html-print assume that attribute values are already html escaped
+
 2000-06-12  John Foderaro  <jkf@tiger.franz.com>
 
 	* main.cl: add utility function request-query-value to

htmlgen/htmlgen.cl

@@ -24,7 +24,7 @@
 ;;
 
 ;;
-;; $Id: htmlgen.cl,v 1.7 2000/05/16 14:01:26 jkf Exp $
+;; $Id: htmlgen.cl,v 1.8 2000/06/26 04:51:34 jkf Exp $
 
 ;; Description:
 ;;   html generator
@@ -348,9 +348,9 @@
 	then (format stream "<~a" (html-process-key ent))
 	     (do ((xx args (cddr xx)))
 		 ((null xx))
-	       (format stream " ~a=\"" (car xx))
-	       (emit-safe stream (format nil "~a" (cadr xx)))
-	       (format stream "\""))
+	       ; assume that the arg is already escaped since we read it
+	       ; from the parser
+	       (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
 	     (format stream ">")
 	else (format stream "<~a>" (html-process-key ent)))
      (dolist (ff (cdr form))

log.cl

@@ -23,7 +23,7 @@
 ;; Suite 330, Boston, MA  02111-1307  USA
 ;;
 ;;
-;; $Id: log.cl,v 1.10 2000/06/10 19:06:41 jkf Exp $
+;; $Id: log.cl,v 1.11 2000/06/26 04:51:34 jkf Exp $
 
 ;; Description:
 ;;   iserve's logging
@@ -74,7 +74,7 @@
 	    (format stream
 		    "~a - - [~a] ~s ~s ~s~%"
 		    (socket:ipaddr-to-dotted ipaddr)
-		    (universal-time-to-date time)
+		    (maybe-universal-time-to-date time)
 		    (request-raw-request req)
 		    code
 		    (or length -1)))))

main.cl

@@ -23,7 +23,7 @@
 ;; Suite 330, Boston, MA  02111-1307  USA
 ;;
 ;;
-;; $Id: main.cl,v 1.45 2000/06/12 21:53:03 jkf Exp $
+;; $Id: main.cl,v 1.46 2000/06/26 04:51:34 jkf Exp $
 
 ;; Description:
 ;;   aserve's main loop
@@ -76,6 +76,7 @@
    #:request-query
    #:request-query-value
    #:request-raw-request
+   #:request-raw-uri
    #:request-socket
    #:request-uri
    #:request-wserver
@@ -314,7 +315,12 @@
     ;; entity to invoke given a request that was denied
     :initform nil  ; will build on demand if not present
     :accessor wserver-denied-request)
-   ))
+
+   (ipaddrs
+    ;; list of the ip addresses by which this wserver has been contacted
+    :initform nil
+    :accessor wserver-ipaddrs
+   )))
 
 
 
@@ -437,7 +443,11 @@
 			"content-type"
 			"content-length"))
 	  (push (list name   ;; string name
-		      (read-from-string name) ;; symbol name
+
+		      ;; symbol naming slot
+		      (read-from-string 
+		       (concatenate 'string (symbol-name :reply-) name))
+
 		      ;; accessor name
 		      (read-from-string 
 			    (format nil "request-reply-~a" name))) res))
@@ -548,10 +558,15 @@
     :initarg :method
     :reader request-method)
 
-   (uri  ;; uri object holding the current request
+   (uri  ;; uri object holding the current request with the scheme, host
+         ;; and port filled in.
     :initarg :uri
-    :reader request-uri)
+    :accessor request-uri)
 
+   (raw-uri  ;; uri object holding the actual uri from the command
+    :initarg :raw-uri
+    :accessor request-raw-uri)
+
    (protocol ;; symbol naming the http protocol  (e.g. :http/1.0)
     :initarg :protocol
     :reader request-protocol)
@@ -668,6 +683,19 @@
     (make-resp 500 "Internal Server Error"))
 (defparameter *response-not-implemented* (make-resp 501 "Not Implemented"))
 
+(defparameter *responses*
+    (list *response-ok*
+	  *response-created*
+	  *response-accepted*
+	  *response-moved-permanently*
+	  *response-found*
+	  *response-see-other*
+	  *response-not-modified*
+	  *response-temporary-redirect*
+	  *response-bad-request*
+	  *response-unauthorized*
+	  *response-not-found*))
+
 (defvar *crlf* (make-array 2 :element-type 'character :initial-contents
 			   '(#\return #\linefeed)))
 
@@ -759,11 +787,21 @@
 (defun start-simple-server ()
   ;; do all the serving on the main thread so it's easier to
   ;; debug problems
-  (let ((main-socket (wserver-socket *wserver*)))
+  (let ((main-socket (wserver-socket *wserver*))
+	(ipaddrs (wserver-ipaddrs *wserver*)))
     (unwind-protect
 	(loop
 	  (restart-case
-	      (process-connection (socket:accept-connection main-socket))
+	      (let ((sock (socket:accept-connection main-socket))
+		    (localhost))
+		(if* (not (member (setq localhost (socket:local-host sock))
+				  ipaddrs))
+		   then ; new ip address by which this machine is known
+			(push localhost ipaddrs)
+			(setf (wserver-ipaddrs *wserver*) ipaddrs))
+
+		(process-connection sock))
+
 	    (:loop ()  ; abort out of error without closing socket
 	      nil)))
       (close main-socket))))
@@ -832,12 +870,23 @@
   (let* ((error-count 0)
 	 (workers nil)
 	 (server *wserver*)
-	 (main-socket (wserver-socket server)))
+	 (main-socket (wserver-socket server))
+	 (ipaddrs (wserver-ipaddrs server)))
     (unwind-protect
 
 	(loop
 	  (handler-case
-	      (let ((sock (socket:accept-connection main-socket)))
+	      (let ((sock (socket:accept-connection main-socket))
+		    (localhost))
+
+		; track all the ipaddrs by which we're reachable
+		(if* (not (member (setq localhost (socket:local-host sock))
+				  ipaddrs))
+		   then ; new ip address by which this machine is known
+			(push localhost ipaddrs)
+			(setf (wserver-ipaddrs *wserver*) ipaddrs))
+
+
 		(setq error-count 0) ; reset count
 
 		; find a worker thread
@@ -985,10 +1034,14 @@
 	    (if* (or (null cmd) (null protocol))
 	       then ; no valid command found
 		    (return-from read-http-request nil))
-
+
+	    (if* (null (net.uri:uri-path uri))
+	       then (setf (net.uri:uri-path uri) "/"))
+
 	    (setq req (make-instance 'http-request
 			:method cmd
-			:uri uri
+			:uri (net.uri:copy-uri uri)
+			:raw-uri uri
 			:protocol protocol
 			:protocol-string (case protocol
 					   (:http/1.0 "HTTP/1.0")
@@ -1735,7 +1788,13 @@
     ))
 
 
-
+
+(defun maybe-universal-time-to-date (ut-or-string)
+  ;; given a ut or a string, only do the conversion on the string
+  (if* (stringp ut-or-string) 
+     then ut-or-string
+     else (universal-time-to-date ut-or-string)))
+
 (defun universal-time-to-date (ut)
   ;; convert a lisp universal time to rfc 1123 date
   ;;
@@ -1871,3 +1930,11 @@
 		(setf (cdr ent) (cdr header)))))
     (setf (request-reply-headers req) current-headers)))
 
+
+(defun code-to-response (code)
+  ;; return response object for the given code
+  (let ((obj (find code *responses* :key #'response-number)))
+    (if* (null obj)
+       then (push (setq obj (make-resp code "unknown code")) *responses*))
+    obj))
+

publish.cl

@@ -23,7 +23,7 @@
 ;; Suite 330, Boston, MA  02111-1307  USA
 ;;
 ;;
-;; $Id: publish.cl,v 1.32 2000/06/10 19:06:41 jkf Exp $
+;; $Id: publish.cl,v 1.33 2000/06/26 04:51:34 jkf Exp $
 
 ;; Description:
 ;;   publishing urls
@@ -355,7 +355,7 @@
 ;-- content-length -- how long is the body of the response, if we know
 
 (defmethod content-length ((ent entity))
-  ;; by default we don't know, and that's what nil mean
+  ;; by default we don't know, and that's what nil means
   nil)
 
 (defmethod content-length ((ent file-entity))
@@ -1181,7 +1181,7 @@
 		(not (eq (request-protocol req) :http/0.9)))
 	 then ; can put out headers
 	      (format-dif :xmit sock "Date: ~a~a" 
-			  (universal-time-to-date (request-reply-date req))
+			  (maybe-universal-time-to-date (request-reply-date req))
 			  *crlf*)
 
 	      (if* (member :keep-alive strategy :test #'eq)