X-Git-Url: http://git.kpe.io/?p=wol.git;a=blobdiff_plain;f=project.lisp;h=0280a27e9ff88252f33f497ac02059dca0ea49ab;hp=cc26b2783ff09dfe1348b8db4ac8873b926fcddb;hb=d91ff3b4d9cdcae003420c04609ea736161c7e65;hpb=e74e1fd67746e37a630a1c9f8251467ba4254508 diff --git a/project.lisp b/project.lisp index cc26b27..0280a27 100644 --- a/project.lisp +++ b/project.lisp @@ -7,7 +7,7 @@ ;;;; 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 ;;;; ************************************************************************* @@ -15,8 +15,16 @@ (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)) @@ -31,6 +39,7 @@ (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) @@ -38,10 +47,16 @@ (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))) @@ -54,17 +69,49 @@ (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 @@ -93,30 +140,28 @@ (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) @@ -124,11 +169,12 @@ (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) @@ -159,23 +205,10 @@ (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 @@ -187,6 +220,10 @@ (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)))) @@ -194,3 +231,65 @@ (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)))))))))