X-Git-Url: http://git.kpe.io/?p=wol.git;a=blobdiff_plain;f=project.lisp;h=75322739ecfbed95e28c13a974d8a9cd5daaabcb;hp=ed1ef4892c8a0beb42db44cbe477bbc1f3c28290;hb=HEAD;hpb=115593575b49ab252692a959380e94707e385de3 diff --git a/project.lisp b/project.lisp index ed1ef48..7532273 100644 --- a/project.lisp +++ b/project.lisp @@ -15,29 +15,29 @@ (in-package #:wol) (defun wol-project (name &key (project-prefix "/") map index - (sessions t) (session-lifetime 18000) - (reap-interval 300) server - (connector :modlisp) - timeout) + (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*)))) - + (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) @@ -45,7 +45,7 @@ (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)) (ecase connector @@ -53,16 +53,16 @@ (setf (ml::processor server) 'wol-ml-processor)) (:aserve (net.aserve:publish-prefix :prefix project-prefix - :server server - :function 'wol-aserve-processor - :timeout timeout))) - + :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 (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*)) @@ -71,67 +71,67 @@ (defun wol-ml-processor (command) "Processes an incoming modlisp command" (let* ((req (command->request command - :ml-server *ml-server*)) - (ent (make-entity-for-request req))) + :ml-server *ml-server*)) + (ent (make-entity-for-request req))) (if ent - (dispatch-request req ent) - (no-url-handler req 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) + (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))) + '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 - :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))) + (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))) + (setf (request-decoded-uri-path req) (puri:uri-path it))) req)) (defun header-slot-value (req slot) @@ -139,52 +139,52 @@ (defun command->uri (command) (format nil "http://~A:~D~A" - (header-value command :host) - (header-value command :server-ip-port) - (header-value command :url))) + (header-value command :host) + (header-value command :server-ip-port) + (header-value command :url))) (defun is-index-request (req ent) (string= (request-decoded-uri-path req) - (project-prefix (entity-project ent)))) + (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)))) + (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 - )))))) + (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))) + (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)))))) + (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))))) @@ -193,28 +193,28 @@ (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))))) + (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 make-entity-for-request (req) (awhen (find-project-for-request req) - (make-entity :project it))) + (make-entity :project it))) (defun find-project-for-request (req) (maphash (lambda (name project) - (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*)) + (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" @@ -222,36 +222,45 @@ (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) + (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 req ent)) - (cons - (redirect-entity (car next-page) req ent (cadr next-page))) - (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) @@ -271,26 +280,26 @@ (defun request-query (req &key (uri t) (post t)) (aif (aserve-request req) (alist-key->keyword - (net.aserve:request-query it :uri uri :post post)) + (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)))))))))) + ;; 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)))) - + :test 'equal)))) + (defun websession-variable (ws name) (when ws (gethash name (websession-variables ws)))) @@ -301,85 +310,85 @@ (defmacro with-wol-page ((req ent - &key (format :html) (precompute t) headers - (response-code 200) - timeout) - &body body) + &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))) + (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))) - + :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) + &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-"))) + (precomp (gensym "PRE-")) + (result (gensym "RES-")) + (outstr (gensym "STR-")) + (stream (gensym "STRM-")) + (hdr (gensym "HDR-"))) `(let ((,fmt ,format) - (,precomp ,precompute) - ,result ,outstr ,stream) + (,precomp ,precompute) + ,result ,outstr ,stream) (declare (ignorable ,stream)) (write-header-line "Status" ,response-string) - (write-header-line "Content-Type" (ml::format-string ,fmt)) + (write-header-line "Content-Type" (ml::format->string ,fmt)) (dolist (,hdr ,headers) - (write-header-line (car ,hdr) (cdr ,hdr))) + (write-header-line (car ,hdr) (cdr ,hdr))) (unless ,precomp - (write-string "end" *wol-stream*) - (write-char #\NewLine *wol-stream*)) + (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))))) + (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))) + (,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))) @@ -392,8 +401,8 @@ (:body (:h1 "Not Found") (:p "The request for " - (:b (:write-string (render-uri (request-uri req) nil))) - " was not found on this server.") + (:b (:write-string (render-uri (request-uri req) nil))) + " was not found on this server.") (:hr) (:div (:i "WOL " - (:write-string (wol-version-string))))))))) + (:write-string (wol-version-string)))))))))