1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: URI functions for wol
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: July 2003
10 ;;;; $Id: uri.lisp,v 1.8 2003/08/10 05:16:52 kevin Exp $
12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
17 (defun req-recode-uri-sans-session-id (req)
18 (let ((ppath (puri:uri-parsed-path (request-uri req))))
19 (when (is-raw-session-id (second ppath))
20 (let ((new-path (list* (car ppath) (cddr ppath))))
21 (setf (uri-parsed-path (request-uri req)) new-path)
22 (setf (uri-parsed-path (request-raw-uri req)) new-path))
23 (setf (request-decoded-uri-path req)
24 (uridecode-string (uri-path (request-raw-uri req))))
25 (raw-session-id->session-id (second ppath)))))
27 (defun request-cookies (req)
28 (aif (aserve-request req)
29 (net.aserve:get-cookie-values it)
30 (loop for h in (request-headers req)
31 when (eq :cookie (car h))
34 (defun header-lines-matching (key headers)
35 (loop for hdr in headers
36 when (eq key (car hdr))
39 (defun set-cookies-in-headers (headers)
40 (header-lines-matching :set-cookie headers))
42 (defun cookies-in-headers (headers)
43 (header-lines-matching :cookie headers))
45 (defun cookie-session-key (ent cookies)
46 "Return the session key from the alist of cookies"
47 (let ((name (project-name (entity-project ent))))
48 (cdr (assoc name cookies :test #'string-equal))))
50 (defun compute-uris (req ent)
51 "Compute URI's of a request"
52 (let ((url-session-id (req-recode-uri-sans-session-id req)))
53 (compute-session req ent url-session-id)
55 (multiple-value-bind (page plists query)
56 (decode-url (puri:uri-path (request-raw-uri req)))
58 (setf (request-page req) (base-page-name page ent)))
60 (setf (request-plist req) (car plists))
61 (setf (request-next-plists req) (cdr plists))
63 (awhen (getf (request-plist req) :page)
64 (setf (request-page req) it))))
65 (setf (request-uri-query req) query))))
70 (defun base-page-name (page ent)
71 "Return the base page name for a html url"
72 (let ((len-prefix (length (project-prefix (entity-project ent)))))
73 (assert (>= (length page) len-prefix))
74 (string-strip-ending (subseq page len-prefix)
77 (defun split-plist-url (url)
78 (string-delimited-string-to-list url +plist-header+))
80 (defun decode-url (url)
81 "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
83 (qsplit (delimited-string-to-list url #\?))
85 (split (split-plist-url (car qsplit)))
87 (when (and (plusp (length (car split)))
88 (not (string= +full-asp-header+ (car split)))
89 (not (string-starts-with +full-asp-header+ (car split))))
91 (dolist (elem (cdr split))
92 (push (url-string-to-plist elem) plists))
93 (values page-name (nreverse plists) query)))
97 (defun make-wol-url (page req ent &optional plist)
98 (let ((session (websession-from-req req))
99 (url-plist (append (list :page page) plist))
100 (prefix (project-prefix (entity-project ent))))
104 (websession-key session)
105 (not (eq :cookies (websession-method session))))
106 (format nil "~~~A~~/" (websession-key session))
109 (concatenate 'string page ".html")
112 (concatenate 'string +plist-header+
113 (plist-to-url-string url-plist)))))))
118 (defun plist-to-url-string (plist &key (base64 t))
119 (let ((str (plist-to-compressed-string plist)))
121 (string-to-base64-string str :uri t)
122 (uriencode-string str))))
124 (defun url-string-to-plist (str &key (base64 t))
125 (let ((decode (if base64
126 (base64-string-to-string str :uri t)
127 (uridecode-string str))))
129 (ignore-errors (compressed-string-to-plist decode)))))
131 (defun plist-to-compressed-string (plist)
132 "Decode an encoded plist"
133 (assert (evenp (length plist)))
135 (list plist (cddr list)))
137 (prin1-to-string (nreverse output)))
138 (push (compress-elem (car list)) output)
139 (push (cadr list) output)))
141 (defun compress-elem (elem)
142 "Encode a plist elem"
166 (defun compressed-string-to-plist (encoded-str)
167 (let ((encoded (ignore-errors (read-from-string encoded-str)))
170 (cmsg "invalid encoded string")
172 (gen-invalid-encoded-str encoded-str)
174 (assert (evenp (length encoded)))
175 (do* ((elist encoded (cddr elist)))
176 ((null elist) (nreverse output))
177 (push (decompress-elem (car elist)) output)
178 (push (cadr elist) output))))
180 (defun decompress-elem (elem)
191 ;; For posting to lookup-func1