X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=project.lisp;h=ad94d48f2aa99087ff062300aa2130098eb1f4cd;hb=3bffe3c738cf4026f76cd7428c378442e0e4bb2a;hp=ac0e5a80c9d987135e0ab444c583cc8863baf93f;hpb=de82da84115f8e2a6ad7add24cb73e7876c89a3b;p=wol.git diff --git a/project.lisp b/project.lisp index ac0e5a8..ad94d48 100644 --- a/project.lisp +++ b/project.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: July 2003 ;;;; -;;;; $Id: project.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; $Id: project.lisp,v 1.5 2003/07/23 23:08:28 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,24 +69,53 @@ (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 (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)) (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) - :raw-uri (header-value command :url) - :uri (create-uri (header-value command :host) - (awhen (header-value - command :server-ip-port) - (parse-integer it)) - (header-value command :url)) - :protocol (ensure-keyword (header-value command :server-protocol)) + :host (header-value command :host) + :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) :method (ensure-keyword (header-value command :method)) :posted-content (header-value command :posted-content) @@ -83,59 +127,60 @@ (defun header-slot-value (req slot) (header-value (request-headers req) slot)) -(defun create-uri (host port page) - (format nil "http://~A:~D~A" host port page)) +(defun command->uri (command) + (format nil "http://~A:~D~A" + (header-value command :host) + (awhen (header-value + command :server-ip-port) + (parse-integer it)) + (header-value command :url))) (defun is-index-request (req ent) - (string= (request-raw-uri req) + (string= (puri:uri-path (request-raw-uri req)) (project-prefix (entity-project ent)))) -(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-to-location - (format nil "~A~A" - (project-prefix proj) - (project-index proj))) - t) - (progn - (request-decompile-uri req ent) - (compute-session req ent) - (dispatch-entity req ent)))) - ent))) +(defun redirect-entity (page ent &optional plist) + (redirect-to-location (apply #'make-wol-url page ent plist))) + +(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) "Returns project if request matches project" - (string-starts-with prefix (request-raw-uri req))) + (string-starts-with prefix (puri:uri-path (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) (project-hash-map (entity-project ent))))) -(defun action-redirect (page req ent) - (cmsg "redirect to ~A" page)) - (defun handle-request (handler req ent) (typecase handler (null @@ -145,14 +190,16 @@ (not (fboundp handler))) (cmsg "handler given a symbol without a function ~S" handler) (return-from handle-request nil)) - (let ((res (funcall handler req ent))) - (typecase res + (let ((next-page (funcall handler req ent))) + (typecase next-page (string - (action-redirect res req ent)) + (redirect-entity next-page ent)) + (cons + (redirect-entity (car next-page) ent (cadr next-page))) (null t) (t - (cmsg "handler should return nil or a string")))) + (cmsg "handler should return nil or a string, not ~S" next-page)))) t) (string (cmsg "string handler not supported: ~A" handler) @@ -161,23 +208,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 @@ -189,6 +223,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)))) @@ -196,3 +234,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)))))))))