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.1 2003/07/16 16:02:21 kevin Exp $
12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
18 (defun request-decompile-uri (req ent)
19 "returns (VALUE PAGE PLIST QUERY-ALIST)"
20 (multiple-value-bind (page plists query)
21 (decode-url (request-raw-uri req))
23 (setf (request-page req) (base-page-name page ent)))
25 (setf (request-plist req) (car plists))
26 (setf (request-next-plists req) (cdr plists))
28 (awhen (getf (request-plist req) :page)
29 (setf (request-page req) it))))
30 (setf (request-uri-query req) query))
36 (defun base-page-name (page ent)
37 "Return the base page name for a html url"
38 (let ((len-prefix (length (project-prefix (entity-project ent)))))
39 (assert (>= (length page) len-prefix))
40 (string-strip-ending (subseq page len-prefix)
43 (defun split-plist-url (url)
44 (string-delimited-string-to-list url +plist-header+))
46 (defun decode-url (url)
47 "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
49 (qsplit (delimited-string-to-list url #\?))
51 (split (split-plist-url (car qsplit)))
53 (when (and (plusp (length (car split)))
54 (not (string= +full-asp-header+ (car split)))
55 (not (string-starts-with +full-asp-header+ (car split))))
57 (dolist (elem (cdr split))
58 (push (url-string-to-plist elem) plists))
59 (values page-name (nreverse plists) query)))
63 (defun make-html-url (page ent &optional query-args)
64 (make-url (concatenate 'string page ".html")
65 :base-dir (project-prefix
67 :vars query-args :format :xhtml))
69 (defvar *unspecified* (cons :unspecified nil))
71 (defun make-wol-url (page ent
72 &key (session-id *unspecified*)
73 (object-id *unspecified*)
74 (func *unspecified*) (key *unspecified*)
75 (subobjects *unspecified*) (labels *unspecified*)
76 (english-only *unspecified*)
77 (format *unspecified*)
78 (lang *unspecified*) (logged *unspecified*)
79 (next-page *unspecified*) (caller *unspecified*)
81 (let ((plist (list :page page))
82 (prefix (project-prefix (entity-project ent))))
83 (unless (eq session-id *unspecified*)
84 (setq plist (append plist (list :session-id session-id))))
85 (unless (eq object-id *unspecified*)
86 (setq plist (append plist (list :object-id object-id))))
87 (unless (eq lang *unspecified*)
88 (setq plist (append plist (list :lang lang))))
89 (unless (eq logged *unspecified*)
90 (setq plist (append plist (list :logged logged))))
91 (unless (eq func *unspecified*)
92 (setq plist (append plist (list :func func))))
93 (unless (eq subobjects *unspecified*)
94 (setq plist (append plist (list :subobjects subobjects))))
95 (unless (eq key *unspecified*)
96 (setq plist (append plist (list :key key))))
97 (unless (eq labels *unspecified*)
98 (setq plist (append plist (list :labels labels))))
99 (unless (eq english-only *unspecified*)
100 (setq plist (append plist (list :english-only english-only))))
101 (unless (eq next-page *unspecified*)
102 (setq plist (append plist (list :next-page next-page))))
103 (unless (eq format *unspecified*)
104 (setq plist (append plist (list :format format))))
105 (unless (eq caller *unspecified*)
106 (setq plist (append plist (list :caller caller))))
108 (parameters-null session-id object-id lang logged func subobjects
109 key labels english-only next-page format caller))
110 (concatenate 'string prefix page ".html")
114 (concatenate 'string page ".lsp")
116 +asp-header+ +plist-header+ (plist-to-url-string plist)))))))
118 (defun parameters-null (&rest params)
119 (every #'(lambda (p) (or (null p) (eq p *unspecified*))) params))
124 (defun plist-to-url-string (plist &key (base64 t))
125 (let ((str (plist-to-compressed-string plist)))
127 (string-to-base64-string str :uri t)
128 (escape-uri-field str))))
130 (defun url-string-to-plist (str &key (base64 t))
131 (let ((decode (if base64
132 (base64-string-to-string str :uri t)
133 (unescape-uri-field str))))
135 (ignore-errors (compressed-string-to-plist decode)))))
137 (defun plist-to-compressed-string (plist)
138 "Decode an encoded plist"
139 (assert (evenp (length plist)))
141 (list plist (cddr list)))
143 (prin1-to-string (nreverse output)))
144 (push (compress-elem (car list)) output)
145 (push (cadr list) output)))
147 (defun compress-elem (elem)
148 "Encode a plist elem"
171 (defun compressed-string-to-plist (encoded-str)
172 (let ((encoded (ignore-errors (read-from-string encoded-str)))
175 (cmsg "invalid encoded string")
177 (gen-invalid-encoded-str encoded-str)
179 (assert (evenp (length encoded)))
180 (do* ((elist encoded (cddr elist)))
181 ((null elist) (nreverse output))
182 (push (decompress-elem (car elist)) output)
183 (push (cadr elist) output))))
185 (defun decompress-elem (elem)
195 ;; For posting to lookup-func1