Updated version to 1.3.3.
[zs3.git] / bucket-listing.lisp
blob7bb406137f306d0575e660761605f28bfb17ba83
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
30 (in-package #:zs3)
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)))))))
43 (defclass all-buckets (response)
44 ((owner
45 :initarg :owner
46 :accessor owner)
47 (buckets
48 :initarg :buckets
49 :accessor buckets)))
51 (set-element-class "ListAllMyBucketsResult" 'all-buckets)
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)))))))
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))))))
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))
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))))
137 (set-element-class "ListBucketResult" 'bucket-listing)
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)))
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)))))
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)))))))
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))))))