-
-(defun request-decompile-uri (req ent)
- "returns (VALUE PAGE PLIST QUERY-ALIST)"
- (multiple-value-bind (page plists query)
- (decode-url (request-raw-uri req))
- (when page
- (setf (request-page req) (base-page-name page ent)))
- (when plists
- (setf (request-plist req) (car plists))
- (setf (request-next-plists req) (cdr plists))
- (when (null page)
- (awhen (getf (request-plist req) :page)
- (setf (request-page req) it))))
- (setf (request-uri-query req) query))
- req)
+(defun req-recode-uri-sans-session-id (req)
+ (let ((ppath (puri:uri-parsed-path (request-uri req))))
+ (when (is-raw-session-id (second ppath))
+ (let ((new-path (list* (car ppath) (cddr ppath))))
+ (setf (uri-parsed-path (request-uri req)) new-path)
+ (setf (uri-parsed-path (request-raw-uri req)) new-path))
+ (setf (request-decoded-uri-path req)
+ (uridecode-string (uri-path (request-raw-uri req))))
+ (raw-session-id->session-id (second ppath)))))
+
+(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))))
+
+(defun header-lines-matching (key headers)
+ (loop for hdr in headers
+ when (eq key (car hdr))
+ collect (cdr hdr)))
+
+(defun set-cookies-in-headers (headers)
+ (header-lines-matching :set-cookie headers))
+
+(defun cookies-in-headers (headers)
+ (header-lines-matching :cookie headers))
+
+(defun cookie-session-key (ent cookies)
+ "Return the session key from the alist of cookies"
+ (let ((name (project-name (entity-project ent))))
+ (cdr (assoc name cookies :test #'string-equal))))
+
+(defun compute-uris (req ent)
+ "Compute URI's of a request"
+ (let ((url-session-id (req-recode-uri-sans-session-id req)))
+ (compute-session req ent url-session-id)
+
+ (multiple-value-bind (page plists query)
+ (decode-url (puri:uri-path (request-raw-uri req)))
+ (when page
+ (setf (request-page req) (base-page-name page ent)))
+ (when plists
+ (setf (request-plist req) (car plists))
+ (setf (request-next-plists req) (cdr plists))
+ (when (null page)
+ (awhen (getf (request-plist req) :page)
+ (setf (request-page req) it))))
+ (setf (request-uri-query req) query))))