r5473: *** empty log message ***

[wol.git] / project.lisp

diff --git a/project.lisp b/project.lisp
index 346ccd31b302744946e6ba62d18290a75fbff7e5..6a285f65f706dd0ca4e3562e0a9dd0413b22f8f0 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.7 2003/08/08 09:03:45 kevin Exp $
+;;;; $Id: project.lisp,v 1.8 2003/08/08 23:40:13 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -78,32 +78,37 @@
 
 (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)))
+  (multiple-value-bind (req ent) (make-request/ent-from-aserve as-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))
+
+    
+(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))
+        (ent (make-instance 'entity
+                            :project (find-project-for-request req)
+                            :aserve-entity as-ent)))
+    (values req ent)))
 
 
 (defun command->request (command &key ml-server)
@@ -111,14 +116,9 @@
   (let ((req
         (make-instance 'http-request
           :host (header-value command :host)
-          :raw-uri  (aif (ignore-errors
-                          (puri:intern-uri (header-value command :url)))
-                         it
-                         (header-value command :url))
-          :uri (aif (ignore-errors
-                     (puri:intern-uri (command->uri command)))
-                    it
-                    (command->uri command))
+          :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))
           :protocol-string (header-value command :server-protocol)
@@ -127,6 +127,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)
@@ -139,18 +141,42 @@
          (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 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
+          (cmsg "Set-cookie: ~A"  (websession-key
+                                                (websession-from-req req)))
+          (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 (make-wol-url page ent plist)))
+       (url (make-wol-url page req ent plist)))
     (ecase (project-connector proj)
       (:aserve
        (net.aserve:with-http-response 
           ((aserve-request req) 
            (entity-aserve-entity ent)
            :response net.aserve:*response-moved-permanently*)
+        (set-cookie req ent)
         (net.aserve:with-http-body 
             ((aserve-request req) 
              (entity-aserve-entity ent)
@@ -163,8 +189,7 @@
     (if (is-index-request req 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)
@@ -183,7 +208,7 @@
 
 (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)
@@ -274,6 +299,7 @@
          ((aserve-request ,req) 
           (entity-aserve-entity ,ent)
           :content-type (ml::format-string ,format))
+       (set-cookie ,req ,ent)
        (net.aserve:with-http-body 
            ((aserve-request ,req) 
             (entity-aserve-entity ,ent)