X-Git-Url: http://git.kpe.io/?p=wol.git;a=blobdiff_plain;f=project.lisp;h=75322739ecfbed95e28c13a974d8a9cd5daaabcb;hp=cc26b2783ff09dfe1348b8db4ac8873b926fcddb;hb=HEAD;hpb=e74e1fd67746e37a630a1c9f8251467ba4254508 diff --git a/project.lisp b/project.lisp index cc26b27..7532273 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$ ;;;; ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -15,143 +15,252 @@ (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) + timeout) + (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)) - + (multiple-value-bind (project found) (gethash name *active-projects*) (unless found (setq project (make-instance 'wol-project)) (setf (gethash name *active-projects*) project)) - + (setf (project-name project) name) (setf (project-prefix project) project-prefix) (setf (project-map project) map) - (setf (project-index project) index) + (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) (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)) - - (setf (ml::processor server) 'wol-ml-processor) - (if sessions - (when (null (sessions (session-master project))) - (setf (sessions (session-master project)) - (make-hash-table :test 'eq))) + (ecase connector + (:modlisp + (setf (ml::processor server) 'wol-ml-processor)) + (:aserve + (net.aserve:publish-prefix :prefix project-prefix + :server server + :function 'wol-aserve-processor + :timeout timeout))) + + (if sessions + (when (null (sessions (session-master project))) + (setf (sessions (session-master project)) + (make-hash-table :test 'eq))) (when (sessions (session-master project)) - (setf (sessions (session-master project)) nil))) + (setf (sessions (session-master project)) nil))) (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 - :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" + (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) "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)) - :protocol-string (header-value command :server-protocol) - :method (ensure-keyword (header-value command :method)) - :posted-content (header-value command :posted-content) - :headers command - :socket *modlisp-socket* - :ml-server ml-server))) + (make-instance 'http-request + :host (header-value command :host) + :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) + :method (ensure-keyword (header-value command :method)) + :posted-content (header-value command :posted-content) + :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 (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) + (header-value command :server-ip-port) + (header-value command :url))) (defun is-index-request (req ent) - (string= (request-raw-uri req) - (project-prefix (entity-project ent)))) - -(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 + (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))) - (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))) + (ecase (project-connector proj) + (:aserve + (net.aserve:set-cookie-header (aserve-request req) + :name (project-name + (entity-project ent)) + :expires :never + :secure nil + :domain ".kpe.io" + :value (websession-key + (websession-from-req req)) + :path "/")) + (:modlisp + ;; fixme + )))))) + + +(defun redirect-entity (page req ent &optional plist) + (let ((proj (entity-project ent)) + (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-temporary-redirect*) + (set-cookie req ent) + (net.aserve:with-http-body + ((aserve-request req) + (entity-aserve-entity ent) + :headers `((:location . ,url)))))) + (:modlisp + (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 + (compute-uris 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)))) - *active-projects*)) + (declare (ignore name)) + (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 (request-raw-uri req))) + (string-starts-with prefix (request-decoded-uri-path req))) -(defun dispatch-entity (req ent) - (let ((handler (request-find-handler req ent))) - (if handler - (handle-request handler req ent) - (no-url-handler req)))) +(defun dispatch-to-handler (req ent) + (let ((handlers (request-find-handlers req ent)) + (*wol-stream* (request-socket req))) + (if handlers + (handle-request handlers req ent) + (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 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 ent)) - (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) @@ -159,33 +268,37 @@ (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 alist-key->keyword (alist) + (loop for a in alist + collect (cons (kmrcl:ensure-keyword (car a)) (cdr a)))) + (defun request-query (req &key (uri t) (post t)) - (append - (when (and uri (request-uri-query req)) - (aif (request-query-alist req) - it - (setf (request-query-alist req) - (query-to-alist (request-uri-query req))))) - (when (and post (request-posted-content req)) - (query-to-alist (request-posted-content req))))) + (aif (aserve-request req) + (alist-key->keyword + (net.aserve:request-query it :uri uri :post post)) + (let ((desired (cons uri post))) + (if (equal desired (request-desired-query req)) + ;; Same desired as cached + (request-query-alist req) + (progn + (setf (request-desired-query req) desired) + (setf (request-query-alist req) + (append + (when (and uri (request-uri-query req)) + (query-to-alist (request-uri-query req))) + (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)) + (aif (aserve-request req) + (net.aserve:request-query-value (string key) it :uri uri :post post) + (cdr (assoc key (request-query req :uri uri :post post) + :test 'equal)))) (defun websession-variable (ws name) (when ws @@ -194,3 +307,102 @@ (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 + (response-code 200) + timeout) + &body body) + `(if (request-aserve-server ,req) + (net.aserve:with-http-response + ((aserve-request ,req) + (entity-aserve-entity ,ent) + :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 + (response-string "200 OK")) + &body body) + (declare (ignore req ent)) + (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" ,response-string) + (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 :response-code 404) + (html + (:html + (:head + (:title "404 - NotFound")) + (:body + (:h1 "Not Found") + (:p "The request for " + (:b (:write-string (render-uri (request-uri req) nil))) + " was not found on this server.") + (:hr) + (:div (:i "WOL " + (:write-string (wol-version-string)))))))))