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.7 2003/08/09 21:42:24 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)
19 (let ((ppath (puri:uri-parsed-path (request-uri req))))
20 (when (is-raw-session-id (second ppath))
21 (let ((new-path (list* (car ppath) (cddr ppath))))
22 (setf (uri-parsed-path (request-uri req)) new-path)
23 (setf (uri-parsed-path (request-raw-uri req)) new-path))
24 (setf (request-decoded-uri-path req)
25 (uridecode-string (uri-path (request-raw-uri req))))
26 (raw-session-id->session-id (second ppath)))))
28 (defun request-cookies (req)
29 (aif (aserve-request req)
30 (net.aserve:get-cookie-values it)
31 (loop for h in (request-headers req)
32 when (eq :cookie (car h))
35 (defun cookie-session-key (ent cookies)
36 (let ((name (project-name (entity-project ent))))
37 (cdr (assoc name cookies :test #'string-equal))))
39 (defun compute-uris (req ent)
40 "Compute URI's of a request"
41 (let ((url-session-id (req-recode-uri-sans-session-id req)))
42 (compute-session req ent url-session-id)
44 (multiple-value-bind (page plists query)
45 (decode-url (puri:uri-path (request-raw-uri req)))
47 (setf (request-page req) (base-page-name page ent)))
49 (setf (request-plist req) (car plists))
50 (setf (request-next-plists req) (cdr plists))
52 (awhen (getf (request-plist req) :page)
53 (setf (request-page req) it))))
54 (setf (request-uri-query req) query))))
59 (defun base-page-name (page ent)
60 "Return the base page name for a html url"
61 (let ((len-prefix (length (project-prefix (entity-project ent)))))
62 (assert (>= (length page) len-prefix))
63 (string-strip-ending (subseq page len-prefix)
66 (defun split-plist-url (url)
67 (string-delimited-string-to-list url +plist-header+))
69 (defun decode-url (url)
70 "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
72 (qsplit (delimited-string-to-list url #\?))
74 (split (split-plist-url (car qsplit)))
76 (when (and (plusp (length (car split)))
77 (not (string= +full-asp-header+ (car split)))
78 (not (string-starts-with +full-asp-header+ (car split))))
80 (dolist (elem (cdr split))
81 (push (url-string-to-plist elem) plists))
82 (values page-name (nreverse plists) query)))
86 (defun make-wol-url (page req ent &optional plist)
87 (let ((session (websession-from-req req))
88 (url-plist (append (list :page page) plist))
89 (prefix (project-prefix (entity-project ent))))
93 (websession-key session)
94 (not (eq :cookies (websession-method session))))
95 (format nil "~~~A~~/" (websession-key session))
98 (concatenate 'string page ".html")
101 (concatenate 'string +plist-header+
102 (plist-to-url-string url-plist)))))))
107 (defun plist-to-url-string (plist &key (base64 t))
108 (let ((str (plist-to-compressed-string plist)))
110 (string-to-base64-string str :uri t)
111 (uriencode-string str))))
113 (defun url-string-to-plist (str &key (base64 t))
114 (let ((decode (if base64
115 (base64-string-to-string str :uri t)
116 (uridecode-string str))))
118 (ignore-errors (compressed-string-to-plist decode)))))
120 (defun plist-to-compressed-string (plist)
121 "Decode an encoded plist"
122 (assert (evenp (length plist)))
124 (list plist (cddr list)))
126 (prin1-to-string (nreverse output)))
127 (push (compress-elem (car list)) output)
128 (push (cadr list) output)))
130 (defun compress-elem (elem)
131 "Encode a plist elem"
155 (defun compressed-string-to-plist (encoded-str)
156 (let ((encoded (ignore-errors (read-from-string encoded-str)))
159 (cmsg "invalid encoded string")
161 (gen-invalid-encoded-str encoded-str)
163 (assert (evenp (length encoded)))
164 (do* ((elist encoded (cddr elist)))
165 ((null elist) (nreverse output))
166 (push (decompress-elem (car elist)) output)
167 (push (cadr elist) output))))
169 (defun decompress-elem (elem)
180 ;; For posting to lookup-func1