acl.lisp

   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
  29
  30 (in-package #:zs3)
  31
  32 (defclass access-control-list ()
  33   ((owner
  34     :initarg :owner
  35     :accessor owner)
  36    (grants
  37     :initarg :grants
  38     :accessor grants)))
  39
  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)))))
  45
  46 (defclass grant ()
  47   ((permission
  48     :initarg :permission
  49     :accessor permission)
  50    (grantee
  51     :initarg :grantee
  52     :accessor grantee)))
  53
  54 (defclass acl-person (person) ())
  55
  56 (defmethod slot-unbound ((class t) (object acl-person) (slot (eql 'display-name)))
  57   (setf (display-name object) (id object)))
  58
  59 (defclass acl-email ()
  60   ((email
  61     :initarg :email
  62     :accessor email)))
  63
  64 (defmethod print-object ((email acl-email) stream)
  65   (print-unreadable-object (email stream :type t)
  66     (prin1 (email email) stream)))
  67
  68 (defclass acl-group ()
  69   ((label
  70     :initarg :label
  71     :accessor label)
  72    (uri
  73     :initarg :uri
  74     :accessor uri)))
  75
  76 (defmethod slot-unbound ((class t) (group acl-group) (slot (eql 'label)))
  77   (setf (label group) (uri group)))
  78
  79 (defmethod print-object ((group acl-group) stream)
  80   (print-unreadable-object (group stream :type t)
  81     (prin1 (label group) stream)))
  82
  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)))
  90
  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)))))
  96
  97 (defparameter *permissions*
  98   '((:read . "READ")
  99     (:write . "WRITE")
 100     (:read-acl . "READ_ACP")
 101     (:write-acl . "WRITE_ACP")
 102     (:full-control . "FULL_CONTROL")))
 103
 104 (defun permission-name (permission)
 105   (or (cdr (assoc permission *permissions*))
 106       (error "Unknown permission - ~S" permission)))
 107
 108 (defun permission-keyword (permission)
 109   (or (car (rassoc permission *permissions* :test 'string=))
 110       (error "Unknown permission - ~S" permission)))
 111
 112 (defparameter *all-users*
 113   (make-instance 'acl-group
 114                  :label "AllUsers"
 115                  :uri "http://acs.amazonaws.com/groups/global/AllUsers"))
 116
 117 (defparameter *aws-users*
 118   (make-instance 'acl-group
 119                  :label "AWSUsers"
 120                  :uri "http://acs.amazonaws.com/groups/global/AuthenticatedUsers"))
 121
 122 (defparameter *log-delivery*
 123   (make-instance 'acl-group
 124                  :label "LogDelivery"
 125                  :uri "http://acs.amazonaws.com/groups/s3/LogDelivery"))
 126
 127 (defgeneric acl-serialize (object))
 128
 129 (defmethod acl-serialize ((person person))
 130   (with-element "ID" (text (id person)))
 131   (with-element "DisplayName" (text (display-name person))))
 132
 133 (defvar *xsi* "http://www.w3.org/2001/XMLSchema-instance")
 134
 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"))
 142
 143 (defmethod acl-serialize ((grantee acl-group))
 144   (simple-element "URI" (uri grantee)))
 145
 146 (defmethod acl-serialize ((grantee acl-email))
 147   (simple-element "EmailAddress" (email grantee)))
 148
 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)))))
 156
 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))))))
 166
 167
 168 ;;; Parsing XML ACL responses
 169
 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)))))))
 181
 182 (defclass acl-response (response)
 183   ((acl
 184     :initarg :acl
 185     :accessor acl)))
 186
 187 (set-element-class "AccessControlPolicy" 'acl-response)
 188
 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)))))
 199
 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*)
 207         (t
 208          (make-instance 'acl-group :uri uri))))
 209
 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)))))))
 229
 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))
 241
 242
 243 (defun grant (permission &key to)
 244   (make-instance 'grant :permission permission :grantee to))
 245
 246 (defun acl-email (address)
 247   (make-instance 'acl-email :email address))
 248
 249 (defun acl-person (id &optional display-name)
 250   (make-instance 'acl-person
 251                  :id id
 252                  :display-name (or display-name id)))