X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=project.lisp;h=cf8c1910c44ddc516a34ec452a5151241d4d7fc0;hb=97e14ef9a350c61c9891c1d43aab815c574c1ce6;hp=6a285f65f706dd0ca4e3562e0a9dd0413b22f8f0;hpb=0c0d797b5e6c5afa9050b8021ea4729f4ab68aca;p=wol.git diff --git a/project.lisp b/project.lisp index 6a285f6..cf8c191 100644 --- a/project.lisp +++ b/project.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: July 2003 ;;;; -;;;; $Id: project.lisp,v 1.8 2003/08/08 23:40:13 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -15,9 +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 @@ -53,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))) @@ -65,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,8 +81,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 +108,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))) @@ -151,8 +154,6 @@ (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)) @@ -169,13 +170,16 @@ (defun redirect-entity (page req ent &optional plist) (let ((proj (entity-project ent)) - (url (make-wol-url page req ent plist))) + (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-moved-permanently*) + :response net.aserve:*response-temporary-redirect*) (set-cookie req ent) (net.aserve:with-http-body ((aserve-request req) @@ -185,6 +189,8 @@ (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) req ent) @@ -202,7 +208,11 @@ (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*)) @@ -291,29 +301,43 @@ (defmacro with-wol-page ((req ent - &key (format :html) (precompute t) headers) + &key (format :html) (precompute t) headers + (response-code 200) + timeout) &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) + :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)))) - (: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-")) @@ -326,8 +350,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 @@ -360,7 +384,7 @@ (defun no-url-handler (req ent) - (with-wol-page (req ent) + (with-wol-page (req ent :response-code 404) (html (:html (:head