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
12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
17 (defun path->session-id (path ent)
18 "Returns session-id,remainder-path"
19 (let ((prefix (project-prefix (entity-project ent))))
20 (when (and (> (length path) (length prefix))
21 (string= prefix (subseq path 0 (length prefix))))
22 (let ((sans-prefix (subseq path (length prefix))))
23 (when (char= #\~ (schar sans-prefix 0))
24 (let* ((len (length sans-prefix))
25 (next-tilde (position-char #\~ sans-prefix 1 len))
26 (next-slash (position-char #\/ sans-prefix 1 len)))
27 (when (and next-tilde next-slash
28 (< next-tilde next-slash))
30 (subseq sans-prefix 0 (1+ next-tilde))
31 (subseq sans-prefix (1+ next-tilde))))))))))
34 (defun req-recode-uri-sans-session-id (req ent)
35 (multiple-value-bind (raw-session-id remainder)
36 (path->session-id (request-decoded-uri-path req) ent)
38 (let ((new-path (concatenate 'string (project-prefix
40 (subseq remainder 1))))
41 (setf (uri-path (request-uri req)) new-path)
42 (setf (uri-path (request-raw-uri req)) new-path)
43 (setf (request-decoded-uri-path req) new-path))
44 (raw-session-id->session-id raw-session-id))))
46 (defun request-cookies (req)
47 (aif (aserve-request req)
48 (net.aserve:get-cookie-values it)
49 (loop for h in (request-headers req)
50 when (eq :cookie (car h))
53 (defun header-lines-matching (key headers)
54 (loop for hdr in headers
55 when (eq key (car hdr))
58 (defun set-cookies-in-headers (headers)
59 (header-lines-matching :set-cookie headers))
61 (defun cookies-in-headers (headers)
62 (header-lines-matching :cookie headers))
64 (defun cookie-session-key (ent cookies)
65 "Return the session key from the alist of cookies"
66 (let ((name (project-name (entity-project ent))))
67 (cdr (assoc name cookies :test #'string-equal))))
69 (defun entity-project-prefix-string (ent)
70 (let ((prefix (project-prefix (entity-project ent))))
71 (if (= 1 (length prefix))
73 (subseq prefix 1 (1- (length prefix))))))
75 (defun compute-uris (req ent)
76 "Compute URI's of a request"
77 (let* ((url-session-id (req-recode-uri-sans-session-id req ent))
78 (uri (request-raw-uri req))
79 (ppath (puri:uri-parsed-path uri))
80 (prefix-string (entity-project-prefix-string ent)))
82 (assert (eq (first ppath) :absolute))
85 ((zerop (length prefix-string))
87 (setq ppath (cdr ppath)))
88 ((string-equal (second ppath) (entity-project-prefix-string ent))
89 (setq ppath (cddr ppath)))
91 (warn "Non-prefix path ~S" ppath)
92 (return-from compute-uris nil)))
94 (compute-session req ent url-session-id)
95 (multiple-value-bind (page plists) (decode-url ppath)
97 (setf (request-page req) (base-page-name page)))
99 (setf (request-url-plist req) (car plists))
100 (setf (request-url-next-plists req) (cdr plists))
102 (awhen (getf (request-url-plist req) :page)
103 (setf (request-page req) it))))
104 (setf (request-uri-query req) (puri:uri-query uri)))))
109 (defun base-page-name (page)
110 "Return the base page name for a html url"
111 (string-strip-ending page '(".html" ".lsp")))
113 (defun split-plist-url (url)
114 (string-delimited-string-to-list url +plist-header+))
116 (defun is-plist-header (str)
117 (string= +plist-header+ (subseq str 0 +plist-header-length+)))
119 (defun decode-url (ppath)
120 "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
121 (when (is-raw-session-id (car ppath))
122 (setq ppath (cdr ppath)))
124 (page-name (unless (is-plist-header (car ppath))
127 (setq ppath (cdr ppath))))))
129 (if (is-plist-header elem)
130 (push (url-string-to-plist (subseq elem +plist-header-length+))
132 (warn "Non plist header found in url ~S" elem)))
133 (values page-name (nreverse plists))))
137 (defun make-wol-url (page req ent &optional plist)
138 (let ((session (websession-from-req req))
139 (url-plist (append (list :page page) plist))
140 (prefix (project-prefix (entity-project ent))))
144 (websession-key session)
145 (not (eq :cookies (websession-method session))))
146 (format nil "~~~A~~/" (websession-key session))
149 (concatenate 'string page ".html")
151 (concatenate 'string +plist-header+
152 (plist-to-url-string url-plist)))))))
157 (defun plist-to-url-string (plist &key (base64 t))
158 (let ((str (plist-to-compressed-string plist)))
160 (string-to-base64-string str :uri t)
161 (encode-uri-string str))))
163 (defun url-string-to-plist (str &key (base64 t))
164 (let ((decode (if base64
165 (base64-string-to-string str :uri t)
166 (decode-uri-string str))))
168 (ignore-errors (compressed-string-to-plist decode)))))
170 (defun plist-to-compressed-string (plist)
171 "Decode an encoded plist"
172 (assert (evenp (length plist)))
174 (list plist (cddr list)))
176 (prin1-to-string (nreverse output)))
177 (push (compress-elem (car list)) output)
178 (push (cadr list) output)))
181 (defun compress-elem (elem)
182 "Encode a plist elem"
206 (defun compressed-string-to-plist (encoded-str)
207 (let ((encoded (ignore-errors (read-from-string encoded-str)))
210 (cmsg "invalid encoded string")
212 (gen-invalid-encoded-str encoded-str)
214 (assert (evenp (length encoded)))
215 (do* ((elist encoded (cddr elist)))
216 ((null elist) (nreverse output))
217 (push (decompress-elem (car elist)) output)
218 (push (cadr elist) output))))
220 (defun decompress-elem (elem)
221 (if (> (length (symbol-name elem)) 1)
223 (case (char-upcase (schar (symbol-name elem ) 0))
233 ;; For posting to lookup-func1