bucket-listing.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 ;;;; bucket-listing.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defbinder all-buckets
  33   ("ListAllMyBucketsResult"
  34    ("Owner"
  35     ("ID" (bind :owner-id))
  36     ("DisplayName" (bind :display-name)))
  37    ("Buckets"
  38     (sequence :buckets
  39               ("Bucket"
  40                ("Name" (bind :name))
  41                ("CreationDate" (bind :creation-date)))))))
  42
  43 (defclass all-buckets (response)
  44   ((owner
  45     :initarg :owner
  46     :accessor owner)
  47    (buckets
  48     :initarg :buckets
  49     :accessor buckets)))
  50
  51 (set-element-class "ListAllMyBucketsResult" 'all-buckets)
  52
  53 (defmethod specialized-initialize ((response all-buckets) source)
  54   (let ((bindings (xml-bind 'all-buckets source)))
  55     (setf (owner response)
  56           (make-instance 'person
  57                          :id (bvalue :owner-id bindings)
  58                          :display-name (bvalue :display-name bindings)))
  59     (let* ((bucket-bindings (bvalue :buckets bindings))
  60            (buckets (make-array (length bucket-bindings))))
  61       (setf (buckets response) buckets)
  62       (loop for i from 0
  63             for ((nil . name) (nil . timestamp)) in bucket-bindings
  64             do (setf (aref buckets i)
  65                      (make-instance 'bucket
  66                                     :name name
  67                                     :creation-date (parse-amazon-timestamp timestamp)))))))
  68
  69
  70 (defbinder list-bucket-result
  71   ("ListBucketResult"
  72    ("Name" (bind :bucket-name))
  73    ("Prefix" (bind :prefix))
  74    ("Marker" (bind :marker))
  75    (optional
  76     ("NextMarker" (bind :next-marker)))
  77    ("MaxKeys" (bind :max-keys))
  78    (optional
  79     ("Delimiter" (bind :delimiter)))
  80    ("IsTruncated" (bind :truncatedp))
  81    (sequence :keys
  82              ("Contents"
  83               ("Key" (bind :key))
  84               ("LastModified" (bind :last-modified))
  85               ("ETag" (bind :etag))
  86               ("Size" (bind :size))
  87               (optional
  88                ("Owner"
  89                 ("ID" (bind :owner-id))
  90                 (optional ("DisplayName" (bind :owner-display-name)))))
  91               ("StorageClass" (bind :storage-class))))
  92    (sequence :common-prefixes
  93              ("CommonPrefixes"
  94               ("Prefix" (bind :prefix))))))
  95
  96 (defclass bucket-listing (response)
  97   ((bucket-name
  98     :initarg :bucket-name
  99     :accessor bucket-name)
 100    (prefix
 101     :initarg :prefix
 102     :accessor prefix)
 103    (marker
 104     :initarg :marker
 105     :accessor marker)
 106    (next-marker
 107     :initarg :next-marker
 108     :accessor next-marker)
 109    (max-keys
 110     :initarg :max-keys
 111     :accessor max-keys)
 112    (delimiter
 113     :initarg :delimiter
 114     :accessor delimiter)
 115    (truncatedp
 116     :initarg :truncatedp
 117     :accessor truncatedp)
 118    (keys
 119     :initarg :keys
 120     :accessor keys)
 121    (common-prefixes
 122     :initarg :common-prefixes
 123     :accessor common-prefixes))
 124   (:default-initargs
 125    :next-marker nil
 126    :delimiter nil
 127    :prefix nil
 128    :max-keys nil))
 129
 130 (defmethod print-object ((response bucket-listing) stream)
 131   (print-unreadable-object (response stream :type t)
 132     (format stream "~S~@[ (truncated)~]"
 133             (bucket-name response)
 134             (truncatedp response))))
 135
 136
 137 (set-element-class "ListBucketResult" 'bucket-listing)
 138
 139 (defun key-binding-key (binding)
 140   (alist-bind (key
 141                last-modified etag size
 142                owner-id owner-display-name
 143                storage-class)
 144       binding
 145     (make-instance 'key
 146                    :name key
 147                    :last-modified (parse-amazon-timestamp last-modified)
 148                    :etag etag
 149                    :size (parse-integer size)
 150                    :owner (when owner-id
 151                             (make-instance 'person
 152                                            :id owner-id
 153                                            :display-name owner-display-name))
 154                    :storage-class storage-class)))
 155
 156 (defmethod specialized-initialize ((response bucket-listing) source)
 157   (let* ((bindings (xml-bind 'list-bucket-result source))
 158          (bucket-name (bvalue :bucket-name bindings)))
 159     (setf (bucket-name response) bucket-name)
 160     (setf (prefix response) (bvalue :prefix bindings))
 161     (setf (marker response) (bvalue :marker bindings))
 162     (setf (next-marker response) (bvalue :next-marker bindings))
 163     (setf (max-keys response) (parse-integer (bvalue :max-keys bindings)))
 164     (setf (delimiter response) (bvalue :delimiter bindings))
 165     (setf (truncatedp response) (equal (bvalue :truncatedp bindings)
 166                                        "true"))
 167     (setf (keys response)
 168           (map 'vector
 169                (lambda (key-binding)
 170                  (key-binding-key key-binding))
 171                (bvalue :keys bindings)))
 172     (setf (common-prefixes response)
 173           (map 'vector #'cdar (bvalue :common-prefixes bindings)))))
 174
 175 (defgeneric successive-marker (response)
 176   (:method ((response bucket-listing))
 177     (when (truncatedp response)
 178       (let* ((k1 (next-marker response))
 179              (k2 (last-entry (keys response)))
 180              (k3 (last-entry (common-prefixes response))))
 181         (cond (k1)
 182               ((and k2 (not k3)) (name k2))
 183               ((not k2) nil)
 184               ((string< (name k3) (name k2)) (name k2))
 185               (t (name k3)))))))
 186
 187 (defgeneric successive-request (response)
 188   (:method ((response bucket-listing))
 189     (when (truncatedp response)
 190       (make-instance 'request
 191                      :credentials (credentials (request response))
 192                      :method :get
 193                      :bucket (bucket-name response)
 194                      :parameters
 195                      (parameters-alist :max-keys (max-keys response)
 196                                        :delimiter (delimiter response)
 197                                        :marker (successive-marker response)
 198                                        :prefix (prefix response))))))
 199
 200