X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=project.lisp;fp=project.lisp;h=6a285f65f706dd0ca4e3562e0a9dd0413b22f8f0;hb=0c0d797b5e6c5afa9050b8021ea4729f4ab68aca;hp=346ccd31b302744946e6ba62d18290a75fbff7e5;hpb=b2a8ce33193d1621e9232521e779adf6a7d872f3;p=wol.git diff --git a/project.lisp b/project.lisp index 346ccd3..6a285f6 100644 --- 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)