Permalink
Fetching contributors…
Cannot retrieve contributors at this time
201 lines (183 sloc) 7 KB
;;;;
;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;;
;;;; * Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;;
;;;; * Redistributions in binary form must reproduce the above
;;;; copyright notice, this list of conditions and the following
;;;; disclaimer in the documentation and/or other materials
;;;; provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
;;;; bucket-listing.lisp
(in-package #:zs3)
(defbinder all-buckets
("ListAllMyBucketsResult"
("Owner"
("ID" (bind :owner-id))
("DisplayName" (bind :display-name)))
("Buckets"
(sequence :buckets
("Bucket"
("Name" (bind :name))
("CreationDate" (bind :creation-date)))))))
(defclass all-buckets (response)
((owner
:initarg :owner
:accessor owner)
(buckets
:initarg :buckets
:accessor buckets)))
(set-element-class "ListAllMyBucketsResult" 'all-buckets)
(defmethod specialized-initialize ((response all-buckets) source)
(let ((bindings (xml-bind 'all-buckets source)))
(setf (owner response)
(make-instance 'person
:id (bvalue :owner-id bindings)
:display-name (bvalue :display-name bindings)))
(let* ((bucket-bindings (bvalue :buckets bindings))
(buckets (make-array (length bucket-bindings))))
(setf (buckets response) buckets)
(loop for i from 0
for ((nil . name) (nil . timestamp)) in bucket-bindings
do (setf (aref buckets i)
(make-instance 'bucket
:name name
:creation-date (parse-amazon-timestamp timestamp)))))))
(defbinder list-bucket-result
("ListBucketResult"
("Name" (bind :bucket-name))
("Prefix" (bind :prefix))
("Marker" (bind :marker))
(optional
("NextMarker" (bind :next-marker)))
("MaxKeys" (bind :max-keys))
(optional
("Delimiter" (bind :delimiter)))
("IsTruncated" (bind :truncatedp))
(sequence :keys
("Contents"
("Key" (bind :key))
("LastModified" (bind :last-modified))
("ETag" (bind :etag))
("Size" (bind :size))
(optional
("Owner"
("ID" (bind :owner-id))
("DisplayName" (bind :owner-display-name))))
("StorageClass" (bind :storage-class))))
(sequence :common-prefixes
("CommonPrefixes"
("Prefix" (bind :prefix))))))
(defclass bucket-listing (response)
((bucket-name
:initarg :bucket-name
:accessor bucket-name)
(prefix
:initarg :prefix
:accessor prefix)
(marker
:initarg :marker
:accessor marker)
(next-marker
:initarg :next-marker
:accessor next-marker)
(max-keys
:initarg :max-keys
:accessor max-keys)
(delimiter
:initarg :delimiter
:accessor delimiter)
(truncatedp
:initarg :truncatedp
:accessor truncatedp)
(keys
:initarg :keys
:accessor keys)
(common-prefixes
:initarg :common-prefixes
:accessor common-prefixes))
(:default-initargs
:next-marker nil
:delimiter nil
:prefix nil
:max-keys nil))
(defmethod print-object ((response bucket-listing) stream)
(print-unreadable-object (response stream :type t)
(format stream "~S~@[ (truncated)~]"
(bucket-name response)
(truncatedp response))))
(set-element-class "ListBucketResult" 'bucket-listing)
(defun key-binding-key (binding)
(alist-bind (key
last-modified etag size
owner-id owner-display-name
storage-class)
binding
(make-instance 'key
:name key
:last-modified (parse-amazon-timestamp last-modified)
:etag etag
:size (parse-integer size)
:owner (when owner-id
(make-instance 'person
:id owner-id
:display-name owner-display-name))
:storage-class storage-class)))
(defmethod specialized-initialize ((response bucket-listing) source)
(let* ((bindings (xml-bind 'list-bucket-result source))
(bucket-name (bvalue :bucket-name bindings)))
(setf (bucket-name response) bucket-name)
(setf (prefix response) (bvalue :prefix bindings))
(setf (marker response) (bvalue :marker bindings))
(setf (next-marker response) (bvalue :next-marker bindings))
(setf (max-keys response) (parse-integer (bvalue :max-keys bindings)))
(setf (delimiter response) (bvalue :delimiter bindings))
(setf (truncatedp response) (equal (bvalue :truncatedp bindings)
"true"))
(setf (keys response)
(map 'vector
(lambda (key-binding)
(key-binding-key key-binding))
(bvalue :keys bindings)))
(setf (common-prefixes response)
(map 'vector #'cdar (bvalue :common-prefixes bindings)))))
(defgeneric successive-marker (response)
(:method ((response bucket-listing))
(when (truncatedp response)
(let* ((k1 (next-marker response))
(k2 (last-entry (keys response)))
(k3 (last-entry (common-prefixes response))))
(cond (k1)
((and k2 (not k3)) (name k2))
((not k2) nil)
((string< (name k3) (name k2)) (name k2))
(t (name k3)))))))
(defgeneric successive-request (response)
(:method ((response bucket-listing))
(when (truncatedp response)
(make-instance 'request
:credentials (credentials (request response))
:method :get
:bucket (bucket-name response)
:parameters
(parameters-alist :max-keys (max-keys response)
:delimiter (delimiter response)
:marker (successive-marker response)
:prefix (prefix response))))))