;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: July 2003
;;;;
-;;;; $Id: project.lisp,v 1.2 2003/07/16 20:40:43 kevin Exp $
+;;;; $Id: project.lisp,v 1.3 2003/07/18 21:34:18 kevin Exp $
;;;;
;;;; 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 *ml-server*))
+ (sessions t) (session-lifetime 18000)
+ (reap-interval 300) server
+ (connector :modlisp))
+
+ (unless server
+ (setq server
+ (ecase connector
+ (:modlisp ml:*ml-server*)
+ (:aserve net.aserve:*wserver*))))
+
(unless server
(warn "Can't start project without server")
(return-from wol-project nil))
(setf (project-map project) map)
(setf (project-index project) index)
(setf (project-server project) server)
+ (setf (project-connector project) connector)
(setf (lifetime (session-master project)) session-lifetime)
(setf (cookie-name (session-master project)) name)
(dolist (map-item map)
(setf (gethash (first map-item) hash) (second map-item)))
(setf (project-hash-map project) hash))
-
- (setf (ml::processor server) 'wol-ml-processor)
- (if sessions
+ (ecase connector
+ (:modlisp
+ (setf (ml::processor server) 'wol-ml-processor))
+ (:aserve
+ (net.aserve:publish-prefix :prefix project-prefix
+ :server server
+ :function 'wol-aserve-processor)))
+
+ (if sessions
(when (null (sessions (session-master project)))
(setf (sessions (session-master project))
(make-hash-table :test 'eq)))
(defun wol-ml-processor (command)
"Processes an incoming modlisp command"
- (let ((req (command->request command
- :ml-server *ml-server*)))
- (unless (dispatch-request req)
- (no-url-handler req))))
+ (let* ((req (command->request command
+ :ml-server *ml-server*))
+ (ent (make-entity-for-request req)))
+ (if ent
+ (dispatch-request req ent)
+ (no-url-handler req ent))))
+
+
+(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 (net.uri:render-uri
+ (net.aserve:request-raw-uri as-req)
+ nil)
+ :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 command->request (command &key ml-server)
"Convert a cl-modlisp command into a wol request"
(let ((req
(make-instance 'http-request
- :vhost (header-value command :host)
+ :host (header-value command :host)
:raw-uri (header-value command :url)
:uri (create-uri (header-value command :host)
(awhen (header-value
(defun redirect-entity (page ent)
(redirect-to-location
(format nil "~A~A" (project-prefix (entity-project ent)) page)))
-
-(defun dispatch-request (req)
- (let ((ent (find-entity-for-request req)))
- (when ent
- (let ((proj (entity-project ent)))
- (if (is-index-request req ent)
- (progn
- (redirect-entity (project-index proj) ent)
- t)
- (progn
- (request-decompile-uri req ent)
- (compute-session req ent)
- (dispatch-entity req ent))))
- ent)))
+
+(defun dispatch-request (req ent)
+ (let ((proj (entity-project ent)))
+ (if (is-index-request req ent)
+ (redirect-entity (project-index proj) ent)
+ (progn
+ (request-decompile-uri req ent)
+ (compute-session req ent)
+ (dispatch-to-handler req ent)))))
(defun make-entity (&key project)
(make-instance 'entity :project project))
-(defun find-entity-for-request (req)
+(defun make-entity-for-request (req)
+ (awhen (find-project-for-request req)
+ (make-entity :project it)))
+
+(defun find-project-for-request (req)
(maphash (lambda (name project)
(declare (ignore name))
(when (request-matches-prefix req (project-prefix project))
- (return-from find-entity-for-request
- (make-entity :project project))))
+ (return-from find-project-for-request project)))
*active-projects*))
(defun request-matches-prefix (req prefix)
(string-starts-with prefix (request-raw-uri req)))
-(defun dispatch-entity (req ent)
- (let ((handler (request-find-handler req ent)))
+(defun dispatch-to-handler (req ent)
+ (let ((handler (request-find-handler req ent))
+ (*wol-stream* (request-socket req)))
(if handler
(handle-request handler req ent)
- (no-url-handler req))))
+ (no-url-handler req ent))))
(defun request-find-handler (req ent)
(nth-value 0 (gethash (request-page req)
(cmsg "unknown handler type: ~S" handler)
nil)))
-(defun no-url-handler (req)
- (print (request-socket req))
- (with-ml-page ()
- (html-stream
- *modlisp-socket*
- (:html
- (:head
- (:title "404 - NotFound"))
- (:body
- (:h1 "Not Found")
- (:p "The request for "
- (:b (:write-string (request-uri req)))
- " was not found on this server.")
- (:hr)
- (:div (:i "WOL "
- (:write-string *wol-version*))))))))
+
+(defun wol-version-string ()
+ (format nil "~{~D~^.~}" *wol-version*))
(defun request-query (req &key (uri t) (post t))
(append
(when (and post (request-posted-content req))
(query-to-alist (request-posted-content req)))))
+(defun request-query-value (key req &key (uri t) (post t))
+ (cdr (assoc key (request-query req :uri uri :post post)
+ :test 'equal)))
+
(defun websession-variable (ws name)
(when ws
(gethash name (websession-variables ws))))
(defun (setf websession-variable) (value ws name)
(when ws
(setf (gethash name (websession-variables ws)) value)))
+
+
+(defmacro with-wol-page ((req ent
+ &key (format :html) (precompute t) headers)
+ &body body)
+ (let ((fmt (gensym "FMT-"))
+ (precomp (gensym "PRE-"))
+ (result (gensym "RES-"))
+ (outstr (gensym "STR-"))
+ (stream (gensym "STRM-"))
+ (hdr (gensym "HDR-")))
+ `(let ((,fmt ,format)
+ (,precomp ,precompute)
+ ,result ,outstr ,stream)
+ (declare (ignorable ,stream))
+ (write-header-line "Status" "200 OK")
+ (write-header-line "Content-Type" (ml::format-string ,fmt))
+ (dolist (,hdr ,headers)
+ (write-header-line (car ,hdr) (cdr ,hdr)))
+ (unless ,precomp
+ (write-string "end" *wol-stream*)
+ (write-char #\NewLine *wol-stream*))
+ (setq ,outstr
+ (with-output-to-string (,stream)
+ (let ((*html-stream* (if ,precomp
+ ,stream
+ *wol-stream*))
+ (*wol-stream* (if ,precomp
+ ,stream
+ *wol-stream*)))
+ (setq ,result (progn ,@body)))))
+ (cond
+ (,precomp
+ (write-header-line "Content-Length"
+ (write-to-string (length ,outstr)))
+ (write-header-line "Keep-Socket" "1")
+ (write-header-line "Connection" "Keep-Alive")
+ (write-string "end" *wol-stream*)
+ (write-char #\NewLine *wol-stream*)
+ (write-string ,outstr *wol-stream*)
+ (finish-output *wol-stream*)
+ (setq *close-modlisp-socket* nil))
+ (t
+ (finish-output *wol-stream*)
+ (setq *close-modlisp-socket* t)))
+ ,result)))
+
+
+(defun no-url-handler (req ent)
+ (with-wol-page (req ent)
+ (html
+ (:html
+ (:head
+ (:title "404 - NotFound"))
+ (:body
+ (:h1 "Not Found")
+ (:p "The request for "
+ (:b (:write-string (request-uri req)))
+ " was not found on this server.")
+ (:hr)
+ (:div (:i "WOL "
+ (:write-string (wol-version-string)))))))))
projects / wol.git / blobdiff