(multiple-value-bind (project found) (gethash name *active-projects*)
(unless found
(setq project (make-instance 'wol-project))
(setf (gethash name *active-projects*) project))
(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-name project) name)
(setf (project-prefix project) project-prefix)
(setf (project-map project) map)
(setf (project-server project) server)
(setf (project-connector project) connector)
(setf (lifetime (session-master project)) session-lifetime)
(setf (project-server project) server)
(setf (project-connector project) connector)
(setf (lifetime (session-master project)) session-lifetime)
- (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)))
(defun wol-ml-processor (command)
"Processes an incoming modlisp command"
(let* ((req (command->request command
(defun wol-ml-processor (command)
"Processes an incoming modlisp command"
(let* ((req (command->request command
(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)
(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)
- '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)))
- (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)))
- (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 set-cookie (req ent)
(let ((session (websession-from-req req)))
(when (and session (websession-key session)
(defun set-cookie (req ent)
(let ((session (websession-from-req req)))
(when (and session (websession-key session)
- (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 ".b9.com"
+ :value (websession-key
+ (websession-from-req req))
+ :path "/"))
+ (:modlisp
+ ;; fixme
+ ))))))
- (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))))))
(defun make-entity (&key project)
(make-instance 'entity :project project))
(defun make-entity-for-request (req)
(awhen (find-project-for-request req)
(defun make-entity (&key project)
(make-instance 'entity :project project))
(defun make-entity-for-request (req)
(awhen (find-project-for-request req)
- (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*))
(let ((next-handler (first handlers)))
(setf (entity-generators ent) (cdr handlers))
(when (and (symbolp next-handler)
(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))
+ (not (fboundp next-handler)))
+ (cmsg "handler given a symbol without a function ~S" next-handler)
+ (return-from handle-request nil))
- (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))))
+ (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))))
- ;; 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)
(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)
- (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
(%with-wol-page (,req ,ent :format ,format :precompute ,precompute
- (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-")))
- (,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))
(dolist (,hdr ,headers)
(declare (ignorable ,stream))
(write-header-line "Status" ,response-string)
(write-header-line "Content-Type" (ml::format->string ,fmt))
(dolist (,hdr ,headers)
- (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)))))
- (,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)))