X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=project.lisp;h=ea38c8a28c54618dd74e0314092b0559e7bf0c28;hb=ba01a7216c7a4c15c103525654fe10ea5845afb1;hp=a0d40610b561d6468cbab955cccd534747701b3f;hpb=b02132b356f13c6e1d04fde727eb86ac1ee0b3ce;p=wol.git

diff --git a/project.lisp b/project.lisp
index a0d4061..ea38c8a 100644
--- a/project.lisp
+++ b/project.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: project.lisp,v 1.4 2003/07/19 20:32:48 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -15,10 +15,10 @@
 (in-package #:wol)
 
 (defun wol-project (name &key (project-prefix "/") map index
-		    (sessions t) (session-lifetime 18000)
-		    (reap-interval 300) server
-		    (connector :modlisp))
-
+			      (sessions t) (session-lifetime 18000)
+			      (reap-interval 300) server
+			      (connector :modlisp)
+			      timeout)
   (unless server
     (setq server 
 	  (ecase connector
@@ -45,7 +45,7 @@
 
     (let ((hash (make-hash-table :size (length map) :test 'equal)))
       (dolist (map-item map)
-	(setf (gethash (first map-item) hash) (second map-item)))
+	(setf (gethash (first map-item) hash) (cdr map-item)))
       (setf (project-hash-map project) hash))
 
     (ecase connector
@@ -54,7 +54,8 @@
       (:aserve
        (net.aserve:publish-prefix :prefix project-prefix
 				  :server server
-				  :function 'wol-aserve-processor)))
+				  :function 'wol-aserve-processor
+				  :timeout timeout)))
   
   (if sessions
 	(when (null (sessions (session-master project)))
@@ -66,7 +67,7 @@
     (setq *reap-interval* reap-interval)
     (when (and sessions (null *reaper-process*))
       (setq *reaper-process* (start-reaper)))))
-    
+
 (defun wol-ml-processor (command)
   "Processes an incoming modlisp command"
   (let* ((req (command->request command
@@ -79,32 +80,38 @@
 
 (defun wol-aserve-processor (as-req as-ent)
   "Processes an incoming modlisp command"
-  (let* ((req (make-request-from-aserve as-req))
-	 (ent (make-entity-from-aserve req as-ent)))
-    (dispatch-request req ent)))
-
-(defun make-request-from-aserve (as-req)
-  (make-instance 'http-request
-		 :method (net.aserve:request-method as-req)
-		 ;;:host (net.aserve:request-host as-req)
-		 :raw-uri (puri:intern-uri
-			   (net.uri:render-uri
-			    (net.aserve:request-raw-uri as-req) nil))
-		 :uri (puri:intern-uri
-		       (net.uri:render-uri
-			(net.aserve:request-uri as-req) nil))
-		 :protocol (net.aserve:request-protocol as-req)
-		 :protocol-string
-		 (net.aserve:request-protocol-string as-req)
-		 :posted-content (net.aserve::request-request-body as-req)
-		 :socket (net.aserve:request-socket as-req)
-		 :aserve-server net.aserve:*wserver*
-		 :aserve-request as-req))
-
-(defun make-entity-from-aserve (req as-ent)
-  (make-instance 'entity
-		 :project (find-project-for-request req)
-		 :aserve-entity as-ent))
+  (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
+    (if (entity-project ent)
+	(dispatch-request req ent)
+      (no-url-handler req ent))))
+
+    
+(defun make-request/ent-from-aserve (as-req as-ent)
+  (let* ((req (make-instance
+	       'http-request
+	       :method (net.aserve:request-method as-req)
+	       ;;:host (net.aserve:request-host as-req)
+	       :raw-request (net.aserve::request-raw-request as-req)
+	       :raw-uri (puri:intern-uri
+			 (net.uri:render-uri
+			 (net.aserve:request-raw-uri as-req) nil))
+	       :decoded-uri-path
+	       (net.aserve::request-decoded-uri-path as-req)
+	       :uri (puri:intern-uri
+		     (net.uri:render-uri
+		     (net.aserve:request-uri as-req) nil))
+	       :protocol (net.aserve:request-protocol as-req)
+	       :protocol-string
+	       (net.aserve:request-protocol-string as-req)
+	       :posted-content (net.aserve::request-request-body as-req)
+	       :socket (net.aserve:request-socket as-req)
+	       :headers (net.aserve::request-headers as-req)
+	       :aserve-server net.aserve:*wserver*
+	       :aserve-request as-req))
+	 (project (find-project-for-request req))
+	 (ent (make-instance 'entity :project project
+			     :aserve-entity as-ent)))
+    (values req ent)))
 
 
 (defun command->request (command &key ml-server)
@@ -112,7 +119,8 @@
   (let ((req
 	 (make-instance 'http-request
 	   :host (header-value command :host)
-	   :raw-uri (puri:intern-uri (header-value command :url))
+	   :raw-request (header-value command :url) 
+	   :raw-uri  (puri:intern-uri (header-value command :url))
 	   :uri (puri:intern-uri (command->uri command))
 	   :protocol (ensure-keyword
 		      (header-value command :server-protocol))
@@ -122,6 +130,8 @@
 	   :headers command
 	   :socket *modlisp-socket*
 	   :ml-server ml-server)))
+    (awhen (request-raw-uri req)
+	   (setf (request-decoded-uri-path req) (puri:uri-path it)))
     req))
 
 (defun header-slot-value (req slot)
@@ -130,26 +140,62 @@
 (defun command->uri (command)
   (format nil "http://~A:~D~A"
 	  (header-value command :host)
-	  (awhen (header-value
-		  command :server-ip-port)
-		 (parse-integer it))
+	  (header-value command :server-ip-port)
 	  (header-value command :url)))
 
 (defun is-index-request (req ent)
-  (string= (puri:uri-path (request-raw-uri req)) 
+  (string= (request-decoded-uri-path req)
 	   (project-prefix (entity-project ent))))
 
-(defun redirect-entity (page ent)
-  (redirect-to-location 
-   (format nil "~A~A" (project-prefix (entity-project ent)) page)))
+(defun set-cookie (req ent)
+  (let ((session (websession-from-req req)))
+    (when (and session (websession-key session)
+	       (not (eq :url (websession-method session))))
+      (let ((proj (entity-project ent)))
+	(ecase (project-connector proj)
+	  (:aserve
+	   (net.aserve:set-cookie-header (aserve-request req)
+					 :name (project-name
+						(entity-project ent))
+					 :expires :never
+					 :secure nil
+					 :domain ".b9.com"
+					 :value (websession-key
+						 (websession-from-req req))
+					 :path "/"))
+	  (:modlisp
+	   ;; fixme
+	   ))))))
+
+
+(defun redirect-entity (page req ent &optional plist)
+  (let ((proj (entity-project ent))
+	(url (render-uri
+	      (copy-uri (request-uri req)
+			:path (make-wol-url page req ent plist))
+	      nil)))
+    (ecase (project-connector proj)
+      (:aserve
+       (net.aserve:with-http-response 
+	   ((aserve-request req) 
+	    (entity-aserve-entity ent)
+	    :response net.aserve:*response-temporary-redirect*)
+	 (set-cookie req ent)
+	 (net.aserve:with-http-body 
+	     ((aserve-request req) 
+	      (entity-aserve-entity ent)
+	      :headers `((:location . ,url))))))
+      (:modlisp
+       (redirect-to-location url)))))
 
 (defun dispatch-request (req ent)
+  (setq *req* req)
+  (setq *ent* ent)
   (let ((proj (entity-project ent)))
     (if (is-index-request req ent)
-	(redirect-entity (project-index proj) ent)
+	(redirect-entity (project-index proj) req ent)
 	(progn
-	  (request-decompile-uri req ent)
-	  (compute-session req ent)
+	  (compute-uris req ent)
 	  (dispatch-to-handler req ent)))))
 
 (defun make-entity (&key project)
@@ -162,44 +208,59 @@
 (defun find-project-for-request (req)
   (maphash (lambda (name project)
 	     (declare (ignore name))
-	     (when (request-matches-prefix req (project-prefix project))
+	     (when (and (eq (project-server project)
+			    (or (request-aserve-server req)
+				(request-ml-server req)))
+			(request-matches-prefix
+			 req (project-prefix project)))
 	       (return-from find-project-for-request project)))
 	   *active-projects*))
 
 (defun request-matches-prefix (req prefix)
   "Returns project if request matches project"
-  (string-starts-with prefix (puri:uri-path (request-raw-uri req))))
+  (string-starts-with prefix (request-decoded-uri-path req)))
 
 
 (defun dispatch-to-handler (req ent)
-  (let ((handler (request-find-handler req ent))
+  (let ((handlers (request-find-handlers req ent))
 	(*wol-stream* (request-socket req)))
-    (if handler
-	(handle-request handler req ent)
+    (if handlers
+	(handle-request handlers req ent)
       (no-url-handler req ent))))
 
-(defun request-find-handler (req ent)
+(defun request-find-handlers (req ent)
   (nth-value 0 (gethash (request-page req) 
 			(project-hash-map (entity-project ent)))))
 
-(defun handle-request (handler req ent)
-  (typecase handler
+(defun handle-request (handlers req ent)
+  (typecase handlers
     (null
+     (setf (entity-generators ent) nil)
      nil)
-    ((or symbol function)
-     (when (and (symbolp handler)
-		(not (fboundp handler)))
-       (cmsg "handler given a symbol without a function ~S" handler)
-       (return-from handle-request nil))
-     (let ((next-page (funcall handler req ent)))
-       (typecase next-page
-	 (string
-	  (redirect-entity next-page ent))
-	 (null
-	  t)
-	 (t
-	  (cmsg "handler should return nil or a string, not ~S" next-page))))
-     t)
+    (list
+     (let ((next-handler (first handlers)))
+       (setf (entity-generators ent) (cdr handlers))
+       (when (and (symbolp next-handler)
+		  (not (fboundp next-handler)))
+	 (cmsg "handler given a symbol without a function ~S" next-handler)
+	 (return-from handle-request nil))
+       (let ((next-page (funcall next-handler req ent)))
+	 (typecase next-page
+	   (string
+	    (setf (entity-generators ent) nil)
+	    (redirect-entity next-page req ent))
+	   (cons
+	    (setf (entity-generators ent) nil)
+	    (redirect-entity (car next-page) req ent (cadr next-page)))
+	   (keyword
+	    (if (eq :continue next-page)
+		(handle-request (cdr handlers) req ent)
+		(add-log-entry "Invalid return keyword ~S" next-page)))
+	   (null
+	    t)
+	   (t
+	    (cmsg "handler should return nil or a string, not ~S" next-page))))
+       t))
     (string
      (cmsg "string handler not supported: ~A" handler)
      nil)
@@ -211,20 +272,33 @@
 
 (defun wol-version-string ()
   (format nil "~{~D~^.~}" *wol-version*))
-  
+
+(defun alist-key->keyword (alist)
+  (loop for a in alist
+      collect (cons (kmrcl:ensure-keyword (car a)) (cdr a))))
+
 (defun request-query (req &key (uri t) (post t))
-  (append
-    (when (and uri (request-uri-query req))
-      (aif (request-query-alist req)
-	 it
-	 (setf (request-query-alist req)
-	   (query-to-alist (request-uri-query req)))))
-    (when (and post (request-posted-content req))
-      (query-to-alist (request-posted-content req)))))
+  (aif (aserve-request req)
+       (alist-key->keyword
+	(net.aserve:request-query it :uri uri :post post))
+    (let ((desired (cons uri post)))
+      (if (equal desired (request-desired-query req))
+	  ;; Same desired as cached 
+	  (request-query-alist req)
+	(progn
+	  (setf (request-desired-query req) desired)
+	  (setf (request-query-alist req)
+	    (append
+	     (when (and uri (request-uri-query req))
+	       (query-to-alist (request-uri-query req)))
+	     (when (and post (request-posted-content req))
+	       (query-to-alist (request-posted-content req))))))))))
 
 (defun request-query-value (key req &key (uri t) (post t))
-  (cdr (assoc key (request-query req :uri uri :post post)
-	      :test 'equal)))
+  (aif (aserve-request req)
+       (net.aserve:request-query-value (string key) it :uri uri :post post)
+       (cdr (assoc key (request-query req :uri uri :post post)
+		   :test 'equal))))
     
 (defun websession-variable (ws name)
   (when ws
@@ -236,8 +310,45 @@
 
 
 (defmacro with-wol-page ((req ent
-			      &key (format :html) (precompute t) headers)
+			  &key (format :html) (precompute t) headers
+			       (response-code 200)
+			       timeout)
+			 &body body)
+  `(if (request-aserve-server ,req)
+      (net.aserve:with-http-response 
+	  ((aserve-request ,req) 
+	   (entity-aserve-entity ,ent)
+	   :content-type (ml::format->string ,format)
+	   :timeout ,timeout
+	   :response
+	   (case ,response-code
+	     (302 net.aserve::*response-moved-permanently*)
+	     (307 net.aserve::*response-temporary-redirect*)
+	     (404 net.aserve::*response-not-found*)
+	     (otherwise net.aserve::*response-ok*)))
+	(set-cookie ,req ,ent)
+	  (net.aserve:with-http-body 
+	      ((aserve-request ,req) 
+	       (entity-aserve-entity ,ent)
+	       :headers ,headers)
+	    (let ((*html-stream* net.html.generator:*html-stream*))
+	      ,@body)))
+     (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
+			   :headers ,headers 
+			   :response-string 
+			   (case ,response-code
+			     (302 "302 Moved Permanently")
+			     (307 "307 Temporary Redirect")
+			     (404 "404 Not Found")
+			      (otherwise "200 OK")))
+		     ,@body)))
+  
+
+(defmacro %with-wol-page ((req ent
+			   &key (format :html) (precompute t) headers
+				(response-string "200 OK"))
 			 &body body)
+  (declare (ignore req ent))
   (let ((fmt (gensym "FMT-"))
 	(precomp (gensym "PRE-"))
 	(result (gensym "RES-"))
@@ -248,8 +359,8 @@
 	   (,precomp ,precompute)
 	   ,result ,outstr ,stream)
        (declare (ignorable ,stream))
-       (write-header-line "Status" "200 OK")
-       (write-header-line "Content-Type" (ml::format-string ,fmt))
+       (write-header-line "Status" ,response-string)
+       (write-header-line "Content-Type" (ml::format->string ,fmt))
        (dolist (,hdr ,headers)
 	 (write-header-line (car ,hdr) (cdr ,hdr)))
        (unless ,precomp
@@ -282,7 +393,7 @@
 
 
 (defun no-url-handler (req ent)
-  (with-wol-page (req ent)
+  (with-wol-page (req ent :response-code 404)
     (html
      (:html
       (:head
@@ -290,7 +401,7 @@
       (:body
        (:h1 "Not Found")
        (:p "The request for "
-	   (:b (:write-string (request-uri req)))
+	   (:b (:write-string (render-uri (request-uri req) nil)))
 	   " was not found on this server.")
        (:hr)
        (:div (:i "WOL "