(counter :initform 0 :accessor counter)
(prefix :initform "/" :accessor prefix)
(sessions :initform nil :accessor sessions)))
-
+
(defclass websession ()
((key :initarg :key :accessor websession-key)
(lastref :initarg :lastref :accessor websession-lastref)
(lifetime :initarg :lifetime :initform nil
- :accessor websession-lifetime)
+ :accessor websession-lifetime)
(data :initform nil :accessor websession-data)
(method :initarg :method :accessor websession-method :initform nil)
(variables :initform (make-hash-table :test 'equal)
- :accessor websession-variables)))
-
+ :accessor websession-variables)))
+
(defclass wol-project ()
((name :initarg :name :initform "" :type string :accessor project-name)
(project-prefix :initarg :project-prefix :type string
- :initform "/" :accessor project-prefix)
+ :initform "/" :accessor project-prefix)
(map :initarg :map :initform nil :type list :accessor project-map)
(hash :initarg :hash :initform nil :accessor project-hash-map)
- (index :initarg :index :initform "index" :type string
- :accessor project-index)
+ (index :initarg :index :initform "index" :type string
+ :accessor project-index)
(server :initarg :server :initform nil :accessor project-server)
(session-master :initform (make-instance 'session-master)
- :accessor session-master)
+ :accessor session-master)
(connector :initarg :connector :accessor project-connector)))
(defclass entity ()
((project :initarg :project :accessor entity-project)
(generators :initarg :generators :accessor entity-generators
- :documentation "List of waiting page generators")
+ :documentation "List of waiting page generators")
(aserve-entity :initarg :aserve-entity :initform nil
- :accessor entity-aserve-entity)))
+ :accessor entity-aserve-entity)))
(defclass http-request ()
((method :initarg :method :accessor request-method)
(uri :initarg :uri :accessor request-uri)
(decoded-uri-path :initarg :decoded-uri-path
- :accessor request-decoded-uri-path)
+ :accessor request-decoded-uri-path)
(raw-request :initarg :raw-request :accessor request-raw-request)
(raw-uri :initarg :raw-uri :accessor request-raw-uri)
(protocol :initarg :protocol :reader request-protocol)
(aserve-server :initarg :aserve-server :reader request-aserve-server)
(host :initarg :host :accessor request-host)
(desired-query :initform nil :accessor request-desired-query
- :documentation "type of query alist requested")
+ :documentation "type of query alist requested")
(posted-content :initarg :posted-content :accessor request-posted-content)
(headers :initarg :headers :accessor request-headers)
(page :initarg :page :initform nil :accessor request-page)
(url-plist :initarg :url-plist :initform nil :accessor request-url-plist)
(plist :initarg :plist :initform nil :accessor request-plist)
- (url-next-plists :initarg :url-next-plists :initform nil
- :accessor request-url-next-plists)
- (uri-query :initarg :uri-query :initform nil
- :accessor request-uri-query)
- (query-alist :initarg :query-alist :initform nil
- :accessor request-query-alist)
+ (url-next-plists :initarg :url-next-plists :initform nil
+ :accessor request-url-next-plists)
+ (uri-query :initarg :uri-query :initform nil
+ :accessor request-uri-query)
+ (query-alist :initarg :query-alist :initform nil
+ :accessor request-query-alist)
(session :initarg :session :initform nil
- :accessor websession-from-req)
+ :accessor websession-from-req)
(aserve-request :initarg :aserve-request :initform nil
- :accessor aserve-request)
+ :accessor aserve-request)
))
(defvar *reap-interval* 300)
-(defvar *reaper-process* nil)
+(defvar *reaper-process* nil)
(defvar *active-projects* (make-hash-table :test 'equal))
(flet ((color-td (r g b)
(let ((color (format nil "#~2,'0x~2,'0x~2,'0x" r g b)))
(html ((:td :bgcolor color
- :fformat (:onclick "f42('~a');"
- color))" ")))))
+ :fformat (:onclick "f42('~a');"
+ color))" ")))))
(let* ((colors nil))
(dotimes (r 6)
(dotimes (g 6)
(dotimes (b 6)
(push (list (* r 51) (* g 51) (* b 51)(luminance r g b))
- colors))))
+ colors))))
(setf colors (sort colors #'> :key 'fourth))
(html
(:head
:br
((:div :align "center")
((:a :class "call" :href "javascript:window.close();")
- "Close")))))))
+ "Close")))))))
(defmacro def-stdsite-header (site &body body)
`(setf (gethash ',site *header-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro def-stdsite-footer (site &body body)
`(setf (gethash ',site *footer-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro def-stdsite-banner (site &body body)
`(setf (gethash ',site *banner-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro def-stdsite-contents (site &body body)
`(setf (gethash ',site *contents-table*)
- #'(lambda (plist command)
- (declare (ignorable plist command))
- ,@body)))
+ #'(lambda (plist command)
+ (declare (ignorable plist command))
+ ,@body)))
(defmacro gen-std-head (title site plist command &body body)
`(html
- (:head
+ (:head
(when ,title
(html (:title ,title)))
(maybe-gen-header ',site ,plist ,command)
(html
((:div class "stdbodytable")
((:div :style "width:160px;position:fixed;left:3;right:auto;top:0")
- ((:img :src "/images/umlisp-logo.png" :alt "logo"
- :style "border:0;width:160;height:55"))
+ ((:img :src "/images/umlisp-logo.png" :alt "logo"
+ :style "border:0;width:160;height:55"))
(maybe-gen-contents ',site ,plist ,command))
((:div :style "position:absolute;left:170px;top:0")
((:div :style
- "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
- "High Performance Common Lisp Interface to the Unified Medical Langauge System")
+ "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
+ "High Performance Common Lisp Interface to the Unified Medical Langauge System")
,@body
- (gen-std-footer ,site ,plist ,command))))))
+ (gen-std-footer ,site ,plist ,command))))))
(defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss)
(when altcss
(html
((:link :rel "stylesheet" :type "text/css"
- :href (if (eq altcss t)
- "http://b9.com/umls.css" altcss)))))
+ :href (if (eq altcss t)
+ "http://b9.com/umls.css" altcss)))))
(when title-str
(html (:title (lml-write-string title-str)))))))
(:xml
(dtd-prologue format)
(lml-format "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
- (aif css it "http://b9.com/umlsxml.css"))
+ (aif css it "http://b9.com/umlsxml.css"))
(lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
(lml-write-char #\Newline)
(when title
(defun page-keyword-format (format)
(ecase format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
- :xhtml10-frameset)
+ :xhtml10-frameset)
:html)
(:xml
:xml)
:text)))
(defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
- &rest body)
+ &rest body)
(let ((fmt (gensym "FMT-")))
`(let ((,fmt ,format))
(with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
- (let ((*html-stream* *modlisp-socket*))
- (prog1
- (progn
- (page-prologue ,title ,format ,css ,altcss)
- ,@body)
- (page-epilogue ,format)))))))
+ (let ((*html-stream* *modlisp-socket*))
+ (prog1
+ (progn
+ (page-prologue ,title ,format ,css ,altcss)
+ ,@body)
+ (page-epilogue ,format)))))))
(defmacro gen-std-page ((site plist command title &key css altcss
- (precompute t) (format :xhtml))
- &body body)
+ (precompute t) (format :xhtml))
+ &body body)
`(let ((*print-circle* nil))
(with-lml-page (,title :css ,css :altcss ,altcss :format ,format
- :precompute ,precompute)
+ :precompute ,precompute)
(gen-std-body ,site ,plist ,command ,@body))))
,@body
(lml-princ "</html:a>"))
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
- :xhtml10-frameset)
+ :xhtml10-frameset)
(lml-princ "<a href=\"")
(lml-princ ,href)
(lml-princ "\">")
(defun ml-link (page name session-id &key (format :html))
(case format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
- :xhtml10-frameset)
+ :xhtml10-frameset)
(html
((:div class "homelink")
"Return to "
(with-ml-link ((make-ml-url page :session-id session-id :html t))
- (lml-write-string name))
+ (lml-write-string name))
" page.")))
((:xml :ie-xml)
(lml-princ "<homelink>Return to ")
(with-ml-link ((make-ml-url page :session-id session-id :html t)
- :format format)
+ :format format)
(lml-write-string name))
(lml-write-string " page.</homelink>"))))
(defpackage #:wol
(:use #:kmrcl #:hyperobject #:common-lisp
- #:lml2 #:cl-base64 #:modlisp #:puri)
+ #:lml2 #:cl-base64 #:modlisp #:puri)
(:export
;; classes.lisp
#:request-url-next-plists
#:request-posted-content
#:request-raw-uri
-
+
;; projects.lisp
#:wol-project
#:header-slot-value
#:request-query-value
#:websession-variable
#:with-wol-page
-
+
;; sessions.lisp
;; uri.lisp
)
(:shadowing-import-from #+allegro :mp #-allegro :acl-compat-mp
- :with-process-lock :make-process-lock
- :process-kill :process-run-function
- )
+ :with-process-lock :make-process-lock
+ :process-kill :process-run-function
+ )
)
(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)
(let ((hash (make-hash-table :size (length map) :test 'equal)))
(dolist (map-item map)
- (setf (gethash (first map-item) hash) (cdr map-item)))
+ (setf (gethash (first map-item) hash) (cdr map-item)))
(setf (project-hash-map project) hash))
(ecase connector
(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*))
(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)
(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 ".b9.com"
+ :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)))))
(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"
(defun dispatch-to-handler (req ent)
(let ((handlers (request-find-handlers req ent))
- (*wol-stream* (request-socket req)))
+ (*wol-stream* (request-socket req)))
(if handlers
- (handle-request handlers req ent)
+ (handle-request handlers req ent)
(no-url-handler req ent))))
(defun request-find-handlers (req ent)
- (nth-value 0 (gethash (request-page req)
- (project-hash-map (entity-project ent)))))
+ (nth-value 0 (gethash (request-page req)
+ (project-hash-map (entity-project ent)))))
(defun handle-request (handlers req ent)
(typecase handlers
(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))
(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))))
+ (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)
(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))))
(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))
(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)))
(: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)))))))))
(lambda (k v)
(declare (ignore k))
(when (equal key (websession-key v))
- (setf (websession-lastref v) (get-universal-time))
- (return-from find-websession v)))
+ (setf (websession-lastref v) (get-universal-time))
+ (return-from find-websession v)))
sessions)
nil))
(defun is-session-enabled (ent)
(not (null (sessions (session-master (entity-project ent))))))
-
+
(defun make-websession (req ent)
(let* ((key (random-string :length +length-session-id+
- :set :lower-alphanumeric))
- (sess (make-instance 'websession
- :key key
- :lastref (get-universal-time)
- :lifetime (lifetime (session-master (entity-project ent)))
- :method :try-cookie))
- (hash (sessions (session-master (entity-project ent)))))
+ :set :lower-alphanumeric))
+ (sess (make-instance 'websession
+ :key key
+ :lastref (get-universal-time)
+ :lifetime (lifetime (session-master (entity-project ent)))
+ :method :try-cookie))
+ (hash (sessions (session-master (entity-project ent)))))
(when hash
(setf (gethash key hash) sess)
(setf (websession-from-req req) sess)
(defun compute-session (req ent url-session-id)
(when (is-session-enabled ent)
(let* ((cookie-session-id (cookie-session-key ent (request-cookies req)))
- (session-id (or url-session-id cookie-session-id))
- (found-session (when session-id
- (find-websession session-id ent)))
- (session (aif found-session
- it
- (make-websession req ent))))
+ (session-id (or url-session-id cookie-session-id))
+ (found-session (when session-id
+ (find-websession session-id ent)))
+ (session (aif found-session
+ it
+ (make-websession req ent))))
(cond
- (cookie-session-id
- (setf (websession-method session) :cookies))
- (url-session-id
- (setf (websession-method session) :url)))
+ (cookie-session-id
+ (setf (websession-method session) :cookies))
+ (url-session-id
+ (setf (websession-method session) :url)))
(setf (websession-from-req req) session))))
-
+
;;; Reap expired sessions
(defun find-expired-sessions ()
(loop for s in (all-sessions)
- when (is-session-expired (car s))
- collect s))
+ when (is-session-expired (car s))
+ collect s))
(defun all-sessions (&aux s)
(maphash
(lambda (name proj)
(declare (ignore name))
(let* ((sm (session-master proj))
- (sessions (when sm (sessions sm))))
+ (sessions (when sm (sessions sm))))
(when sessions
- (maphash
- (lambda (k v)
- (declare (ignore k))
- (push (cons v proj) s))
- sessions))))
+ (maphash
+ (lambda (k v)
+ (declare (ignore k))
+ (push (cons v proj) s))
+ sessions))))
*active-projects*)
s)
(defmethod flush-expired (s)
(let ((sessions (sessions (session-master (cdr s)))))
(remhash (car s) sessions)
- (add-log-entry (cdr s) "flush expired session: key=~A"
- (websession-key (car s)))))
+ (add-log-entry (cdr s) "flush expired session: key=~A"
+ (websession-key (car s)))))
(defun is-session-expired (ws)
(> (get-universal-time) (+ (websession-lastref ws)
- (websession-lifetime ws))))
+ (websession-lifetime ws))))
(defun is-raw-session-id (str)
(and (stringp str)
(defpackage #:wol-tests
(:use #:xlunit #:cl #:wol #:puri #:lml2 #:kmrcl)
(:export #:do-tests #:*all-tests*))
-
+
(in-package #:wol-tests)
(eval-when (:compile-toplevel :load-toplevel :execute)
(import '(wol::req-recode-uri-sans-session-id wol::request-uri
- wol::request-decoded-uri-path wol::websession-from-req
- wol::websession-key wol::+length-session-id+
- wol::set-cookies-in-headers)))
+ wol::request-decoded-uri-path wol::websession-from-req
+ wol::websession-key wol::+length-session-id+
+ wol::set-cookies-in-headers)))
;; Keyed URL Tests
(defmethod set-up ((self test-keyed-url))
(let ((uri (parse-uri "/~abcdefg~/index.html")))
(setf (req self) (make-instance 'wol::http-request
- :raw-uri uri
- :decoded-uri-path (render-uri uri nil)
- :uri uri))
- (setf (ent self) (make-instance 'wol::entity
- :project (make-instance 'wol::wol-project
- :project-prefix "/")))))
+ :raw-uri uri
+ :decoded-uri-path (render-uri uri nil)
+ :uri uri))
+ (setf (ent self) (make-instance 'wol::entity
+ :project (make-instance 'wol::wol-project
+ :project-prefix "/")))))
(def-test-method test-returned-session ((self test-keyed-url) :run nil)
(assert-equal "abcdefg" (req-recode-uri-sans-session-id (req self)
- (ent self))))
-
+ (ent self))))
+
(def-test-method test-recomputed-uri ((self test-keyed-url) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (render-uri (request-uri (req self)) nil)
- "/index.html"))
+ "/index.html"))
(def-test-method test-decoded-uri ((self test-keyed-url) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (request-decoded-uri-path (req self))
- "/index.html"))
+ "/index.html"))
(defclass test-keyed-url-2 (test-case)
(defmethod set-up ((self test-keyed-url-2))
(let ((uri (parse-uri "/app/~abcdefg~/index.html")))
(setf (req self) (make-instance 'wol::http-request
- :raw-uri uri
- :decoded-uri-path (render-uri uri nil)
- :uri uri))
- (setf (ent self) (make-instance 'wol::entity
- :project (make-instance 'wol::wol-project
- :project-prefix "/app/")))))
+ :raw-uri uri
+ :decoded-uri-path (render-uri uri nil)
+ :uri uri))
+ (setf (ent self) (make-instance 'wol::entity
+ :project (make-instance 'wol::wol-project
+ :project-prefix "/app/")))))
(def-test-method test-returned-session ((self test-keyed-url-2) :run nil)
(assert-equal "abcdefg" (req-recode-uri-sans-session-id (req self)
- (ent self))))
-
+ (ent self))))
+
(def-test-method test-recomputed-uri ((self test-keyed-url-2) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (render-uri (request-uri (req self)) nil)
- "/app/index.html"))
+ "/app/index.html"))
(def-test-method test-decoded-uri ((self test-keyed-url-2) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (request-decoded-uri-path (req self))
- "/app/index.html"))
+ "/app/index.html"))
;;; Non-keyed URL tests
(defmethod set-up ((self test-non-keyed-url))
(let ((uri (parse-uri "/index.html")))
(setf (req self) (make-instance 'wol::http-request
- :raw-uri uri
- :decoded-uri-path (render-uri uri nil)
- :uri uri))
- (setf (ent self) (make-instance 'wol::entity
- :project (make-instance 'wol::wol-project
- :project-prefix "/")))))
+ :raw-uri uri
+ :decoded-uri-path (render-uri uri nil)
+ :uri uri))
+ (setf (ent self) (make-instance 'wol::entity
+ :project (make-instance 'wol::wol-project
+ :project-prefix "/")))))
(def-test-method test-returned-session ((self test-non-keyed-url) :run nil)
(assert-false (req-recode-uri-sans-session-id (req self) (ent self))))
-
+
(def-test-method test-recomputed-uri ((self test-non-keyed-url) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (render-uri (request-uri (req self)) nil)
- "/index.html"))
+ "/index.html"))
(def-test-method test-decoded-uri ((self test-non-keyed-url) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (request-decoded-uri-path (req self))
- "/index.html"))
+ "/index.html"))
(defclass test-non-keyed-url-2 (test-case)
((req :accessor req)
(defmethod set-up ((self test-non-keyed-url-2))
(let ((uri (parse-uri "/app1/index.html")))
(setf (req self) (make-instance 'wol::http-request
- :raw-uri uri
- :decoded-uri-path (render-uri uri nil)
- :uri uri))
- (setf (ent self) (make-instance 'wol::entity
- :project (make-instance 'wol::wol-project
- :project-prefix "/app1/")))))
+ :raw-uri uri
+ :decoded-uri-path (render-uri uri nil)
+ :uri uri))
+ (setf (ent self) (make-instance 'wol::entity
+ :project (make-instance 'wol::wol-project
+ :project-prefix "/app1/")))))
(def-test-method test-returned-session ((self test-non-keyed-url-2) :run nil)
(assert-false (req-recode-uri-sans-session-id (req self) (ent self))))
-
+
(def-test-method test-recomputed-uri ((self test-non-keyed-url-2) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (render-uri (request-uri (req self)) nil)
- "/app1/index.html"))
+ "/app1/index.html"))
(def-test-method test-decoded-uri ((self test-non-keyed-url-2) :run nil)
(req-recode-uri-sans-session-id (req self) (ent self))
(assert-equal (request-decoded-uri-path (req self))
- "/app1/index.html"))
+ "/app1/index.html"))
;;; Test server
))
(defmethod set-up ((self test-server))
- (setf (wserver self) (net.aserve:start :port (port self) :server :new))
+ (setf (wserver self) (net.aserve:start :port (port self) :server :new))
(setq net.aserve::*enable-logging* nil)
(wol-project (name self) :index "index" :connector :aserve
- :server (wserver self)))
-
+ :server (wserver self)))
+
(defmethod tear-down ((self test-server))
(net.aserve:shutdown :server (wserver self)))
(def-test-method test-server-index ((self test-server) :run nil)
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/")
- :port (port self)) nil)
- :redirect nil)
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/")
+ :port (port self)) nil)
+ :redirect nil)
(declare (ignore uri))
(assert-true (zerop (length body)))
(let ((redir (parse-uri
- (cdr (assoc "Location" headers :test #'string-equal)))))
+ (cdr (assoc "Location" headers :test #'string-equal)))))
(assert-equal (uri-path redir) "/index.html"))
(assert-equal response-code 307)
))
(def-test-method test-prefix-index-1 ((self test-server) :run nil)
(wol-project (name self) :index "index" :connector :aserve
- :project-prefix "/aprefix/" :server (wserver self))
+ :project-prefix "/aprefix/" :server (wserver self))
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/aprefix/")
- :port (port self)) nil)
- :redirect nil)
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/aprefix/")
+ :port (port self)) nil)
+ :redirect nil)
(declare (ignore uri))
(assert-equal "" body)
(let ((redir (parse-uri
- (cdr (assoc "Location" headers :test #'string-equal)))))
+ (cdr (assoc "Location" headers :test #'string-equal)))))
(assert-equal (uri-path redir) "/aprefix/index.html"))
(assert-equal response-code 307)))
(def-test-method test-prefix-index-2 ((self test-server) :run nil)
(wol-project (name self) :index "index" :connector :aserve
- :project-prefix "/aprefix/" :server (wserver self))
+ :project-prefix "/aprefix/" :server (wserver self))
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/ab")
- :port (port self)) nil)
- :redirect nil)
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/ab")
+ :port (port self)) nil)
+ :redirect nil)
(declare (ignore uri headers))
(assert-equal response-code 404)
(assert-true (plusp (length body))))
-
+
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/")
- :port (port self)) nil)
- :redirect nil)
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/")
+ :port (port self)) nil)
+ :redirect nil)
(declare (ignore uri headers))
(assert-true (plusp (length body)))
(assert-equal response-code 404))
-
+
)
))
(defmethod set-up ((self test-two-projects))
- (setf (wserver self) (net.aserve:start :port (port self) :server :new))
+ (setf (wserver self) (net.aserve:start :port (port self) :server :new))
(setq net.aserve::*enable-logging* nil)
(wol-project (name1 self) :index "index1" :connector :aserve
- :project-prefix (prefix1 self)
- :server (wserver self))
+ :project-prefix (prefix1 self)
+ :server (wserver self))
(wol-project (name2 self) :index "index2" :connector :aserve
- :project-prefix (prefix2 self)
- :server (wserver self))
- )
-
+ :project-prefix (prefix2 self)
+ :server (wserver self))
+ )
+
(defmethod tear-down ((self test-two-projects))
(net.aserve:shutdown :server (wserver self)))
(def-test-method test-two-project-index ((self test-two-projects) :run nil)
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/testprefix/")
- :port (port self)) nil)
- :redirect nil)
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/testprefix/")
+ :port (port self)) nil)
+ :redirect nil)
(declare (ignore uri))
(assert-true (zerop (length body)))
(let ((redir (parse-uri
- (cdr (assoc "Location" headers :test #'string-equal)))))
+ (cdr (assoc "Location" headers :test #'string-equal)))))
(assert-equal (uri-path redir) "/testprefix/index1.html"))
(assert-equal response-code 307))
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/prefixtest/")
- :port (port self)) nil)
- :redirect nil)
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/prefixtest/")
+ :port (port self)) nil)
+ :redirect nil)
(declare (ignore uri))
(assert-true (zerop (length body)))
(let ((redir (parse-uri
- (cdr (assoc "Location" headers :test #'string-equal)))))
+ (cdr (assoc "Location" headers :test #'string-equal)))))
(assert-equal (uri-path redir) "/prefixtest/index2.html"))
(assert-equal response-code 307)
))
))
(defmethod set-up ((self test-sessions))
- (setf (wserver self) (net.aserve:start :port (port self) :server :new))
+ (setf (wserver self) (net.aserve:start :port (port self) :server :new))
(setq net.aserve::*enable-logging* nil)
(wol-project (name self) :index "index" :connector :aserve
- :sessions t
- :map '(("index" test-sessions-index))
- :project-prefix (prefix self)
- :server (wserver self)))
-
+ :sessions t
+ :map '(("index" test-sessions-index))
+ :project-prefix (prefix self)
+ :server (wserver self)))
+
(defmethod tear-down ((self test-sessions))
(net.aserve:shutdown :server (wserver self)))
(let ((session (websession-from-req req)))
(with-wol-page (req ent)
(let ((url (make-wol-url "page" req ent)))
- (format *html-stream* "index~%")
- (format *html-stream* "~A~%" (websession-key session))
- (format *html-stream* "~A~%" url)
- ))))
+ (format *html-stream* "index~%")
+ (format *html-stream* "~A~%" (websession-key session))
+ (format *html-stream* "~A~%" url)
+ ))))
(def-test-method test-sessions ((self test-sessions) :run nil)
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/index.html")
- :port (port self)) nil))
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/index.html")
+ :port (port self)) nil))
(declare (ignore uri))
(assert-equal response-code 200)
(let ((cookies (set-cookies-in-headers headers)))
(assert-equal (first lines) "index")
(assert-equal (length (second lines)) +length-session-id+)
(assert-equal (third lines)
- (format nil "/~~~A~~/page.html" (second lines))))))
+ (format nil "/~~~A~~/page.html" (second lines))))))
;;; Test no sessions
))
(defmethod set-up ((self test-no-sessions))
- (setf (wserver self) (net.aserve:start :port (port self) :server :new))
+ (setf (wserver self) (net.aserve:start :port (port self) :server :new))
(setq net.aserve::*enable-logging* nil)
(wol-project (name self) :index "index" :connector :aserve
- :sessions nil
- :map '(("index" test-no-sessions-index))
- :project-prefix (prefix self)
- :server (wserver self)))
+ :sessions nil
+ :map '(("index" test-no-sessions-index))
+ :project-prefix (prefix self)
+ :server (wserver self)))
(defun test-no-sessions-index (req ent)
(let ((session (websession-from-req req)))
(with-wol-page (req ent)
(let ((url (make-wol-url "page" req ent)))
- (format *html-stream* "index~%")
- (format *html-stream* "~(~A~)~%" session)
- (format *html-stream* "~A~%" url)
- ))))
+ (format *html-stream* "index~%")
+ (format *html-stream* "~(~A~)~%" session)
+ (format *html-stream* "~A~%" url)
+ ))))
(defmethod tear-down ((self test-no-sessions))
(net.aserve:shutdown :server (wserver self)))
(def-test-method test-no-sessions ((self test-no-sessions) :run nil)
(multiple-value-bind (body response-code headers uri)
- (net.aserve.client:do-http-request
- (render-uri (copy-uri (parse-uri "http://localhost/index.html")
- :port (port self)) nil))
+ (net.aserve.client:do-http-request
+ (render-uri (copy-uri (parse-uri "http://localhost/index.html")
+ :port (port self)) nil))
(declare (ignore uri))
(assert-equal response-code 200)
(let ((cookies (set-cookies-in-headers headers)))
"Returns session-id,remainder-path"
(let ((prefix (project-prefix (entity-project ent))))
(when (and (> (length path) (length prefix))
- (string= prefix (subseq path 0 (length prefix))))
+ (string= prefix (subseq path 0 (length prefix))))
(let ((sans-prefix (subseq path (length prefix))))
- (when (char= #\~ (schar sans-prefix 0))
- (let* ((len (length sans-prefix))
- (next-tilde (position-char #\~ sans-prefix 1 len))
- (next-slash (position-char #\/ sans-prefix 1 len)))
- (when (and next-tilde next-slash
- (< next-tilde next-slash))
- (values
- (subseq sans-prefix 0 (1+ next-tilde))
- (subseq sans-prefix (1+ next-tilde))))))))))
+ (when (char= #\~ (schar sans-prefix 0))
+ (let* ((len (length sans-prefix))
+ (next-tilde (position-char #\~ sans-prefix 1 len))
+ (next-slash (position-char #\/ sans-prefix 1 len)))
+ (when (and next-tilde next-slash
+ (< next-tilde next-slash))
+ (values
+ (subseq sans-prefix 0 (1+ next-tilde))
+ (subseq sans-prefix (1+ next-tilde))))))))))
(defun req-recode-uri-sans-session-id (req ent)
- (multiple-value-bind (raw-session-id remainder)
+ (multiple-value-bind (raw-session-id remainder)
(path->session-id (request-decoded-uri-path req) ent)
(when raw-session-id
(let ((new-path (concatenate 'string (project-prefix
- (entity-project ent))
- (subseq remainder 1))))
- (setf (uri-path (request-uri req)) new-path)
- (setf (uri-path (request-raw-uri req)) new-path)
- (setf (request-decoded-uri-path req) new-path))
- (raw-session-id->session-id raw-session-id))))
+ (entity-project ent))
+ (subseq remainder 1))))
+ (setf (uri-path (request-uri req)) new-path)
+ (setf (uri-path (request-raw-uri req)) new-path)
+ (setf (request-decoded-uri-path req) new-path))
+ (raw-session-id->session-id raw-session-id))))
(defun request-cookies (req)
(aif (aserve-request req)
- (net.aserve:get-cookie-values it)
- (loop for h in (request-headers req)
- when (eq :cookie (car h))
- collect (cdr h))))
+ (net.aserve:get-cookie-values it)
+ (loop for h in (request-headers req)
+ when (eq :cookie (car h))
+ collect (cdr h))))
(defun header-lines-matching (key headers)
(loop for hdr in headers
(defun entity-project-prefix-string (ent)
(let ((prefix (project-prefix (entity-project ent))))
(if (= 1 (length prefix))
- ""
+ ""
(subseq prefix 1 (1- (length prefix))))))
(defun compute-uris (req ent)
"Compute URI's of a request"
(let* ((url-session-id (req-recode-uri-sans-session-id req ent))
- (uri (request-raw-uri req))
- (ppath (puri:uri-parsed-path uri))
- (prefix-string (entity-project-prefix-string ent)))
-
+ (uri (request-raw-uri req))
+ (ppath (puri:uri-parsed-path uri))
+ (prefix-string (entity-project-prefix-string ent)))
+
(assert (eq (first ppath) :absolute))
-
+
(cond
((zerop (length prefix-string))
;; strip :absolute
(t
(warn "Non-prefix path ~S" ppath)
(return-from compute-uris nil)))
-
+
(compute-session req ent url-session-id)
(multiple-value-bind (page plists) (decode-url ppath)
(when page
- (setf (request-page req) (base-page-name page)))
+ (setf (request-page req) (base-page-name page)))
(when plists
- (setf (request-url-plist req) (car plists))
- (setf (request-url-next-plists req) (cdr plists))
- (when (null page)
- (awhen (getf (request-url-plist req) :page)
- (setf (request-page req) it))))
+ (setf (request-url-plist req) (car plists))
+ (setf (request-url-next-plists req) (cdr plists))
+ (when (null page)
+ (awhen (getf (request-url-plist req) :page)
+ (setf (request-page req) it))))
(setf (request-uri-query req) (puri:uri-query uri)))))
-
+
;;; URI Functions
(when (is-raw-session-id (car ppath))
(setq ppath (cdr ppath)))
(let* ((plists '())
- (page-name (unless (is-plist-header (car ppath))
- (prog1
- (car ppath)
- (setq ppath (cdr ppath))))))
+ (page-name (unless (is-plist-header (car ppath))
+ (prog1
+ (car ppath)
+ (setq ppath (cdr ppath))))))
(dolist (elem ppath)
(if (is-plist-header elem)
- (push (url-string-to-plist (subseq elem +plist-header-length+))
- plists)
- (warn "Non plist header found in url ~S" elem)))
+ (push (url-string-to-plist (subseq elem +plist-header-length+))
+ plists)
+ (warn "Non plist header found in url ~S" elem)))
(values page-name (nreverse plists))))
(defun make-wol-url (page req ent &optional plist)
(let ((session (websession-from-req req))
- (url-plist (append (list :page page) plist))
- (prefix (project-prefix (entity-project ent))))
+ (url-plist (append (list :page page) plist))
+ (prefix (project-prefix (entity-project ent))))
(concatenate 'string
prefix
(if (and session
- (websession-key session)
- (not (eq :cookies (websession-method session))))
- (format nil "~~~A~~/" (websession-key session))
- "")
+ (websession-key session)
+ (not (eq :cookies (websession-method session))))
+ (format nil "~~~A~~/" (websession-key session))
+ "")
(if (null plist)
- (concatenate 'string page ".html")
- (concatenate 'string
- (concatenate 'string +plist-header+
- (plist-to-url-string url-plist)))))))
+ (concatenate 'string page ".html")
+ (concatenate 'string
+ (concatenate 'string +plist-header+
+ (plist-to-url-string url-plist)))))))
;; Property lists
(defun plist-to-url-string (plist &key (base64 t))
(let ((str (plist-to-compressed-string plist)))
(if base64
- (string-to-base64-string str :uri t)
- (encode-uri-string str))))
+ (string-to-base64-string str :uri t)
+ (encode-uri-string str))))
(defun url-string-to-plist (str &key (base64 t))
(let ((decode (if base64
- (base64-string-to-string str :uri t)
- (decode-uri-string str))))
+ (base64-string-to-string str :uri t)
+ (decode-uri-string str))))
(when decode
(ignore-errors (compressed-string-to-plist decode)))))
"Decode an encoded plist"
(assert (evenp (length plist)))
(do* ((output '())
- (list plist (cddr list)))
- ((null list)
- (prin1-to-string (nreverse output)))
+ (list plist (cddr list)))
+ ((null list)
+ (prin1-to-string (nreverse output)))
(push (compress-elem (car list)) output)
(push (cadr list) output)))
-
+
(defun compress-elem (elem)
"Encode a plist elem"
(:logged :g)
(:caller :c)
(:db :d)
-
+
;; For lookup-func1
(:func :f)
(:format :r)
(:labels :a)
(:subobjects :b)
(:english-only :e)
-
+
(:xml :x)
(:next-page :n)
-
+
(otherwise elem)))
(defun compressed-string-to-plist (encoded-str)
(let ((encoded (ignore-errors (read-from-string encoded-str)))
- (output '()))
+ (output '()))
(unless encoded
(cmsg "invalid encoded string")
#+ignore
nil)
(assert (evenp (length encoded)))
(do* ((elist encoded (cddr elist)))
- ((null elist) (nreverse output))
+ ((null elist) (nreverse output))
(push (decompress-elem (car elist)) output)
(push (cadr elist) output))))
(#\G :logged)
(#\C :caller)
(#\D :db)
-
+
;; For posting to lookup-func1
(#\F :func)
(#\K :key)
(#\A :labels)
(#\E :english-only)
(#\R :format)
-
+
(#\X :xml)
(#\P :page)
-
+
(otherwise elem))))
-
+
projects / wol.git / commitdiff