X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=project.lisp;fp=project.lisp;h=119c929e00b93096c9462e584bc9c841b29dee7f;hb=0c0d2b88b9c35f1da0f62566768ccc0b6a4c7aa2;hp=d5213f95c295debfdab0c64d9fc1fae7365cae63;hpb=cfaad04360c41c3c930d8da4eeafc848ff46f6aa;p=wol.git

diff --git a/project.lisp b/project.lisp
index d5213f9..119c929 100644
--- a/project.lisp
+++ b/project.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: project.lisp,v 1.10 2003/08/09 22:18:32 kevin Exp $
+;;;; $Id: project.lisp,v 1.11 2003/08/10 05:16:52 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -65,7 +65,10 @@
     (setq *reap-interval* reap-interval)
     (when (and sessions (null *reaper-process*))
       (setq *reaper-process* (start-reaper)))))
-    
+
+(defun stop-wol-project (name)
+  (remhash name *active-projects*))
+
 (defun wol-ml-processor (command)
   "Processes an incoming modlisp command"
   (let* ((req (command->request command
@@ -79,8 +82,9 @@
 (defun wol-aserve-processor (as-req as-ent)
   "Processes an incoming modlisp command"
   (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
-    (dispatch-request req ent)))
-
+    (if (entity-project ent)
+	(dispatch-request req ent)
+      (no-url-handler req ent))))
 
     
 (defun make-request/ent-from-aserve (as-req as-ent)
@@ -105,8 +109,8 @@
 	       :headers (net.aserve::request-headers as-req)
 	       :aserve-server net.aserve:*wserver*
 	       :aserve-request as-req))
-	 (ent (make-instance 'entity
-			     :project (find-project-for-request req)
+	 (project (find-project-for-request req))
+	 (ent (make-instance 'entity :project project
 			     :aserve-entity as-ent)))
     (values req ent)))
 
@@ -203,7 +207,13 @@
 (defun find-project-for-request (req)
   (maphash (lambda (name project)
 	     (declare (ignore name))
-	     (when (request-matches-prefix req (project-prefix project))
+	     (setq cl-user::p project)
+	     (setq cl-user::r req)
+	     (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*))
 
@@ -292,29 +302,41 @@
 
 
 (defmacro with-wol-page ((req ent
-			  &key (format :html) (precompute t) headers)
+			  &key (format :html) (precompute t) headers
+			       (response-code 200))
 			 &body body)
-  `(ecase (project-connector (entity-project ,ent))
-     (:aserve
+  `(if (request-aserve-server ,req)
       (net.aserve:with-http-response 
 	  ((aserve-request ,req) 
 	   (entity-aserve-entity ,ent)
-	   :content-type (ml::format-string ,format))
+	   :content-type (ml::format-string ,format)
+	   :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))))
-     (:modlisp
-      (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
-			    :headers ,headers)
-		      ,@body))))
+	  (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)
+			   &key (format :html) (precompute t) headers
+				(response-string "200 OK"))
 			 &body body)
   (declare (ignore req ent))
   (let ((fmt (gensym "FMT-"))
@@ -327,7 +349,7 @@
 	   (,precomp ,precompute)
 	   ,result ,outstr ,stream)
        (declare (ignorable ,stream))
-       (write-header-line "Status" "200 OK")
+       (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)))
@@ -361,7 +383,7 @@
 
 
 (defun no-url-handler (req ent)
-  (with-wol-page (req ent)
+  (with-wol-page (req ent :response-code 404)
     (html
      (:html
       (:head