X-Git-Url: http://git.kpe.io/?p=wol.git;a=blobdiff_plain;f=project.lisp;h=ea38c8a28c54618dd74e0314092b0559e7bf0c28;hp=d5213f95c295debfdab0c64d9fc1fae7365cae63;hb=3e423cb89e5838ab11edb6f128331ebbc8b85f4e;hpb=cfaad04360c41c3c930d8da4eeafc848ff46f6aa diff --git a/project.lisp b/project.lisp index d5213f9..ea38c8a 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$ ;;;; ;;;; 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 @@ -44,7 +45,7 @@ (let ((hash (make-hash-table :size (length map) :test 'equal))) (dolist (map-item map) - (setf (gethash (first map-item) hash) (second map-item))) + (setf (gethash (first map-item) hash) (cdr map-item))) (setf (project-hash-map project) hash)) (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))) @@ -186,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) @@ -203,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*)) @@ -213,36 +222,45 @@ (defun dispatch-to-handler (req ent) - (let ((handler (request-find-handler req ent)) + (let ((handlers (request-find-handlers req ent)) (*wol-stream* (request-socket req))) - (if handler - (handle-request handler req ent) + (if handlers + (handle-request handlers req ent) (no-url-handler req ent)))) -(defun request-find-handler (req ent) +(defun request-find-handlers (req ent) (nth-value 0 (gethash (request-page req) (project-hash-map (entity-project ent))))) -(defun handle-request (handler req ent) - (typecase handler +(defun handle-request (handlers req ent) + (typecase handlers (null + (setf (entity-generators ent) nil) nil) - ((or symbol function) - (when (and (symbolp handler) - (not (fboundp handler))) - (cmsg "handler given a symbol without a function ~S" handler) - (return-from handle-request nil)) - (let ((next-page (funcall handler req ent))) - (typecase next-page - (string - (redirect-entity next-page req ent)) - (cons - (redirect-entity (car next-page) req ent (cadr next-page))) - (null - t) - (t - (cmsg "handler should return nil or a string, not ~S" next-page)))) - t) + (list + (let ((next-handler (first handlers))) + (setf (entity-generators ent) (cdr handlers)) + (when (and (symbolp next-handler) + (not (fboundp next-handler))) + (cmsg "handler given a symbol without a function ~S" next-handler) + (return-from handle-request nil)) + (let ((next-page (funcall next-handler req ent))) + (typecase next-page + (string + (setf (entity-generators ent) nil) + (redirect-entity next-page req ent)) + (cons + (setf (entity-generators ent) nil) + (redirect-entity (car next-page) req ent (cadr next-page))) + (keyword + (if (eq :continue next-page) + (handle-request (cdr handlers) req ent) + (add-log-entry "Invalid return keyword ~S" next-page))) + (null + t) + (t + (cmsg "handler should return nil or a string, not ~S" next-page)))) + t)) (string (cmsg "string handler not supported: ~A" handler) nil) @@ -292,29 +310,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-")) @@ -327,8 +359,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 @@ -361,7 +393,7 @@ (defun no-url-handler (req ent) - (with-wol-page (req ent) + (with-wol-page (req ent :response-code 404) (html (:html (:head