-
Notifications
You must be signed in to change notification settings - Fork 7
/
properties.lisp
192 lines (170 loc) · 8.76 KB
/
properties.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-WEBDAV; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-webdav/properties.lisp,v 1.9 2008/06/25 08:04:25 edi Exp $
;;; Copyright (c) 2007-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-webdav)
(defun property-equal (property1 property2)
"Two \(XMLS nodes denoting) properties are equal iff they have
the same local name and the same namespace URI."
(and (equal (namespace-uri property1)
(namespace-uri property2))
(equal (local-name property1)
(local-name property2))))
(defun dav-property-function (property)
"Returns the function which is responsible to retrieve the DAV
\"live\" property PROPERTY, where PROPERTY can either be an XMLS
node or a string denoting the local name of the corresponding
node. If PROPERTY doesn't denote a DAV property, this function
returns NIL."
(etypecase property
(string (cdr (assoc property +dav-property-alist+ :test #'string=)))
((satisfies xmls-node-p)
(and (equal (namespace-uri property) "DAV:")
(dav-property-function (local-name property))))))
(defun get-dead-property (resource property-designator)
"Returns the dead property denoted by the XMLS node
PROPERTY-DESIGNATOR of the resource RESOURCE or +HTTP-NOT-FOUND+
if such a property doesn't exist."
(or (find property-designator (get-dead-properties resource)
:test #'property-equal)
+http-not-found+))
(defun get-property (resource property-designator)
"Returns the \(live or dead) property denoted by the XMLS node
PROPERTY-DESIGNATOR of the resource RESOURCE or +HTTP-NOT-FOUND+
if such a property doesn't exist."
(let ((property-function (dav-property-function property-designator)))
(cond (property-function
;; if there's such a function, this is a live property
(let ((property (funcall property-function resource)))
(cond ((stringp property)
(dav-node (local-name property-designator) property))
((xmls-node-p property) property))))
(t (get-dead-property resource property-designator)))))
(defun propstat (resource property-designator show-content)
"Uses GET-PROPERTY to try to retrieve the property designated
by PROPERTY-DESIGNATOR from the resource RESOURCE. Returns as
its first value an HTTP return code \(with +HTTP-OK+ denoting
that the property was found) and as its second value the property
designator or \(if SHOW-CONTENT is true and the property was
found) the property itself."
(let ((property (handler-case
(get-property resource property-designator)
(error (condition)
(warn
"While trying to get property ~S for resource ~S: ~A"
(local-name property-designator)
(resource-script-name resource)
condition)
+http-internal-server-error+))))
(etypecase property
(null (values +http-ok+ property-designator))
(integer (values property property-designator))
((satisfies xmls-node-p)
(values +http-ok+
(cond (show-content property)
(t property-designator)))))))
(defun all-dead-property-designators (resource)
"Returns a list of XMLS nodes which are designators for all
dead properties for the resource RESOURCE."
(loop for property in (get-dead-properties resource)
collect (remove-content property)))
(defconstant +dav-property-designators+
(load-time-value
(loop for (name . nil) in +dav-property-alist+
collect (dav-node name)))
"A list of XMLS nodes which are property designators for all
DAV \(live) properties defined by the WebDAV RFC. Computed at
load time from +DAV-PROPERTY-ALIST+.")
(defun all-property-designators (resource)
"Returns a list of XMLS nodes which are designators for all
\(dead and live) properties for the resource RESOURCE."
(append +dav-property-designators+
(all-dead-property-designators resource)))
(defun collect-properties (resource property-designators show-content)
"Tries to collect all properties of the resource RESOURCE which
are in the list PROPERTY-DESIGNATORS \(which can also be the
symbol T which means \"all dead an live properties\".
SHOW-CONTENT is interpreted as in PROPSTAT. Returns the
corresponding \"response\" DAV node as an XMLS node."
;; we use a hash table to map status codes to properties for the XML
;; response
(let ((status-hash (make-hash-table)))
(dolist (property-designator (cond ((eql property-designators t)
(all-property-designators resource))
(t property-designators)))
(multiple-value-bind (status property)
(propstat resource property-designator show-content)
(push property (gethash status status-hash))))
(let ((propstats
(loop for status being the hash-keys of status-hash
using (hash-value properties)
;; collect all properties with the same status code
;; within one "propstat" element
collect (dav-node "propstat"
(apply #'dav-node "prop" properties)
(dav-node "status" (status-line status))))))
;; create the XMLS "response" node
(apply #'dav-node "response"
(dav-node "href" (resource-href resource))
propstats))))
(defun parse-propfind (octets)
"Helper function for PROPFIND-HANDLER which parses the XML
stored in OCTETS \(an array of octets) which is supposed to be
either empty or the body of a PROPFIND request. Returns as its
first value a list of the requested properties \(as XMLS nodes)
or T \(denoting all properties) and as its second value a boolean
which is T iff the client wants only property names."
(when (zerop (length octets))
(return-from parse-propfind t))
(let* ((node (first (node-children (parse-dav octets "propfind"))))
(node-name (local-name node)))
(cond ((string= node-name "allprop") t)
((string= node-name "propname") (values t t))
((string= node-name "prop")
;; skip whitespace (which hasn't been removed as the
;; "spec" is :ANY)
(remove-if #'whitespace-string-p (node-children node))))))
;;; The functions below implement the very simple protocol of storing
;;; dead properties in a hash table in RAM, i.e. without persistence -
;;; don't feel tempted to use this for a production system
(defun retrieve-properties (key)
"Retrieves the properties stored under the \(EQUAL) key KEY."
(gethash key *property-hash*))
(defun store-properties (key properties)
"Stores PROPERTIES under the \(EQUAL) key KEY."
(setf (gethash key *property-hash*) properties))
(defun remove-properties (key)
"Removes any properties stored under the \(EQUAL) key KEY."
(remhash key *property-hash*))
(defun move-properties (from-key to-key)
"Moves properties stored under the \(EQUAL) key FROM-KEY \(if
any) to the key TO-KEY."
(setf (gethash to-key *property-hash*)
(gethash from-key *property-hash*))
(remhash from-key *property-hash*))
(defun copy-properties (from-key to-key)
"Copies \(using COPY-TREE) properties stored under the \(EQUAL)
key FROM-KEY \(if any) to the key TO-KEY."
(setf (gethash to-key *property-hash*)
;; actually, due to how this is implemented, COPY-TREE isn't
;; really necessary, but it's better to be safe than sorry...
(copy-tree (gethash from-key *property-hash*))))