r5483: *** empty log message ***

[wol.git] / project.lisp

diff --git a/project.lisp b/project.lisp
index d5213f95c295debfdab0c64d9fc1fae7365cae63..119c929e00b93096c9462e584bc9c841b29dee7f 100644 (file)
--- 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