;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: July 2003
;;;;
-;;;; $Id: project.lisp,v 1.9 2003/08/09 21:42:24 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
(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
(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
(: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)))
(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
(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)
: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)))
(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))
(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)
(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*))
(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)
(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-"))
(,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
(defun no-url-handler (req ent)
- (with-wol-page (req ent)
+ (with-wol-page (req ent :response-code 404)
(html
(:html
(:head