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   (cxml:with-element "ID" (cxml:text (id person)))
 131   (cxml:with-element "DisplayName" (cxml: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 (defun simple-element (name value)
 144   (cxml:with-element name (cxml:text value)))
 145
 146 (defmethod acl-serialize ((grantee acl-group))
 147   (simple-element "URI" (uri grantee)))
 148
 149 (defmethod acl-serialize ((grantee acl-email))
 150   (simple-element "EmailAddress" (email grantee)))
 151
 152 (defmethod acl-serialize ((grant grant))
 153   (cxml:with-element "Grant"
 154     (cxml:with-element "Grantee"
 155       (cxml:attribute* "xmlns" "xsi" *xsi*)
 156       (cxml:attribute* "xsi" "type" (xsi-type (grantee grant)))
 157       (acl-serialize (grantee grant)))
 158     (simple-element "Permission" (permission-name (permission grant)))))
 159
 160 (defmethod acl-serialize ((acl access-control-list))
 161   (cxml:with-xml-output (cxml:make-octet-vector-sink)
 162     (cxml:with-element "AccessControlPolicy"
 163       (cxml:attribute "xmlns" "http://s3.amazonaws.com/doc/2006-03-01/")
 164       (cxml:with-element "Owner"
 165         (acl-serialize (owner acl)))
 166       (cxml:with-element "AccessControlList"
 167         (dolist (grant (remove-duplicates (grants acl) :test #'acl-eqv))
 168           (acl-serialize grant))))))
 169
 170
 171 ;;; Parsing XML ACL responses
 172
 173 (defbinder access-control-policy
 174   ("AccessControlPolicy"
 175    ("Owner"
 176     ("ID" (bind :owner-id))
 177     ("DisplayName" (bind :owner-display-name)))
 178    ("AccessControlList"
 179     (sequence :grants
 180               ("Grant"
 181                ("Grantee"
 182                 (elements-alist :grantee))
 183                ("Permission" (bind :permission)))))))
 184
 185 (defclass acl-response (response)
 186   ((acl
 187     :initarg :acl
 188     :accessor acl)))
 189
 190 (set-element-class "AccessControlPolicy" 'acl-response)
 191
 192 (defgeneric acl-eqv (a b)
 193   (:method (a b)
 194     (eql a b))
 195   (:method ((a acl-group) (b acl-group))
 196     (string= (uri a) (uri b)))
 197   (:method ((a person) (b person))
 198     (string= (id a) (id b)))
 199   (:method ((a grant) (b grant))
 200     (and (eql (permission a) (permission b))
 201          (acl-eqv (grantee a) (grantee b)))))
 202
 203 (defun ensure-acl-group (uri)
 204   (cond ((string= uri (uri *all-users*))
 205          *all-users*)
 206         ((string= uri (uri *aws-users*))
 207          *aws-users*)
 208         ((string= uri (uri *log-delivery*))
 209          *log-delivery*)
 210         (t
 211          (make-instance 'acl-group :uri uri))))
 212
 213 (defun alist-grant (bindings)
 214   (let* ((permission (bvalue :permission bindings))
 215          (alist (bvalue :grantee bindings))
 216          (group-uri (assoc "URI" alist :test 'string=))
 217          (user-id (assoc "ID" alist :test 'string=))
 218          (email (assoc "EmailAddress" alist :test 'string=))
 219          (display-name (assoc "DisplayName" alist :test 'string=)))
 220     (make-instance 'grant
 221                    :permission (permission-keyword permission)
 222                    :grantee (cond (group-uri
 223                                    (ensure-acl-group (cdr group-uri)))
 224                                   (user-id
 225                                    (make-instance 'acl-person
 226                                                   :id (cdr user-id)
 227                                                   :display-name
 228                                                   (cdr display-name)))
 229                                   (email
 230                                    (make-instance 'acl-email
 231                                                   :email (cdr email)))))))
 232
 233 (defmethod specialized-initialize ((response acl-response) source)
 234   (let* ((bindings (xml-bind 'access-control-policy source))
 235          (owner (make-instance 'acl-person
 236                                :id (bvalue :owner-id bindings)
 237                                :display-name (bvalue :owner-display-name bindings)))
 238          (grants (mapcar 'alist-grant (bvalue :grants bindings))))
 239     (setf (acl response)
 240           (make-instance 'access-control-list
 241                          :owner owner
 242                          :grants grants))
 243     response))
 244
 245
 246 (defun grant (permission &key to)
 247   (make-instance 'grant :permission permission :grantee to))
 248
 249 (defun acl-email (address)
 250   (make-instance 'acl-email :email address))
 251
 252 (defun acl-person (id &optional display-name)
 253   (make-instance 'acl-person
 254                  :id id
 255                  :display-name (or display-name id)))