From cf7030dd6955c663f1f1422ff61c3aac41e4b8fa Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 31 Aug 2007 18:04:31 +0000 Subject: [PATCH] r11859: Canonicalize whitespace --- classes.lisp | 42 ++--- color-picker.lisp | 8 +- genpage.lisp | 72 ++++---- package.lisp | 12 +- project.lisp | 424 +++++++++++++++++++++++----------------------- sessions.lisp | 64 +++---- tests.lisp | 220 ++++++++++++------------ uri.lisp | 138 +++++++-------- 8 files changed, 490 insertions(+), 490 deletions(-) diff --git a/classes.lisp b/classes.lisp index a11e888..794cc57 100644 --- a/classes.lisp +++ b/classes.lisp @@ -21,44 +21,44 @@ (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) @@ -68,26 +68,26 @@ (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)) diff --git a/color-picker.lisp b/color-picker.lisp index 0e64c97..4b942b8 100644 --- a/color-picker.lisp +++ b/color-picker.lisp @@ -7,14 +7,14 @@ (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 @@ -44,5 +44,5 @@ f42(d){window.opener.change_color(d);window.close();};") :br ((:div :align "center") ((:a :class "call" :href "javascript:window.close();") - "Close"))))))) + "Close"))))))) diff --git a/genpage.lisp b/genpage.lisp index 4b1dbf4..451b04f 100644 --- a/genpage.lisp +++ b/genpage.lisp @@ -39,32 +39,32 @@ (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) @@ -82,15 +82,15 @@ (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) @@ -100,8 +100,8 @@ (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))))))) @@ -110,7 +110,7 @@ (:xml (dtd-prologue format) (lml-format "~%" - (aif css it "http://b9.com/umlsxml.css")) + (aif css it "http://b9.com/umlsxml.css")) (lml-write-string "") (lml-write-char #\Newline) (when title @@ -148,7 +148,7 @@ (defun page-keyword-format (format) (ecase format ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional - :xhtml10-frameset) + :xhtml10-frameset) :html) (:xml :xml) @@ -156,24 +156,24 @@ :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)))) @@ -194,7 +194,7 @@ ,@body (lml-princ "")) ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional - :xhtml10-frameset) + :xhtml10-frameset) (lml-princ "") @@ -204,17 +204,17 @@ (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 "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.")))) diff --git a/package.lisp b/package.lisp index eeb7a85..15b1d12 100644 --- a/package.lisp +++ b/package.lisp @@ -17,7 +17,7 @@ (defpackage #:wol (:use #:kmrcl #:hyperobject #:common-lisp - #:lml2 #:cl-base64 #:modlisp #:puri) + #:lml2 #:cl-base64 #:modlisp #:puri) (:export ;; classes.lisp @@ -31,7 +31,7 @@ #:request-url-next-plists #:request-posted-content #:request-raw-uri - + ;; projects.lisp #:wol-project #:header-slot-value @@ -39,7 +39,7 @@ #:request-query-value #:websession-variable #:with-wol-page - + ;; sessions.lisp ;; uri.lisp @@ -55,8 +55,8 @@ ) (: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 + ) ) diff --git a/project.lisp b/project.lisp index ea38c8a..fd2b4ab 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) (cdr 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 ".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))))) @@ -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" @@ -223,14 +223,14 @@ (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 @@ -241,25 +241,25 @@ (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) @@ -280,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)))) @@ -310,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)) (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))) @@ -401,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))))))))) diff --git a/sessions.lisp b/sessions.lisp index 727ad4b..6c63e04 100644 --- a/sessions.lisp +++ b/sessions.lisp @@ -21,24 +21,24 @@ (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) @@ -48,19 +48,19 @@ (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 @@ -76,33 +76,33 @@ (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) diff --git a/tests.lisp b/tests.lisp index a946f79..bbcb3b6 100644 --- a/tests.lisp +++ b/tests.lisp @@ -12,14 +12,14 @@ (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 @@ -31,26 +31,26 @@ (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) @@ -60,26 +60,26 @@ (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 @@ -90,25 +90,25 @@ (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) @@ -117,25 +117,25 @@ (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 @@ -146,11 +146,11 @@ )) (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))) @@ -158,57 +158,57 @@ (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)) - + ) @@ -224,41 +224,41 @@ )) (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) )) @@ -274,14 +274,14 @@ )) (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))) @@ -290,16 +290,16 @@ (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))) @@ -309,7 +309,7 @@ (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 @@ -322,31 +322,31 @@ )) (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))) diff --git a/uri.lisp b/uri.lisp index dbcc1a9..d86e128 100644 --- a/uri.lisp +++ b/uri.lisp @@ -18,37 +18,37 @@ "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 @@ -69,18 +69,18 @@ (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 @@ -90,19 +90,19 @@ (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 @@ -121,35 +121,35 @@ (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 @@ -157,13 +157,13 @@ (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))))) @@ -171,12 +171,12 @@ "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" @@ -189,7 +189,7 @@ (:logged :g) (:caller :c) (:db :d) - + ;; For lookup-func1 (:func :f) (:format :r) @@ -197,15 +197,15 @@ (: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 @@ -213,7 +213,7 @@ 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)))) @@ -229,7 +229,7 @@ (#\G :logged) (#\C :caller) (#\D :db) - + ;; For posting to lookup-func1 (#\F :func) (#\K :key) @@ -237,15 +237,15 @@ (#\A :labels) (#\E :english-only) (#\R :format) - + (#\X :xml) (#\P :page) - + (otherwise elem)))) - + -- 2.34.1