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 (defparameter *all-buckets-binder*
  33   (make-binder
  34    '("ListAllMyBucketsResult"
  35      ("Owner"
  36       ("ID" (bind :owner-id))
  37       ("DisplayName" (bind :display-name)))
  38      ("Buckets"
  39       (sequence :buckets
  40        ("Bucket"
  41         ("Name" (bind :name))
  42         ("CreationDate" (bind :creation-date))))))))
  43
  44 (defclass all-buckets (response)
  45   ((owner
  46     :initarg :owner
  47     :accessor owner)
  48    (buckets
  49     :initarg :buckets
  50     :accessor buckets)))
  51
  52 (set-element-class "ListAllMyBucketsResult" 'all-buckets)
  53
  54 (defmethod specialized-initialize ((response all-buckets) source)
  55   (let ((bindings (xml-bind *all-buckets-binder* source)))
  56     (setf (owner response)
  57           (make-instance 'person
  58                          :id (bvalue :owner-id bindings)
  59                          :display-name (bvalue :display-name bindings)))
  60     (let* ((bucket-bindings (bvalue :buckets bindings))
  61            (buckets (make-array (length bucket-bindings))))
  62       (setf (buckets response) buckets)
  63       (loop for i from 0
  64             for ((nil . name) (nil . timestamp)) in bucket-bindings
  65             do (setf (aref buckets i)
  66                      (make-instance 'bucket
  67                                     :name name
  68                                     :creation-date (parse-amazon-timestamp timestamp)))))))
  69
  70
  71 (defparameter *list-bucket-binder*
  72   (make-binder
  73    '("ListBucketResult"
  74      ("Name" (bind :bucket-name))
  75      ("Prefix" (bind :prefix))
  76      ("Marker" (bind :marker))
  77      (optional
  78       ("NextMarker" (bind :next-marker)))
  79      ("MaxKeys" (bind :max-keys))
  80      (optional
  81       ("Delimiter" (bind :delimiter)))
  82      ("IsTruncated" (bind :truncatedp))
  83      (sequence :keys
  84       ("Contents"
  85        ("Key" (bind :key))
  86        ("LastModified" (bind :last-modified))
  87        ("ETag" (bind :etag))
  88        ("Size" (bind :size))
  89        (optional
  90         ("Owner"
  91          ("ID" (bind :owner-id))
  92          ("DisplayName" (bind :owner-display-name))))
  93        ("StorageClass" (bind :storage-class))))
  94      (sequence :common-prefixes
  95       ("CommonPrefixes"
  96        ("Prefix" (bind :prefix)))))))
  97
  98 (defclass bucket-listing (response)
  99   ((bucket-name
 100     :initarg :bucket-name
 101     :accessor bucket-name)
 102    (prefix
 103     :initarg :prefix
 104     :accessor prefix)
 105    (marker
 106     :initarg :marker
 107     :accessor marker)
 108    (next-marker
 109     :initarg :next-marker
 110     :accessor next-marker)
 111    (max-keys
 112     :initarg :max-keys
 113     :accessor max-keys)
 114    (delimiter
 115     :initarg :delimiter
 116     :accessor delimiter)
 117    (truncatedp
 118     :initarg :truncatedp
 119     :accessor truncatedp)
 120    (keys
 121     :initarg :keys
 122     :accessor keys)
 123    (common-prefixes
 124     :initarg :common-prefixes
 125     :accessor common-prefixes))
 126   (:default-initargs
 127    :next-marker nil
 128    :delimiter nil
 129    :prefix nil
 130    :max-keys nil))
 131
 132 (defmethod print-object ((response bucket-listing) stream)
 133   (print-unreadable-object (response stream :type t)
 134     (format stream "~S~@[ (truncated)~]"
 135             (bucket-name response)
 136             (truncatedp response))))
 137
 138
 139 (set-element-class "ListBucketResult" 'bucket-listing)
 140
 141 (defun key-binding-key (binding)
 142   (alist-bind (key
 143                last-modified etag size
 144                owner-id owner-display-name storage-class)
 145       binding
 146     (make-instance 'key
 147                    :name key
 148                    :last-modified (parse-amazon-timestamp last-modified)
 149                    :etag etag
 150                    :size (parse-integer size)
 151                    :owner (when owner-id
 152                             (make-instance 'person
 153                                            :id owner-id
 154                                            :display-name owner-display-name)))))
 155
 156 (defmethod specialized-initialize ((response bucket-listing) source)
 157   (let* ((bindings (xml-bind *list-bucket-binder* 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