;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: July 2003
;;;;
-;;;; $Id: project.lisp,v 1.7 2003/08/08 09:03:45 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
(: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"
- (let* ((req (make-request-from-aserve as-req))
- (ent (make-entity-from-aserve 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))
+ (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
+ (if (entity-project ent)
+ (dispatch-request req ent)
+ (no-url-handler req 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))
+ (project (find-project-for-request req))
+ (ent (make-instance 'entity :project project
+ :aserve-entity as-ent)))
+ (values req ent)))
(defun command->request (command &key ml-server)
(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)
: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)
(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
+ (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 (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)
(entity-aserve-entity 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)
(progn
- (request-decompile-uri req ent)
- (compute-session req ent)
+ (compute-uris req ent)
(dispatch-to-handler req ent)))))
(defun make-entity (&key project)
(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 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)
(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))
- (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))))
+ :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)))
+ (%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 "Status" ,response-string)
(write-header-line "Content-Type" (ml::format-string ,fmt))
(dolist (,hdr ,headers)
(write-header-line (car ,hdr) (cdr ,hdr)))
(defun no-url-handler (req ent)
- (with-wol-page (req ent)
+ (with-wol-page (req ent :response-code 404)
(html
(:html
(:head
projects / wol.git / blobdiff