Updated version to 1.3.3.
[zs3.git] / acl.lisp
blob57524a6161dcaa6c610c9d51cc2b9b8267de7ed0
1 ;;;;
2 ;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
3 ;;;;
4 ;;;; Redistribution and use in source and binary forms, with or without
5 ;;;; modification, are permitted provided that the following conditions
6 ;;;; are met:
7 ;;;;
8 ;;;; * Redistributions of source code must retain the above copyright
9 ;;;; notice, this list of conditions and the following disclaimer.
10 ;;;;
11 ;;;; * Redistributions in binary form must reproduce the above
12 ;;;; copyright notice, this list of conditions and the following
13 ;;;; disclaimer in the documentation and/or other materials
14 ;;;; provided with the distribution.
15 ;;;;
16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
19 ;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 ;;;;
28 ;;;; acl.lisp
30 (in-package #:zs3)
32 (defclass access-control-list ()
33 ((owner
34 :initarg :owner
35 :accessor owner)
36 (grants
37 :initarg :grants
38 :accessor grants)))
40 (defmethod print-object ((object access-control-list) stream)
41 (print-unreadable-object (object stream :type t)
42 (format stream "owner ~S, ~D grant~:P"
43 (display-name (owner object))
44 (length (grants object)))))
46 (defclass grant ()
47 ((permission
48 :initarg :permission
49 :accessor permission)
50 (grantee
51 :initarg :grantee
52 :accessor grantee)))
54 (defclass acl-person (person) ())
56 (defmethod slot-unbound ((class t) (object acl-person) (slot (eql 'display-name)))
57 (setf (display-name object) (id object)))
59 (defclass acl-email ()
60 ((email
61 :initarg :email
62 :accessor email)))
64 (defmethod print-object ((email acl-email) stream)
65 (print-unreadable-object (email stream :type t)
66 (prin1 (email email) stream)))
68 (defclass acl-group ()
69 ((label
70 :initarg :label
71 :accessor label)
72 (uri
73 :initarg :uri
74 :accessor uri)))
76 (defmethod slot-unbound ((class t) (group acl-group) (slot (eql 'label)))
77 (setf (label group) (uri group)))
79 (defmethod print-object ((group acl-group) stream)
80 (print-unreadable-object (group stream :type t)
81 (prin1 (label group) stream)))
83 (defgeneric grantee-for-print (grantee)
84 (:method ((grantee person))
85 (display-name grantee))
86 (:method ((grantee acl-group))
87 (label grantee))
88 (:method ((grantee acl-email))
89 (email grantee)))
91 (defmethod print-object ((grant grant) stream)
92 (print-unreadable-object (grant stream :type t)
93 (format stream "~S to ~S"
94 (permission grant)
95 (grantee-for-print (grantee grant)))))
97 (defparameter *permissions*
98 '((:read . "READ")
99 (:write . "WRITE")
100 (:read-acl . "READ_ACP")
101 (:write-acl . "WRITE_ACP")
102 (:full-control . "FULL_CONTROL")))
104 (defun permission-name (permission)
105 (or (cdr (assoc permission *permissions*))
106 (error "Unknown permission - ~S" permission)))
108 (defun permission-keyword (permission)
109 (or (car (rassoc permission *permissions* :test 'string=))
110 (error "Unknown permission - ~S" permission)))
112 (defparameter *all-users*
113 (make-instance 'acl-group
114 :label "AllUsers"
115 :uri "http://acs.amazonaws.com/groups/global/AllUsers"))
117 (defparameter *aws-users*
118 (make-instance 'acl-group
119 :label "AWSUsers"
120 :uri "http://acs.amazonaws.com/groups/global/AuthenticatedUsers"))
122 (defparameter *log-delivery*
123 (make-instance 'acl-group
124 :label "LogDelivery"
125 :uri "http://acs.amazonaws.com/groups/s3/LogDelivery"))
127 (defgeneric acl-serialize (object))
129 (defmethod acl-serialize ((person person))
130 (with-element "ID" (text (id person)))
131 (with-element "DisplayName" (text (display-name person))))
133 (defvar *xsi* "http://www.w3.org/2001/XMLSchema-instance")
135 (defgeneric xsi-type (grantee)
136 (:method ((grantee acl-group))
137 "Group")
138 (:method ((grantee person))
139 "CanonicalUser")
140 (:method ((grantee acl-email))
141 "AmazonCustomerByEmail"))
143 (defmethod acl-serialize ((grantee acl-group))
144 (simple-element "URI" (uri grantee)))
146 (defmethod acl-serialize ((grantee acl-email))
147 (simple-element "EmailAddress" (email grantee)))
149 (defmethod acl-serialize ((grant grant))
150 (with-element "Grant"
151 (with-element "Grantee"
152 (attribute* "xmlns" "xsi" *xsi*)
153 (attribute* "xsi" "type" (xsi-type (grantee grant)))
154 (acl-serialize (grantee grant)))
155 (simple-element "Permission" (permission-name (permission grant)))))
157 (defmethod acl-serialize ((acl access-control-list))
158 (with-xml-output
159 (with-element "AccessControlPolicy"
160 (attribute "xmlns" "http://s3.amazonaws.com/doc/2006-03-01/")
161 (with-element "Owner"
162 (acl-serialize (owner acl)))
163 (with-element "AccessControlList"
164 (dolist (grant (remove-duplicates (grants acl) :test #'acl-eqv))
165 (acl-serialize grant))))))
168 ;;; Parsing XML ACL responses
170 (defbinder access-control-policy
171 ("AccessControlPolicy"
172 ("Owner"
173 ("ID" (bind :owner-id))
174 ("DisplayName" (bind :owner-display-name)))
175 ("AccessControlList"
176 (sequence :grants
177 ("Grant"
178 ("Grantee"
179 (elements-alist :grantee))
180 ("Permission" (bind :permission)))))))
182 (defclass acl-response (response)
183 ((acl
184 :initarg :acl
185 :accessor acl)))
187 (set-element-class "AccessControlPolicy" 'acl-response)
189 (defgeneric acl-eqv (a b)
190 (:method (a b)
191 (eql a b))
192 (:method ((a acl-group) (b acl-group))
193 (string= (uri a) (uri b)))
194 (:method ((a person) (b person))
195 (string= (id a) (id b)))
196 (:method ((a grant) (b grant))
197 (and (eql (permission a) (permission b))
198 (acl-eqv (grantee a) (grantee b)))))
200 (defun ensure-acl-group (uri)
201 (cond ((string= uri (uri *all-users*))
202 *all-users*)
203 ((string= uri (uri *aws-users*))
204 *aws-users*)
205 ((string= uri (uri *log-delivery*))
206 *log-delivery*)
208 (make-instance 'acl-group :uri uri))))
210 (defun alist-grant (bindings)
211 (let* ((permission (bvalue :permission bindings))
212 (alist (bvalue :grantee bindings))
213 (group-uri (assoc "URI" alist :test 'string=))
214 (user-id (assoc "ID" alist :test 'string=))
215 (email (assoc "EmailAddress" alist :test 'string=))
216 (display-name (assoc "DisplayName" alist :test 'string=)))
217 (make-instance 'grant
218 :permission (permission-keyword permission)
219 :grantee (cond (group-uri
220 (ensure-acl-group (cdr group-uri)))
221 (user-id
222 (make-instance 'acl-person
223 :id (cdr user-id)
224 :display-name
225 (cdr display-name)))
226 (email
227 (make-instance 'acl-email
228 :email (cdr email)))))))
230 (defmethod specialized-initialize ((response acl-response) source)
231 (let* ((bindings (xml-bind 'access-control-policy source))
232 (owner (make-instance 'acl-person
233 :id (bvalue :owner-id bindings)
234 :display-name (bvalue :owner-display-name bindings)))
235 (grants (mapcar 'alist-grant (bvalue :grants bindings))))
236 (setf (acl response)
237 (make-instance 'access-control-list
238 :owner owner
239 :grants grants))
240 response))
243 (defun grant (permission &key to)
244 (make-instance 'grant :permission permission :grantee to))
246 (defun acl-email (address)
247 (make-instance 'acl-email :email address))
249 (defun acl-person (id &optional display-name)
250 (make-instance 'acl-person
251 :id id
252 :display-name (or display-name id)))