Skip to content
Browse files

Initial checkin for github.

  • Loading branch information...
0 parents commit 54a3b3c8ef8ebd7928f81bcb6f70d15babe92eb0 @xach committed
Showing with 6,585 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +27 −0 LICENSE
  3. +24 −0 README
  4. +256 −0 acl.lisp
  5. +200 −0 bucket-listing.lisp
  6. +569 −0 cloudfront.lisp
  7. +91 −0 credentials.lisp
  8. +88 −0 crypto.lisp
  9. +27 −0 doc/LICENSE
  10. +2,559 −0 doc/index.html
  11. +82 −0 doc/style.css
  12. +228 −0 errors.lisp
  13. +770 −0 interface.lisp
  14. +51 −0 location.lisp
  15. +96 −0 logging.lisp
  16. +78 −0 objects.lisp
  17. +156 −0 package.lisp
  18. +75 −0 post.lisp
  19. +56 −0 redirects.lisp
  20. +295 −0 request.lisp
  21. +136 −0 response.lisp
  22. +78 −0 tests.lisp
  23. +301 −0 utils.lisp
  24. +287 −0 xml-binding.lisp
  25. +54 −0 zs3.asd
1 .gitignore
@@ -0,0 +1 @@
+*.fasl
27 LICENSE
@@ -0,0 +1,27 @@
+;;;;
+;;;; 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.
+;;;;
24 README
@@ -0,0 +1,24 @@
+
+This is ZS3, a library for working with Amazon's Simple Storage
+Service (S3) and CloudFront service from Common Lisp.
+
+For more information about S3, see:
+
+ http://aws.amazon.com/s3/
+
+For more information about CloudFront, see:
+
+ http://aws.amazon.com/cloudfront/
+
+For documentation of ZS3, including how to install and use, see
+doc/index.html in this distribution, or visit:
+
+ http://www.xach.com/lisp/zs3/
+
+If you have any questions or comments about ZS3, please contact me,
+Zach Beane, at xach@xach.com. You can also discuss ZS3 on the ZS3
+mailing list at http://groups.google.com/group/zs3-devel .
+
+
+
+
256 acl.lisp
@@ -0,0 +1,256 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; acl.lisp
+
+(in-package #:zs3)
+
+(defclass access-control-list ()
+ ((owner
+ :initarg :owner
+ :accessor owner)
+ (grants
+ :initarg :grants
+ :accessor grants)))
+
+(defmethod print-object ((object access-control-list) stream)
+ (print-unreadable-object (object stream :type t)
+ (format stream "owner ~S, ~D grant~:P"
+ (display-name (owner object))
+ (length (grants object)))))
+
+(defclass grant ()
+ ((permission
+ :initarg :permission
+ :accessor permission)
+ (grantee
+ :initarg :grantee
+ :accessor grantee)))
+
+(defclass acl-person (person) ())
+
+(defmethod slot-unbound (class (object acl-person) (slot (eql 'display-name)))
+ (setf (display-name object) (id object)))
+
+(defclass acl-email ()
+ ((email
+ :initarg :email
+ :accessor email)))
+
+(defmethod print-object ((email acl-email) stream)
+ (print-unreadable-object (email stream :type t)
+ (prin1 (email email) stream)))
+
+(defclass acl-group ()
+ ((label
+ :initarg :label
+ :accessor label)
+ (uri
+ :initarg :uri
+ :accessor uri)))
+
+(defmethod slot-unbound (class (group acl-group) (slot (eql 'label)))
+ (setf (label group) (uri group)))
+
+(defmethod print-object ((group acl-group) stream)
+ (print-unreadable-object (group stream :type t)
+ (prin1 (label group) stream)))
+
+(defgeneric grantee-for-print (grantee)
+ (:method ((grantee person))
+ (display-name grantee))
+ (:method ((grantee acl-group))
+ (label grantee))
+ (:method ((grantee acl-email))
+ (email grantee)))
+
+(defmethod print-object ((grant grant) stream)
+ (print-unreadable-object (grant stream :type t)
+ (format stream "~S to ~S"
+ (permission grant)
+ (grantee-for-print (grantee grant)))))
+
+(defparameter *permissions*
+ '((:read . "READ")
+ (:write . "WRITE")
+ (:read-acl . "READ_ACP")
+ (:write-acl . "WRITE_ACP")
+ (:full-control . "FULL_CONTROL")))
+
+(defun permission-name (permission)
+ (or (cdr (assoc permission *permissions*))
+ (error "Unknown permission - ~S" permission)))
+
+(defun permission-keyword (permission)
+ (or (car (rassoc permission *permissions* :test 'string=))
+ (error "Unknown permission - ~S" permission)))
+
+(defparameter *all-users*
+ (make-instance 'acl-group
+ :label "AllUsers"
+ :uri "http://acs.amazonaws.com/groups/global/AllUsers"))
+
+(defparameter *aws-users*
+ (make-instance 'acl-group
+ :label "AWSUsers"
+ :uri "http://acs.amazonaws.com/groups/global/AuthenticatedUsers"))
+
+(defparameter *log-delivery*
+ (make-instance 'acl-group
+ :label "LogDelivery"
+ :uri "http://acs.amazonaws.com/groups/s3/LogDelivery"))
+
+(defgeneric acl-serialize (object))
+
+(defmethod acl-serialize ((person person))
+ (cxml:with-element "ID" (cxml:text (id person)))
+ (cxml:with-element "DisplayName" (cxml:text (display-name person))))
+
+(defvar *xsi* "http://www.w3.org/2001/XMLSchema-instance")
+
+(defgeneric xsi-type (grantee)
+ (:method ((grantee acl-group))
+ "Group")
+ (:method ((grantee person))
+ "CanonicalUser")
+ (:method ((grantee acl-email))
+ "AmazonCustomerByEmail"))
+
+(defun simple-element (name value)
+ (cxml:with-element name (cxml:text value)))
+
+(defmethod acl-serialize ((grantee acl-group))
+ (simple-element "URI" (uri grantee)))
+
+(defmethod acl-serialize ((grantee acl-email))
+ (simple-element "EmailAddress" (email grantee)))
+
+(defmethod acl-serialize ((grant grant))
+ (cxml:with-element "Grant"
+ (cxml:with-element "Grantee"
+ (cxml:attribute* "xmlns" "xsi" *xsi*)
+ (cxml:attribute* "xsi" "type" (xsi-type (grantee grant)))
+ (acl-serialize (grantee grant)))
+ (simple-element "Permission" (permission-name (permission grant)))))
+
+(defmethod acl-serialize ((acl access-control-list))
+ (cxml:with-xml-output (cxml:make-octet-vector-sink)
+ (cxml:with-element "AccessControlPolicy"
+ (cxml:attribute "xmlns" "http://s3.amazonaws.com/doc/2006-03-01/")
+ (cxml:with-element "Owner"
+ (acl-serialize (owner acl)))
+ (cxml:with-element "AccessControlList"
+ (dolist (grant (remove-duplicates (grants acl) :test #'acl-eqv))
+ (acl-serialize grant))))))
+
+
+;;; Parsing XML ACL responses
+
+(defparameter *acl-binder*
+ (make-binder
+ '("AccessControlPolicy"
+ ("Owner"
+ ("ID" (bind :owner-id))
+ ("DisplayName" (bind :owner-display-name)))
+ ("AccessControlList"
+ (sequence :grants
+ ("Grant"
+ ("Grantee"
+ (elements-alist :grantee))
+ ("Permission" (bind :permission))))))))
+
+(defclass acl-response (response)
+ ((acl
+ :initarg :acl
+ :accessor acl)))
+
+(set-element-class "AccessControlPolicy" 'acl-response)
+
+(defgeneric acl-eqv (a b)
+ (:method (a b)
+ (eql a b))
+ (:method ((a acl-group) (b acl-group))
+ (string= (uri a) (uri b)))
+ (:method ((a person) (b person))
+ (string= (id a) (id b)))
+ (:method ((a grant) (b grant))
+ (and (eql (permission a) (permission b))
+ (acl-eqv (grantee a) (grantee b)))))
+
+(defun ensure-acl-group (uri)
+ (cond ((string= uri (uri *all-users*))
+ *all-users*)
+ ((string= uri (uri *aws-users*))
+ *aws-users*)
+ ((string= uri (uri *log-delivery*))
+ *log-delivery*)
+ (t
+ (make-instance 'acl-group :uri uri))))
+
+(defun alist-grant (bindings)
+ (let* ((permission (bvalue :permission bindings))
+ (alist (bvalue :grantee bindings))
+ (group-uri (assoc "URI" alist :test 'string=))
+ (user-id (assoc "ID" alist :test 'string=))
+ (email (assoc "EmailAddress" alist :test 'string=))
+ (display-name (assoc "DisplayName" alist :test 'string=)))
+ (make-instance 'grant
+ :permission (permission-keyword permission)
+ :grantee (cond (group-uri
+ (ensure-acl-group (cdr group-uri)))
+ (user-id
+ (make-instance 'acl-person
+ :id (cdr user-id)
+ :display-name
+ (cdr display-name)))
+ (email
+ (make-instance 'acl-email
+ :email (cdr email)))))))
+
+(defmethod specialized-initialize ((response acl-response) source)
+ (let* ((bindings (xml-bind *acl-binder* source))
+ (owner (make-instance 'acl-person
+ :id (bvalue :owner-id bindings)
+ :display-name (bvalue :owner-display-name bindings)))
+ (grants (mapcar 'alist-grant (bvalue :grants bindings))))
+ (setf (acl response)
+ (make-instance 'access-control-list
+ :owner owner
+ :grants grants))
+ response))
+
+
+(defun grant (permission &key to)
+ (make-instance 'grant :permission permission :grantee to))
+
+(defun acl-email (address)
+ (make-instance 'acl-email :email address))
+
+(defun acl-person (id &optional display-name)
+ (make-instance 'acl-person
+ :id id
+ :display-name (or display-name id)))
200 bucket-listing.lisp
@@ -0,0 +1,200 @@
+;;;;
+;;;; 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)
+
+(defparameter *all-buckets-binder*
+ (make-binder
+ '("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-binder* 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)))))))
+
+
+(defparameter *list-bucket-binder*
+ (make-binder
+ '("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)))))
+
+(defmethod specialized-initialize ((response bucket-listing) source)
+ (let* ((bindings (xml-bind *list-bucket-binder* 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))))))
+
+
569 cloudfront.lisp
@@ -0,0 +1,569 @@
+;;;;
+;;;; Copyright (c) 2009 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.
+;;;;
+;;;; cloudfront.lisp
+
+(in-package #:zs3)
+
+(defvar *canonical-bucket-name-suffix*
+ ".s3.amazonaws.com")
+
+(defparameter *caller-reference-counter* 8320208)
+
+(defparameter *cloudfront-base-url*
+ "https://cloudfront.amazonaws.com/2010-08-01/distribution")
+
+;;; Errors
+
+(defparameter *distribution-specific-errors*
+ (make-hash-table :test 'equal)
+ "This table is used to signal the most specific error possible for
+distribution request error responses.")
+
+(defparameter *distribution-error-response-binder*
+ (make-binder
+ '("ErrorResponse"
+ ("Error"
+ ("Type" (bind :type))
+ ("Code" (bind :code))
+ ("Message" (bind :message))
+ (optional
+ ("Detail" (bind :detail))))
+ ("RequestId" (bind :request-id)))))
+
+(define-condition distribution-error ()
+ ((error-type
+ :initarg :error-type
+ :accessor distribution-error-type)
+ (error-code
+ :initarg :error-code
+ :accessor distribution-error-code)
+ (http-status-code
+ :initarg :http-status-code
+ :accessor distribution-error-http-status-code)
+ (error-message
+ :initarg :error-message
+ :accessor distribution-error-message)
+ (error-detail
+ :initarg :error-detail
+ :accessor distribution-error-detail))
+ (:report (lambda (condition stream)
+ (format stream "~A error ~A: ~A"
+ (distribution-error-type condition)
+ (distribution-error-code condition)
+ (distribution-error-message condition)))))
+
+(defmacro define-specific-distribution-error (error-xml-code error-name)
+ `(progn
+ (setf (gethash ,error-xml-code *distribution-specific-errors*)
+ ',error-name)
+ (define-condition ,error-name (distribution-error) ())))
+
+(define-specific-distribution-error "InvalidIfMatchVersion"
+ invalid-if-match-version)
+
+(define-specific-distribution-error "PreconditionFailed"
+ distribution-precondition-failed)
+
+(define-specific-distribution-error "DistributionNotDisabled"
+ distribution-not-disabled)
+
+(define-specific-distribution-error "CNAMEAlreadyExists"
+ cname-already-exists)
+
+(define-specific-distribution-error "TooManyDistributions"
+ too-many-distributions)
+
+(defun maybe-signal-distribution-error (http-status-code content)
+ (when (and content
+ (plusp (length content))
+ (string= (xml-document-element content) "ErrorResponse"))
+ (let* ((bindings (xml-bind *distribution-error-response-binder*
+ content))
+ (condition (gethash (bvalue :code bindings)
+ *distribution-specific-errors*
+ 'distribution-error)))
+ (error condition
+ :http-status-code http-status-code
+ :error-type (bvalue :type bindings)
+ :error-code (bvalue :code bindings)
+ :error-message (bvalue :message bindings)
+ :error-detail (bvalue :detail bindings)))))
+
+
+;;; Distribution objects
+
+(defun canonical-distribution-bucket-name (name)
+ (if (ends-with *canonical-bucket-name-suffix* name)
+ name
+ (concatenate 'string name *canonical-bucket-name-suffix*)))
+
+(defun generate-caller-reference ()
+ (format nil "~D.~D"
+ (get-universal-time)
+ (incf *caller-reference-counter*)))
+
+(defclass distribution ()
+ ((origin-bucket
+ :initarg :origin-bucket
+ :accessor origin-bucket
+ :documentation
+ "The S3 bucket that acts as the source of objects for the distribution.")
+ (caller-reference
+ :initarg :caller-reference
+ :accessor caller-reference
+ :initform (generate-caller-reference)
+ :documentation
+ "A unique value provided by the caller to prevent replays. See
+ http://docs.amazonwebservices.com/AmazonCloudFront/2008-06-30/DeveloperGuide/index.html?AboutCreatingDistributions.html")
+ (enabledp
+ :initarg :enabledp
+ :initform t
+ :accessor enabledp
+ :documentation
+ "Whether this distribution should be enabled at creation time or not.")
+ (cnames
+ :initarg :cnames
+ :accessor cnames)
+ (comment
+ :initarg :comment
+ :initform nil
+ :accessor comment)
+ (id
+ :initarg :id
+ :accessor id
+ :documentation
+ "Amazon's assigned unique ID.")
+ (domain-name
+ :initarg :domain-name
+ :accessor domain-name
+ :documentation
+ "Amazon's assigned domain name.")
+ (etag
+ :initarg :etag
+ :accessor etag
+ :initform nil)
+ (status
+ :initarg :status
+ :accessor status
+ :initform nil
+ :documentation "Assigned by Amazon.")
+ (last-modified
+ :initarg :last-modified
+ :accessor last-modified
+ :documentation "Assigned by Amazon.")))
+
+(defmethod print-object ((distribution distribution) stream)
+ (print-unreadable-object (distribution stream :type t)
+ (format stream "~A for ~S~@[ [~A]~]"
+ (id distribution)
+ (origin-bucket distribution)
+ (status distribution))))
+
+(defmethod initialize-instance :after ((distribution distribution)
+ &rest initargs
+ &key &allow-other-keys)
+ (declare (ignore initargs))
+ (setf (origin-bucket distribution)
+ (canonical-distribution-bucket-name (origin-bucket distribution))))
+
+
+;;; Distribution-related requests
+
+(defun distribution-document (distribution)
+ (cxml:with-xml-output (cxml:make-string-sink)
+ (cxml:with-element "DistributionConfig"
+ (cxml:attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2008-06-30/")
+ (cxml:with-element "Origin"
+ (cxml:text (origin-bucket distribution)))
+ (cxml:with-element "CallerReference"
+ (cxml:text (caller-reference distribution)))
+ (dolist (cname (cnames distribution))
+ (cxml:with-element "CNAME"
+ (cxml:text cname)))
+ (when (comment distribution)
+ (cxml:with-element "Comment"
+ (cxml:text (comment distribution))))
+ (cxml:with-element "Enabled"
+ (cxml:text (if (enabledp distribution)
+ "true"
+ "false"))))))
+
+(defun distribution-request-headers (distribution)
+ (let* ((date (http-date-string))
+ (signature (sign-string (secret-key *credentials*)
+ date)))
+ (parameters-alist :date date
+ :authorization
+ (format nil "AWS ~A:~A"
+ (access-key *credentials*)
+ signature)
+ :if-match (and distribution (etag distribution)))))
+
+
+(defun distribution-request (&key distribution (method :get)
+ parameters url-suffix content
+ ((:credentials *credentials*) *credentials*))
+ (let ((url (format nil "~A~@[~A~]" *cloudfront-base-url* url-suffix)))
+ (multiple-value-bind (content code headers uri stream must-close-p phrase)
+ (drakma:http-request url
+ :method method
+ :parameters parameters
+ :content-length t
+ :keep-alive nil
+ :want-stream nil
+ :content-type "text/xml"
+ :additional-headers (distribution-request-headers distribution)
+ :content
+ (or content
+ (and distribution
+ (member method '(:post :put))
+ (distribution-document distribution))))
+ (declare (ignore uri must-close-p))
+ (ignore-errors (close stream))
+ (maybe-signal-distribution-error code content)
+ (values content headers code phrase))))
+
+(defparameter *distribution-config-form*
+ '("DistributionConfig"
+ ("Origin" (bind :origin))
+ ("CallerReference" (bind :caller-reference))
+ (sequence :cnames
+ ("CNAME" (bind :cname)))
+ (optional ("Comment" (bind :comment)))
+ ("Enabled" (bind :enabled))))
+
+(defparameter *distribution-form*
+ `("Distribution"
+ ("Id" (bind :id))
+ ("Status" (bind :status))
+ ("LastModifiedTime" (bind :last-modified-time))
+ ("InProgressInvalidationBatches" (bind :in-progress-invalidation-batches))
+ ("DomainName" (bind :domain-name))
+ ,@*distribution-config-form*))
+
+(defparameter *distribution-config-binder*
+ (make-binder *distribution-config-form*))
+
+(defparameter *distribution-binder* (make-binder *distribution-form*))
+
+(defun bindings-distribution (bindings)
+ (let ((timestamp (bvalue :last-modified-time bindings)))
+ (make-instance 'distribution
+ :id (bvalue :id bindings)
+ :status (bvalue :status bindings)
+ :caller-reference (bvalue :caller-reference bindings)
+ :domain-name (bvalue :domain-name bindings)
+ :origin-bucket (bvalue :origin bindings)
+ :cnames (mapcar (lambda (b) (bvalue :cname b))
+ (bvalue :cnames bindings))
+ :comment (bvalue :comment bindings)
+ :enabledp (equal (bvalue :enabled bindings) "true")
+ :last-modified (and timestamp
+ (parse-amazon-timestamp timestamp)))))
+
+;;; Distribution queries, creation, and manipulation
+
+(defun put-config (distribution)
+ "Post DISTRIBUTION's configuration to AWS. Signals an error and does
+not retry in the event of an etag match problem."
+ (multiple-value-bind (document headers code)
+ (distribution-request :distribution distribution
+ :url-suffix (format nil "/~A/config"
+ (id distribution))
+ :method :put)
+ (declare (ignore document headers))
+ (<= 200 code 299)))
+
+(defun latest-version (distribution)
+ (multiple-value-bind (document headers)
+ (distribution-request :url-suffix (format nil "/~A" (id distribution)))
+ (let ((new (bindings-distribution (xml-bind *distribution-binder*
+ document))))
+ (setf (etag new) (bvalue :etag headers))
+ new)))
+
+(defun merge-into (distribution new)
+ "Copy slot values from NEW into DISTRIBUTION."
+ (macrolet ((sync (accessor)
+ `(setf (,accessor distribution) (,accessor new))))
+ (sync origin-bucket)
+ (sync caller-reference)
+ (sync etag)
+ (sync enabledp)
+ (sync cnames)
+ (sync comment)
+ (sync domain-name)
+ (sync status)
+ (sync last-modified))
+ distribution)
+
+(defgeneric refresh (distribution)
+ (:documentation
+ "Pull down the latest data from AWS for DISTRIBUTION and update its slots.")
+ (:method ((distribution distribution))
+ (merge-into distribution (latest-version distribution))))
+
+(defun call-with-latest (fun distribution)
+ "Call FUN on DISTRIBUTION; if there is an ETag-related error,
+retries after REFRESHing DISTRIBUTION. FUN should not have side
+effects on anything but the DISTRIBUTION itself, as it may be re-tried
+multiple times."
+ (block nil
+ (tagbody
+ retry
+ (handler-bind
+ (((or invalid-if-match-version distribution-precondition-failed)
+ (lambda (c)
+ (declare (ignore c))
+ (setf distribution (refresh distribution))
+ (go retry))))
+ (return (funcall fun distribution))))))
+
+(defun modify-and-save (fun distribution)
+ "Call the modification function FUN with DISTRIBUTION as its only
+argument, and push the modified configuration to Cloudfront. May
+refresh DISTRIBUTION if needed. FUN should not have side effects on
+anything but the DISTRIBUTION itself, as it may be re-tried multiple
+times."
+ (call-with-latest (lambda (distribution)
+ (multiple-value-prog1
+ (funcall fun distribution)
+ (put-config distribution)))
+ distribution))
+
+(defmacro with-saved-modifications ((var distribution) &body body)
+ "Make a series of changes to DISTRIBUTION and push the final result
+to AWS. BODY should not have side-effects on anything but the
+DISTRIBUTION itself, as it may be re-tried multiple times."
+ `(modify-and-save (lambda (,var)
+ ,@body)
+ ,distribution))
+
+(defparameter *distribution-list-binder*
+ (make-binder
+ '("DistributionList"
+ ("Marker" (bind :marker))
+ (optional
+ ("NextMarker" (bind :next-marker)))
+ ("MaxItems" (bind :max-items))
+ ("IsTruncated" (bind :is-truncateD))
+ (sequence :distributions
+ ("DistributionSummary"
+ ("Id" (bind :id))
+ ("Status" (bind :status))
+ ("LastModifiedTime" (bind :last-modified-time))
+ ("DomainName" (bind :domain-name))
+ ("Origin" (bind :origin))
+ (sequence :cnames ("CNAME" (bind :cname)))
+ (optional ("Comment" (bind :comment)))
+ ("Enabled" (bind :enabled)))))))
+
+(defun all-distributions (&key ((:credentials *credentials*) *credentials*))
+ (let* ((document (distribution-request))
+ (bindings (xml-bind *distribution-list-binder* document)))
+ (mapcar (lambda (b)
+ (bindings-distribution b))
+ (bvalue :distributions bindings))))
+
+(defun create-distribution (bucket-name &key cnames (enabled t) comment)
+ (unless (listp cnames)
+ (setf cnames (list cnames)))
+ (let ((distribution (make-instance 'distribution
+ :origin-bucket bucket-name
+ :enabledp enabled
+ :comment comment
+ :cnames cnames)))
+ (let* ((document (distribution-request :method :post
+ :distribution distribution))
+ (bindings (xml-bind *distribution-binder* document)))
+ (bindings-distribution bindings))))
+
+(defun %delete-distribution (distribution)
+ (multiple-value-bind (document headers code)
+ (distribution-request :url-suffix (format nil "/~A" (id distribution))
+ :distribution distribution
+ :method :delete)
+ (declare (ignore document headers))
+ (= code 204)))
+
+(defgeneric delete-distribution (distribution)
+ (:method ((distribution distribution))
+ (call-with-latest #'%delete-distribution distribution)))
+
+(defgeneric enable (distribution)
+ (:documentation
+ "Mark DISTRIBUTION as enabled. Enabling can take time to take
+ effect; the STATUS of DISTRIBUTION will change from \"InProgress\"
+ to \"Deployed\" when fully enabled.")
+ (:method ((distribution distribution))
+ (with-saved-modifications (d distribution)
+ (setf (enabledp d) t))))
+
+
+(defgeneric disable (distribution)
+ (:documentation
+ "Mark DISTRIBUTION as disabled. Like ENABLE, DISABLE may take some
+ time to take effect.")
+ (:method ((distribution distribution))
+ (with-saved-modifications (d distribution)
+ (setf (enabledp d) nil)
+ t)))
+
+(defgeneric ensure-cname (distribution cname)
+ (:documentation
+ "Add CNAME to DISTRIBUTION's list of CNAMEs, if not already
+ present.")
+ (:method ((distribution distribution) cname)
+ (with-saved-modifications (d distribution)
+ (pushnew cname (cnames d)
+ :test #'string-equal))))
+
+(defgeneric remove-cname (distribution cname)
+ (:method (cname (distribution distribution))
+ (with-saved-modifications (d distribution)
+ (setf (cnames d)
+ (remove cname (cnames distribution)
+ :test #'string-equal)))))
+
+(defgeneric set-comment (distribution comment)
+ (:method ((distribution distribution) comment)
+ (with-saved-modifications (d distribution)
+ (setf (comment d) comment))))
+
+(defun distributions-for-bucket (bucket-name)
+ "Return a list of distributions that are associated with BUCKET-NAME."
+ (setf bucket-name (canonical-distribution-bucket-name bucket-name))
+ (remove bucket-name
+ (all-distributions)
+ :test-not #'string-equal
+ :key #'origin-bucket))
+
+
+;;; Invalidation
+
+(defclass invalidation ()
+ ((id
+ :initarg :id
+ :accessor id
+ :initform "*unset*"
+ :documentation "Amazon's assigned unique ID.")
+ (distribution
+ :initarg :distribution
+ :accessor distribution
+ :initform nil)
+ (create-time
+ :initarg :create-time
+ :initform 0
+ :accessor create-time)
+ (status
+ :initarg :status
+ :accessor status
+ :initform "InProgress")
+ (caller-reference
+ :initarg :caller-reference
+ :initform (generate-caller-reference)
+ :accessor caller-reference)
+ (paths
+ :initarg :paths
+ :accessor paths
+ :initform '())))
+
+(defmethod print-object ((invalidation invalidation) stream)
+ (print-unreadable-object (invalidation stream :type t)
+ (format stream "~S [~A]"
+ (id invalidation)
+ (status invalidation))))
+
+(defparameter *invalidation-batch-form*
+ '("InvalidationBatch"
+ (sequence :paths ("Path" (bind :path)))
+ ("CallerReference" (bind :caller-reference))))
+
+(defparameter *invalidation-form*
+ `("Invalidation"
+ ("Id" (bind :id))
+ ("Status" (bind :status))
+ ("CreateTime" (bind :create-time))
+ ,*invalidation-batch-form*))
+
+(defparameter *invalidation-batch-binder*
+ (make-binder *invalidation-batch-form*))
+
+(defparameter *invalidation-binder*
+ (make-binder *invalidation-form*))
+
+(defmethod merge-bindings ((invalidation invalidation) bindings)
+ (setf (id invalidation) (bvalue :id bindings)
+ (status invalidation) (bvalue :status bindings)
+ (create-time invalidation) (parse-amazon-timestamp
+ (bvalue :create-time bindings))
+ (paths invalidation)
+ (mapcar #'url-decode
+ (mapcar (bfun :path) (bvalue :paths bindings))))
+ invalidation)
+
+(defgeneric distribution-id (object)
+ (:method ((invalidation invalidation))
+ (id (distribution invalidation))))
+
+(defun invalidation-request (invalidation &key (url-suffix "")
+ (method :get) content)
+ (distribution-request :method method
+ :url-suffix (format nil "/~A/invalidation~A"
+ (distribution-id invalidation)
+ url-suffix)
+ :content content))
+
+(defun invalidation-batch-document (invalidation)
+ (cxml:with-xml-output (cxml:make-string-sink)
+ (cxml:with-element "InvalidationBatch"
+ (cxml:attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/")
+ (dolist (path (paths invalidation))
+ (cxml:with-element "Path"
+ (cxml:text path)))
+ (cxml:with-element "CallerReference"
+ (cxml:text (caller-reference invalidation))))))
+
+
+(defun invalidate-paths (distribution paths)
+ (let* ((invalidation (make-instance 'invalidation
+ :distribution distribution
+ :paths paths))
+ (response
+ (invalidation-request invalidation
+ :method :post
+ :content (invalidation-batch-document invalidation))))
+ (merge-bindings invalidation (xml-bind *invalidation-binder* response))))
+
+
+(defmethod refresh ((invalidation invalidation))
+ (let ((document
+ (invalidation-request invalidation
+ :url-suffix (format nil "/~A"
+ (id invalidation)))))
+ (merge-bindings invalidation (xml-bind *invalidation-binder* document))))
91 credentials.lisp
@@ -0,0 +1,91 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; credentials.lisp
+
+(in-package #:zs3)
+
+(defvar *credentials* nil
+ "Used as the default initarg value of :CREDENTIALS when creating a
+request.")
+
+(define-condition unsupported-credentials (error)
+ ((object
+ :initarg :object
+ :accessor unsupported-credentials-object))
+ (:report (lambda (c s)
+ (format s "The value ~A is unsupported as S3 credentials. (Did you set *CREDENTIALS*?)~@
+ See http://www.xach.com/lisp/zs3/#*credentials* ~
+ for supported credentials formats."
+ (unsupported-credentials-object c)))))
+
+(defgeneric access-key (credentials)
+ (:method (object)
+ (error 'unsupported-credentials :object object))
+ (:method ((list cons))
+ (first list)))
+
+(defgeneric secret-key (credentials)
+ (:method (object)
+ (error 'unsupported-credentials :object object))
+ (:method ((list cons))
+ (second list)))
+
+
+;;; Lazy-loading credentials
+
+(defclass lazy-credentials-mixin () ())
+
+(defmethod slot-unbound (class (credentials lazy-credentials-mixin)
+ (slot (eql 'access-key)))
+ (nth-value 0 (initialize-lazy-credentials credentials)))
+
+(defmethod slot-unbound (class (credentials lazy-credentials-mixin)
+ (slot (eql 'secret-key)))
+ (nth-value 1 (initialize-lazy-credentials credentials)))
+
+
+;;; Loading credentials from a file
+
+(defclass file-credentials (lazy-credentials-mixin)
+ ((file
+ :initarg :file
+ :accessor file)
+ (access-key
+ :accessor access-key)
+ (secret-key
+ :accessor secret-key)))
+
+(defgeneric initialize-lazy-credentials (credentials)
+ (:method ((credentials file-credentials))
+ (with-open-file (stream (file credentials))
+ (values (setf (access-key credentials) (read-line stream))
+ (setf (secret-key credentials) (read-line stream))))))
+
+(defun file-credentials (file)
+ (make-instance 'file-credentials
+ :file file))
88 crypto.lisp
@@ -0,0 +1,88 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; crypto.lisp
+
+(in-package #:zs3)
+
+(defclass digester ()
+ ((hmac
+ :initarg :hmac
+ :accessor hmac)
+ (newline
+ :initarg :newline
+ :accessor newline
+ :allocation :class)
+ (signed-stream
+ :initarg :signed-stream
+ :accessor signed-stream))
+ (:default-initargs
+ :signed-stream (make-string-output-stream)
+ :newline (make-array 1 :element-type '(unsigned-byte 8)
+ :initial-element 10)))
+
+(defun make-digester (key)
+ (let ((hmac (ironclad:make-hmac (string-octets key) :sha1)))
+ (make-instance 'digester
+ :hmac hmac)))
+
+(defgeneric add-string (string digester)
+ (:method (string digester)
+ (write-string string (signed-stream digester))
+ (ironclad:update-hmac (hmac digester) (string-octets string))))
+
+(defgeneric add-newline (digester)
+ (:method (digester)
+ (terpri (signed-stream digester))
+ (ironclad:update-hmac (hmac digester) (newline digester))))
+
+(defgeneric add-line (string digester)
+ (:method (string digester)
+ (add-string string digester)
+ (add-newline digester)))
+
+(defgeneric digest64 (digester)
+ (:method (digester)
+ (base64:usb8-array-to-base64-string
+ (ironclad:hmac-digest (hmac digester)))))
+
+(defun file-md5 (file)
+ (ironclad:digest-file :md5 file))
+
+(defun file-md5/b64 (file)
+ (base64:usb8-array-to-base64-string (file-md5 file)))
+
+(defun file-md5/hex (file)
+ (ironclad:byte-array-to-hex-string (file-md5 file)))
+
+(defun file-etag (file)
+ (format nil "\"~A\"" (file-md5/hex file)))
+
+(defun sign-string (key string)
+ (let ((digester (make-digester key)))
+ (add-string string digester)
+ (digest64 digester)))
27 doc/LICENSE
@@ -0,0 +1,27 @@
+;;;;
+;;;; 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.
+;;;;
2,559 doc/index.html
2,559 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
82 doc/style.css
@@ -0,0 +1,82 @@
+
+body {
+ margin-left: 4em;
+ font: small/1.2em "Lucida Grande", "Trebuchet MS", "Bitstream Vera Sans", Verdana, Helvetica, sans-serif;
+
+}
+
+p.copyright {
+ font-size: 75%;
+ font-weight: bold;
+}
+
+#content {
+ margin-left: 4em;
+ margin-right: 12em;
+}
+
+h2, h3 {
+ margin-bottom: 0em;
+ margin-top: 2em;
+}
+
+p.html {
+ margin-left: 1em;
+ font-family: monospace;
+}
+
+.type {
+ color: #999;
+}
+
+.signature {
+ color: #A01;
+ margin-left: 1em;
+}
+
+.signature span.result {
+ color: black;
+}
+
+.signature code.llkw {
+ font-family: monospace;
+}
+
+.signature span.result var {
+ color: #A01;
+}
+
+div.signature {
+ margin-left: 1.5em;
+ text-indent: -1.5em;
+}
+
+.signature code.name {
+ font-weight: bold;
+}
+
+.signature code {
+ font-family: sans-serif;
+}
+
+blockquote.description {
+ margin-left: 1em;
+}
+
+a[href] {
+ text-decoration: none;
+ border-bottom: dotted 1px #CCC;
+ color: #600;
+}
+
+a:hover[href] {
+ text-decoration: none;
+ border-bottom: solid 1px #F00;
+ color: #F00;
+}
+
+pre.code {
+ border: solid 1px #DDD;
+ padding: 0.5em;
+ background: #EEE;
+}
228 errors.lisp
@@ -0,0 +1,228 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; errors.lisp
+
+(in-package #:zs3)
+
+(defvar *error-binder*
+ (make-binder
+ '("Error"
+ ("Code" (bind :code))
+ ("Message" (bind :message))
+ (elements-alist :data))))
+
+(defclass amazon-error (response)
+ ((code
+ :initarg :code
+ :accessor code)
+ (message
+ :initarg :message
+ :accessor message)
+ (error-data
+ :initarg :error-data
+ :accessor error-data)))
+
+(set-element-class "Error" 'amazon-error)
+
+(defgeneric error-data-value (name instance)
+ (:method (name (response amazon-error))
+ (cdr (assoc name (error-data response) :test #'equalp))))
+
+(defmethod specialized-initialize ((response amazon-error) source)
+ (let ((bindings (xml-bind *error-binder* source)))
+ (setf (code response) (bvalue :code bindings))
+ (setf (message response) (bvalue :message bindings))
+ (setf (error-data response) (bvalue :data bindings))))
+
+(defmethod print-object ((response amazon-error) stream)
+ (print-unreadable-object (response stream :type t)
+ (prin1 (code response) stream)))
+
+;;; Further specializing error messages/conditions
+
+(defun report-request-error (condition stream)
+ (format stream "~A: ~A"
+ (code (request-error-response condition))
+ (message (request-error-response condition))))
+
+(define-condition request-error (error)
+ ((request
+ :initarg :request
+ :reader request-error-request)
+ (response
+ :initarg :response
+ :reader request-error-response)
+ (data
+ :initarg :data
+ :reader request-error-data))
+ (:report report-request-error))
+
+(defparameter *specific-errors* (make-hash-table :test 'equalp))
+
+(defun specific-error (amazon-code)
+ (gethash amazon-code *specific-errors* 'request-error))
+
+(defgeneric signal-specific-error (response condition-name)
+ (:method (response condition-name)
+ (error 'request-error
+ :request (request response)
+ :response response
+ :data (error-data response))))
+
+(defgeneric maybe-signal-error (response)
+ (:method (response)
+ t)
+ (:method ((response amazon-error))
+ (signal-specific-error response (specific-error (code response)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun error-reader-name (suffix)
+ (intern (concatenate 'string (symbol-name 'request-error)
+ "-"
+ (symbol-name suffix))
+ :zs3)))
+
+(defmacro define-specific-error ((condition-name code)
+ superclasses
+ slots &rest options)
+ (labels ((slot-name (slot)
+ (first slot))
+ (slot-code (slot)
+ (second slot))
+ (slot-keyword (slot)
+ (keywordify (slot-name slot)))
+ (slot-definition (slot)
+ `(,(slot-name slot)
+ :initarg ,(slot-keyword slot)
+ :reader ,(error-reader-name (slot-name slot))))
+ (slot-initializer (slot)
+ (list (slot-keyword slot)
+ `(error-data-value ,(slot-code slot) response))))
+ `(progn
+ (setf (gethash ,code *specific-errors*) ',condition-name)
+ (define-condition ,condition-name (,@superclasses request-error)
+ ,(mapcar #'slot-definition slots)
+ ,@options)
+ (defmethod signal-specific-error ((response amazon-error)
+ (condition-name (eql ',condition-name)))
+ (error ',condition-name
+ :request (request response)
+ :response response
+ :data (error-data response)
+ ,@(mapcan #'slot-initializer slots))))))
+
+
+;;; The specific errors
+
+(define-specific-error (internal-error "InternalError") () ())
+
+(define-specific-error (slow-down "SlowDown") () ())
+
+(define-specific-error (no-such-bucket "NoSuchBucket") ()
+ ((bucket-name "BucketName")))
+
+(define-specific-error (no-such-key "NoSuchKey") ()
+ ((key-name "Key")))
+
+(define-specific-error (access-denied "AccessDenied") () ())
+
+(define-specific-error (malformed-xml "MalformedXML") () ())
+
+(define-condition redirect-error () ())
+
+(define-specific-error (permanent-redirect "PermanentRedirect") (redirect-error)
+ ((endpoint "Endpoint")))
+
+(define-specific-error (temporary-redirect "TemporaryRedirect") (redirect-error)
+ ((endpoint "Endpoint")))
+
+(define-specific-error (signature-mismatch "SignatureDoesNotMatch") ()
+ ((string-to-sign "StringToSign"))
+ (:report (lambda (condition stream)
+ (report-request-error condition stream)
+ (format stream "You signed: ~S~%Amazon signed: ~S"
+ (signed-string (request-error-request condition))
+ (request-error-string-to-sign condition)))))
+
+(define-specific-error (precondition-failed "PreconditionFailed") ()
+ ((condition "Condition")))
+
+
+
+(define-condition linked ()
+ ((url
+ :initarg :url
+ :reader linked-url))
+ (:report (lambda (condition stream)
+ (report-request-error condition stream)
+ (format stream "~&For more information, see:~% ~A"
+ (linked-url condition)))))
+
+
+(define-condition bucket-restrictions (linked)
+ ()
+ (:default-initargs
+ :url "http://docs.amazonwebservices.com/AmazonS3/2006-03-01/BucketRestrictions.html"))
+
+(define-specific-error (invalid-bucket-name "InvalidBucketName")
+ (bucket-restrictions)
+ ())
+
+(define-specific-error (bucket-exists "BucketAlreadyExists")
+ (bucket-restrictions)
+ ())
+
+(define-specific-error (too-many-buckets "TooManyBuckets")
+ (bucket-restrictions)
+ ())
+
+
+(define-specific-error (ambiguous-grant "AmbiguousGrantByEmailAddress") (linked)
+ ()
+ (:default-initargs
+ :url "http://docs.amazonwebservices.com/AmazonS3/2006-03-01/S3_ACLs.html"))
+
+(define-specific-error (bucket-not-empty "BucketNotEmpty") (linked)
+ ()
+ (:default-initargs
+ :url "http://docs.amazonwebservices.com/AmazonS3/2006-03-01/RESTBucketDELETE.html"))
+
+(define-specific-error (invalid-logging-target "InvalidTargetBucketForLogging")
+ () ())
+
+(define-specific-error (key-too-long "KeyTooLong") (linked)
+ ()
+ (:default-initargs
+ :url "http://docs.amazonwebservices.com/AmazonS3/2006-03-01/UsingKeys.html"))
+
+(define-specific-error (request-time-skewed "RequestTimeTooSkewed") (linked)
+ ()
+ (:default-initargs
+ :url "http://docs.amazonwebservices.com/AmazonS3/2006-03-01/RESTAuthentication.html"))
+
+(define-specific-error (operation-aborted "OperationAborted") () ())
770 interface.lisp
@@ -0,0 +1,770 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; interface.lisp
+
+(in-package #:zs3)
+
+(defparameter *canned-access-policies*
+ '((:private . "private")
+ (:public-read . "public-read")
+ (:public-read-write . "public-read-write")
+ (:authenticated-read . "authenticated-read")))
+
+(defun canned-access-policy (access-policy)
+ (let ((value (assoc access-policy *canned-access-policies*)))
+ (unless value
+ (error "~S is not a supported access policy.~%Supported policies are ~S"
+ access-policy
+ (mapcar 'first *canned-access-policies*)))
+ (list (cons "acl" (cdr value)))))
+
+(defun access-policy-header (access-policy public)
+ (cond ((and access-policy public)
+ (error "Only one of ~S and ~S should be provided"
+ :public :access-policy))
+ (public
+ (canned-access-policy :public-read))
+ (access-policy
+ (canned-access-policy access-policy))))
+
+(defun head (&key bucket key parameters
+ ((:credentials *credentials*) *credentials*))
+ "Return three values: the HTTP status, an alist of Drakma-style HTTP
+headers, and the HTTP phrase, with the results of a HEAD request for
+the object specified by the optional BUCKET and KEY arguments."
+ (let ((response
+ (submit-request (make-instance 'request
+ :method :head
+ :bucket bucket
+ :key key
+ :parameters parameters))))
+
+ (values (http-headers response)
+ (http-code response)
+ (http-phrase response))))
+
+;;; Operations on buckets
+
+(defun all-buckets (&key ((:credentials *credentials*) *credentials*))
+ "Return a vector of all BUCKET objects associated with *CREDENTIALS*."
+ (let ((response (submit-request (make-instance 'request
+ :method :get))))
+ (buckets response)))
+
+(defun bucket-location (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ "If BUCKET was created with a LocationConstraint, return its
+constraint."
+ (let* ((request (make-instance 'request
+ :method :get
+ :sub-resource "location"
+ :bucket bucket))
+ (response (submit-request request))
+ (location (location response)))
+ (when (plusp (length location))
+ location)))
+
+(defun query-bucket (bucket &key prefix marker max-keys delimiter
+ ((:credentials *credentials*) *credentials*))
+ (submit-request (make-instance 'request
+ :method :get
+ :bucket bucket
+ :parameters
+ (parameters-alist
+ :prefix prefix
+ :marker marker
+ :max-keys max-keys
+ :delimiter delimiter))))
+
+(defun continue-bucket-query (response)
+ (when response
+ (let ((request (successive-request response)))
+ (when request
+ (submit-request request)))))
+
+(defun all-keys (bucket &key prefix
+ ((:credentials *credentials*) *credentials*))
+ "Reutrn a vector of all KEY objects in BUCKET."
+ (let ((response (query-bucket bucket :prefix prefix))
+ (results '()))
+ (loop
+ (unless response
+ (return))
+ (push (keys response) results)
+ (setf response (continue-bucket-query response)))
+ (let ((combined (make-array (reduce #'+ results :key #'length)))
+ (start 0))
+ (dolist (keys (nreverse results) combined)
+ (replace combined keys :start1 start)
+ (incf start (length keys))))))
+
+(defun bucket-exists-p (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ (let ((code (nth-value 1 (head :bucket bucket
+ :parameters
+ (parameters-alist :max-keys 0)))))
+ (not (<= 400 code 599))))
+
+(defun create-bucket (name &key
+ access-policy
+ public
+ location
+ ((:credentials *credentials*) *credentials*))
+ (let ((policy-header (access-policy-header access-policy public)))
+ (submit-request (make-instance 'request
+ :method :put
+ :bucket name
+ :content (and location
+ (location-constraint-xml
+ location))
+ :amz-headers policy-header))))
+
+(defun delete-bucket (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ (let* ((request (make-instance 'request
+ :method :delete
+ :bucket bucket))
+ (endpoint (endpoint request))
+ (bucket (bucket request)))
+ (prog1
+ (submit-request request)
+ (setf (redirected-endpoint endpoint bucket) nil))))
+
+
+;;; Getting objects as vectors, strings, or files
+
+(defun check-request-success (response)
+ (let ((code (http-code response)))
+ (cond ((= code 304)
+ (throw 'not-modified (values nil (http-headers response))))
+ ((not (<= 200 code 299))
+ (setf response (specialize-response response))
+ (maybe-signal-error response)))))
+
+(defun make-file-writer-handler (file &key (if-exists :supersede))
+ (lambda (response)
+ (check-request-success response)
+ (with-open-stream (input (body response))
+ (with-open-file (output file :direction :output
+ :if-exists if-exists
+ :element-type '(unsigned-byte 8))
+ (copy-n-octets (content-length response) input output)))
+ (setf (body response) (probe-file file))
+ response))
+
+(defun vector-writer-handler (response)
+ (check-request-success response)
+ (let ((buffer (make-octet-vector (content-length response))))
+ (setf (body response)
+ (with-open-stream (input (body response))
+ (read-sequence buffer input)
+ buffer))
+ response))
+
+(defun make-string-writer-handler (external-format)
+ (lambda (response)
+ (setf response (vector-writer-handler response))
+ (setf (body response)
+ (flexi-streams:octets-to-string (body response)
+ :external-format external-format))
+ response))
+
+(defun get-object (bucket key &key
+ when-modified-since
+ unless-modified-since
+ when-etag-matches
+ unless-etag-matches
+ start end
+ (output :vector)
+ (if-exists :supersede)
+ (string-external-format :utf-8)
+ ((:credentials *credentials*) *credentials*))
+ (flet ((range-argument (start end)
+ (when start
+ (format nil "bytes=~D-~@[~D~]" start (and end (1- end)))))
+ (maybe-date (time)
+ (and time (http-date-string time))))
+ (when (and end (not start))
+ (setf start 0))
+ (when (and start end (<= end start))
+ (error "START must be less than END."))
+ (let ((request (make-instance 'request
+ :method :get
+ :bucket bucket
+ :key key
+ :extra-http-headers
+ (parameters-alist
+ :connection "close"
+ :if-modified-since
+ (maybe-date when-modified-since)
+ :if-unmodified-since
+ (maybe-date unless-modified-since)
+ :if-match when-etag-matches
+ :if-none-match unless-etag-matches
+ :range (range-argument start end))))
+ (handler (cond ((eql output :vector)
+ 'vector-writer-handler)
+ ((eql output :string)
+ (make-string-writer-handler string-external-format))
+ ((or (stringp output)
+ (pathnamep output))
+ (make-file-writer-handler output :if-exists if-exists))
+ (t
+ (error "Unknown ~S option ~S -- should be ~
+ :VECTOR, :STRING, or a pathname"
+ :output output)))))
+ (catch 'not-modified
+ (handler-case
+ (let ((response (submit-request request
+ :body-stream t
+ :handler handler)))
+ (values (body response) (http-headers response)))
+ (precondition-failed (c)
+ (throw 'not-modified
+ (values nil
+ (http-headers (request-error-response c))))))))))
+
+(defun get-vector (bucket key
+ &key start end
+ when-modified-since unless-modified-since
+ when-etag-matches unless-etag-matches
+ (if-exists :supersede)
+ ((:credentials *credentials*) *credentials*))
+ (get-object bucket key
+ :output :vector
+ :start start
+ :end end
+ :when-modified-since when-modified-since
+ :unless-modified-since unless-modified-since
+ :when-etag-matches when-etag-matches
+ :unless-etag-matches unless-etag-matches
+ :if-exists if-exists))
+
+(defun get-string (bucket key
+ &key start end
+ (external-format :utf-8)
+ when-modified-since unless-modified-since
+ when-etag-matches unless-etag-matches
+ (if-exists :supersede)
+ ((:credentials *credentials*) *credentials*))
+ (get-object bucket key
+ :output :string
+ :string-external-format external-format
+ :start start
+ :end end
+ :when-modified-since when-modified-since
+ :unless-modified-since unless-modified-since
+ :when-etag-matches when-etag-matches
+ :unless-etag-matches unless-etag-matches
+ :if-exists if-exists))
+
+(defun get-file (bucket key file
+ &key start end
+ when-modified-since unless-modified-since
+ when-etag-matches unless-etag-matches
+ (if-exists :supersede)
+ ((:credentials *credentials*) *credentials*))
+ (get-object bucket key
+ :output (pathname file)
+ :start start
+ :end end
+ :when-modified-since when-modified-since
+ :unless-modified-since unless-modified-since
+ :when-etag-matches when-etag-matches
+ :unless-etag-matches unless-etag-matches
+ :if-exists if-exists))
+
+
+;;; Putting objects
+
+
+(defun put-object (object bucket key &key
+ access-policy
+ public
+ metadata
+ (string-external-format :utf-8)
+ cache-control
+ content-encoding
+ content-disposition
+ expires
+ content-type
+ ((:credentials *credentials*) *credentials*))
+ (let ((content
+ (etypecase object
+ (string
+ (flexi-streams:string-to-octets object
+ :external-format
+ string-external-format))
+ ((or vector pathname) object)))
+ (content-length t)
+ (policy-header (access-policy-header access-policy public)))
+ (submit-request (make-instance 'request
+ :method :put
+ :bucket bucket
+ :key key
+ :metadata metadata
+ :amz-headers policy-header
+ :extra-http-headers
+ (parameters-alist
+ :cache-control cache-control
+ :content-encoding content-encoding
+ :content-disposition content-disposition
+ :expires (and expires
+ (http-date-string expires)))
+ :content-type content-type
+ :content-length content-length
+ :content content))))
+
+
+(defun put-vector (vector bucket key &key
+ start end
+ access-policy
+ public
+ metadata
+ cache-control
+ content-encoding
+ content-disposition
+ (content-type "binary/octet-stream")
+ expires
+ ((:credentials *credentials*) *credentials*))
+ (when (or start end)
+ (setf vector (subseq vector (or start 0) end)))
+ (put-object vector bucket key
+ :access-policy access-policy
+ :public public
+ :metadata metadata
+ :cache-control cache-control
+ :content-encoding content-encoding
+ :content-disposition content-disposition
+ :content-type content-type
+ :expires expires))
+
+(defun put-string (string bucket key &key
+ start end
+ access-policy
+ public
+ metadata
+ (external-format :utf-8)
+ cache-control
+ content-encoding
+ content-disposition
+ (content-type "text/plain")
+ expires
+ ((:credentials *credentials*) *credentials*))
+ (when (or start end)
+ (setf string (subseq string (or start 0) end)))
+ (put-object string bucket key
+ :access-policy access-policy
+ :public public
+ :metadata metadata
+ :expires expires
+ :content-disposition content-disposition
+ :content-encoding content-encoding
+ :content-type content-type
+ :cache-control cache-control
+ :string-external-format external-format))
+
+
+(defun put-file (file bucket key &key
+ start end
+ access-policy
+ public
+ metadata
+ cache-control
+ content-disposition
+ content-encoding
+ (content-type "binary/octet-stream")
+ expires
+ ((:credentials *credentials*) *credentials*))
+ (when (eq key t)
+ (setf key (file-namestring file)))
+ (let ((content (pathname file)))
+ (when (or start end)
+ ;;; FIXME: integrate with not-in-memory file uploading
+ (setf content (file-subset-vector file start end)))
+ (put-object content bucket key
+ :access-policy access-policy
+ :public public
+ :metadata metadata
+ :cache-control cache-control
+ :content-disposition content-disposition
+ :content-encoding content-encoding
+ :content-type content-type
+ :expires expires)))
+
+(defun put-stream (stream bucket key &key
+ (start 0) end
+ access-policy
+ public
+ metadata
+ cache-control
+ content-disposition
+ content-encoding
+ (content-type "binary/octet-stream")
+ expires
+ ((:credentials *credentials*) *credentials*))
+ (let ((content (stream-subset-vector stream start end)))
+ (put-object content bucket key
+ :access-policy access-policy
+ :public public
+ :metadata metadata
+ :cache-control cache-control
+ :content-disposition content-disposition
+ :content-encoding content-encoding
+ :content-type content-type
+ :expires expires)))
+
+
+;;; Delete & copy objects
+
+(defun delete-object (bucket key &key
+ ((:credentials *credentials*) *credentials*))
+ "Delete one object from BUCKET identified by KEY."
+ (submit-request (make-instance 'request
+ :method :delete
+ :bucket bucket
+ :key key)))
+
+(defun delete-objects (bucket keys &key
+ ((:credentials *credentials*) *credentials*))
+ "Delete the objects in BUCKET identified by KEYS."
+ (map nil
+ (lambda (key)
+ (delete-object bucket key))
+ keys)
+ (length keys))
+
+(defun delete-all-objects (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ "Delete all objects in BUCKET."
+ (delete-objects bucket (all-keys bucket)))
+
+(defun copy-object (&key
+ from-bucket from-key
+ to-bucket to-key
+ when-etag-matches
+ unless-etag-matches
+ when-modified-since
+ unless-modified-since
+ (metadata nil metadata-supplied-p)
+ access-policy
+ public
+ precondition-errors
+ ((:credentials *credentials*) *credentials*))
+ "Copy the object identified by FROM-BUCKET/FROM-KEY to
+TO-BUCKET/TO-KEY.
+
+If TO-BUCKET is NIL, uses FROM-BUCKET as the target. If TO-KEY is NIL,
+uses TO-KEY as the target.
+
+If METADATA is provided, it should be an alist of metadata keys and
+values to set on the new object. Otherwise, the source object's
+metadata is copied.
+
+Optional precondition variables are WHEN-ETAG-MATCHES,
+UNLESS-ETAG-MATCHES, WHEN-MODIFIED-SINCE, UNLESS-MODIFIED-SINCE. The
+etag variables use an etag as produced by the FILE-ETAG function,
+i.e. a lowercase hex representation of the file's MD5 digest,
+surrounded by quotes. The modified-since variables should use a
+universal time.
+
+If PUBLIC is T, the new object is visible to all
+users. Otherwise, a default ACL is present on the new object.
+"
+ (unless from-bucket
+ (error "FROM-BUCKET is required"))
+ (unless from-key
+ (error "FROM-KEY is required"))
+ (unless (or to-bucket to-key)
+ (error "Can't copy an object to itself."))
+ (setf to-bucket (or to-bucket from-bucket))
+ (setf to-key (or to-key from-key))
+ (handler-bind ((precondition-failed
+ (lambda (condition)
+ (unless precondition-errors
+ (return-from copy-object
+ (values nil (request-error-response condition)))))))
+ (let ((headers
+ (parameters-alist :copy-source (format nil "~A/~A"
+ (url-encode (name from-bucket))
+ (url-encode (name from-key)))
+ :metadata-directive
+ (if metadata-supplied-p "REPLACE" "COPY")
+ :copy-source-if-match when-etag-matches
+ :copy-source-if-none-match unless-etag-matches
+ :copy-source-if-modified-since
+ (and when-modified-since
+ (http-date-string when-modified-since))
+ :copy-source-if-unmodified-since
+ (and unless-modified-since
+ (http-date-string unless-modified-since))))
+ (policy-header (access-policy-header access-policy public)))
+ (submit-request (make-instance 'request
+ :method :put
+ :bucket to-bucket
+ :key to-key
+ :metadata metadata
+ :amz-headers
+ (nconc headers policy-header))))))
+
+
+(defun object-metadata (bucket key &key
+ ((:credentials *credentials*) *credentials*))
+ "Return the metadata headers as an alist, with keywords for the keys."
+ (let* ((prefix "X-AMZ-META-")
+ (plen (length prefix)))
+ (flet ((metadata-symbol-p (k)
+ (and (< plen (length (symbol-name k)))
+ (string-equal k prefix :end1 plen)
+ (intern (subseq (symbol-name k) plen)
+ :keyword))))
+ (let ((headers (head :bucket bucket :key key)))
+ (loop for ((k . value)) on headers
+ for meta = (metadata-symbol-p k)
+ when meta
+ collect (cons meta value))))))
+
+
+;;; ACL twiddling
+
+(defparameter *public-read-grant*
+ (make-instance 'grant
+ :permission :read
+ :grantee *all-users*)
+ "This grant is added to or removed from an ACL to grant or revoke
+ read access for all users.")
+
+(defun get-acl (&key bucket key
+ ((:credentials *credentials*) *credentials*))
+ (let* ((request (make-instance 'request
+ :method :get
+ :bucket bucket
+ :key key
+ :sub-resource "acl"))
+ (response (submit-request request))
+ (acl (acl response)))
+ (values (owner acl)
+ (grants acl))))
+
+(defun put-acl (owner grants &key bucket key
+ ((:credentials *credentials*) *credentials*))
+ (let* ((acl (make-instance 'access-control-list
+ :owner owner
+ :grants grants))
+ (request (make-instance 'request
+ :method :put
+ :bucket bucket
+ :key key
+ :sub-resource "acl"
+ :content (acl-serialize acl))))
+ (submit-request request)))
+
+
+(defun make-public (&key bucket key
+ ((:credentials *credentials*) *credentials*))
+ (multiple-value-bind (owner grants)
+ (get-acl :bucket bucket :key key)
+ (put-acl owner
+ (cons *public-read-grant* grants)
+ :bucket bucket
+ :key key)))
+
+(defun make-private (&key bucket key
+ ((:credentials *credentials*) *credentials*))
+ (multiple-value-bind (owner grants)
+ (get-acl :bucket bucket :key key)
+ (setf grants
+ (remove *all-users* grants
+ :test #'acl-eqv :key #'grantee))
+ (put-acl owner grants :bucket bucket :key key)))
+
+
+
+;;; Logging
+
+(defparameter *log-delivery-grants*
+ (list (make-instance 'grant
+ :permission :write
+ :grantee *log-delivery*)
+ (make-instance 'grant
+ :permission :read-acl
+ :grantee *log-delivery*))
+ "This list of grants is used to allow the Amazon log delivery group
+to write logfile objects into a particular bucket.")
+
+(defun enable-logging-to (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ "Configure the ACL of BUCKET to accept logfile objects."
+ (multiple-value-bind (owner grants)
+ (get-acl :bucket bucket)
+ (setf grants (append *log-delivery-grants* grants))
+ (put-acl owner grants :bucket bucket)))
+
+(defun disable-logging-to (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ "Configure the ACL of BUCKET to remove permissions for the log
+delivery group."
+ (multiple-value-bind (owner grants)
+ (get-acl :bucket bucket)
+ (setf grants (remove-if (lambda (grant)
+ (acl-eqv (grantee grant) *log-delivery*))
+ grants))
+ (put-acl owner grants :bucket bucket)))
+
+(defun enable-logging (bucket target-bucket target-prefix &key
+ target-grants
+ ((:credentials *credentials*) *credentials*))
+ "Enable logging of requests to BUCKET, putting logfile objects into
+TARGET-BUCKET with a key prefix of TARGET-PREFIX."
+ (let* ((setup (make-instance 'logging-setup
+ :target-bucket target-bucket
+ :target-prefix target-prefix
+ :target-grants target-grants))
+ (request (make-instance 'request
+ :method :put
+ :sub-resource "logging"
+ :bucket bucket
+ :content (log-serialize setup)))
+ (retried nil))
+ (loop
+ (handler-case
+ (return (submit-request request))
+ (invalid-logging-target (condition)
+ (when (starts-with "You must give the log-delivery group"
+ (message (request-error-response condition)))
+ (unless retried
+ (setf retried t)
+ (enable-logging-to target-bucket))))))))
+
+
+(defparameter *empty-logging-setup*
+ (log-serialize (make-instance 'logging-setup))
+ "An empty logging setup; putting this into the logging setup of a
+ bucket effectively disables logging.")
+
+(defun disable-logging (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ "Disable the creation of access logs for BUCKET."
+ (submit-request (make-instance 'request
+ :method :put
+ :sub-resource "logging"
+ :bucket bucket
+ :content *empty-logging-setup*)))
+
+(defun logging-setup (bucket &key
+ ((:credentials *credentials*) *credentials*))
+ (let ((setup (setup
+ (submit-request (make-instance 'request
+ :bucket bucket
+ :sub-resource "logging")))))
+ (values (target-bucket setup)
+ (target-prefix setup)
+ (target-grants setup))))
+
+
+
+;;; Creating unauthorized and authorized URLs for a resource
+
+(defclass url-based-request (request)
+ ((expires
+ :initarg :expires
+ :accessor expires))
+ (:default-initargs
+ :expires 0))
+
+(defmethod date-string ((request url-based-request))
+ (format nil "~D" (expires request)))
+
+(defun resource-url (&key bucket key vhost ssl sub-resource)
+ (case vhost
+ (:cname
+ (format nil "http~@[s~*~]://~A/~@[~A~]~@[?~A~]"
+ ssl bucket (url-encode key) sub-resource))
+ (:amazon
+ (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]~@[?~A~]"
+ ssl bucket (url-encode key) sub-resource))
+ ((nil)
+ (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]~@[?~A~]"
+ ssl (url-encode bucket) (url-encode key) sub-resource))))
+
+(defun authorized-url (&key bucket key vhost expires ssl sub-resource
+ ((:credentials *credentials*) *credentials*))
+ (unless (and expires (integerp expires) (plusp expires))
+ (error "~S option must be a positive integer" :expires))
+ (let* ((request (make-instance 'url-based-request
+ :method :get
+ :bucket bucket
+ :sub-resource sub-resource
+ :key key
+ :expires (unix-time expires)))
+ (parameters
+ (alist-to-url-encoded-string
+ (list (cons "AWSAccessKeyId" (access-key *credentials*))
+ (cons "Expires" (format nil "~D" (expires request)))
+ (cons "Signature"
+ (signature request))))))
+ (case vhost
+ (:cname
+ (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
+ ssl bucket (url-encode key) sub-resource parameters))
+ (:amazon
+ (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A"
+ ssl bucket (url-encode key) sub-resource parameters))
+ ((nil)
+ (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A"
+ ssl (url-encode bucket) (url-encode key) sub-resource
+ parameters)))))
+
+
+;;; Miscellaneous operations
+
+(defparameter *me-cache*
+ (make-hash-table :test 'equal)
+ "A cache for the result of the ME function. Keys are Amazon access
+ key strings.")
+
+(defun me (&key
+ ((:credentials *credentials*) *credentials*))
+ "Return a PERSON object corresponding to the current credentials. Cached."
+ (or (gethash (access-key *credentials*) *me-cache*)
+ (setf
+ (gethash (access-key *credentials*) *me-cache*)
+ (let ((response (submit-request (make-instance 'request))))
+ (owner response)))))
+
+(defun make-post-policy (&key expires conditions
+ ((:credentials *credentials*) *credentials*))
+ "Return an encoded HTTP POST policy string and policy signature as
+multiple values."
+ (unless expires
+ (error "~S is required" :expires))
+ (let ((policy (make-instance 'post-policy
+ :expires expires
+ :conditions conditions)))
+ (values (policy-string64 policy)
+ (policy-signature (secret-key *credentials*) policy))))
51 location.lisp
@@ -0,0 +1,51 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; location.lisp
+
+(in-package #:zs3)
+
+(defparameter *location-binder*
+ (make-binder '("LocationConstraint" (bind :location))))
+
+(defclass location-constraint (response)
+ ((location
+ :initarg :location
+ :accessor location)))
+
+(set-element-class "LocationConstraint" 'location-constraint)
+
+(defmethod specialized-initialize ((response location-constraint) source)
+ (let ((bindings (xml-bind *location-binder* source)))
+ (setf (location response) (bvalue :location bindings))
+ response))
+
+(defun location-constraint-xml (location)
+ (format nil "<CreateBucketConfiguration>~
+ <LocationConstraint>~A</LocationConstraint>~
+ </CreateBucketConfiguration>"
+ location))
96 logging.lisp
@@ -0,0 +1,96 @@
+;;;;
+;;;; 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.
+;;;;
+;;;; logging.lisp
+
+(in-package #:zs3)
+
+(defclass logging-setup ()
+ ((target-bucket
+ :initarg :target-bucket
+ :accessor target-bucket)
+ (target-prefix
+ :initarg :target-prefix
+ :accessor target-prefix)
+ (target-grants
+ :initarg :target-grants
+ :accessor target-grants))
+ (:default-initargs
+ :target-bucket nil
+ :target-prefix nil
+ :target-grants nil))
+
+(defclass logging (response)
+ ((setup
+ :initarg :setup
+ :accessor setup)))
+
+(defparameter *logging-binder*
+ (make-binder '("BucketLoggingStatus"
+ (optional
+ ("LoggingEnabled"
+ ("TargetBucket" (bind :target-bucket))
+ ("TargetPrefix" (bind :target-prefix))
+ (optional
+ ("TargetGrants"
+ (sequence :target-grants
+ ("Grant"
+ ("Grantee"
+ (elements-alist :grantee))
+ ("Permission" (bind :permission)))))))))))
+
+
+(defun bindings-logging-setup (bindings)
+ (alist-bind (target-bucket target-prefix target-grants)
+ bindings
+ (make-instance 'logging-setup
+ :target-bucket target-bucket
+ :target-prefix target-prefix
+ :target-grants (mapcar 'alist-grant target-grants))))
+
+(defgeneric log-serialize (object)
+ (:method ((logging-setup logging-setup))
+ (cxml:with-xml-output (cxml:make-octet-vector-sink)
+ (cxml:with-element "BucketLoggingStatus"
+ (when (target-bucket logging-setup)
+ (cxml:with-element "LoggingEnabled"
+ (simple-element "TargetBucket" (target-bucket logging-setup))
+ (simple-element "TargetPrefix" (target-prefix logging-setup))
+ (when (target-grants logging-setup)
+ (cxml:with-element "TargetGrants"
+ (dolist (grant (target-grants logging-setup))
+ (acl-serialize grant))))))))))
+
+
+(set-element-class "BucketLoggingStatus" 'logging)
+
+(defmethod specialized-initialize ((response logging) source)
+ (let ((bindings (xml-bind *logging-binder* source)))
+ (setf (setup response)
+ (bindings-logging-setup bindings))
+ response))
+
78 objects.lisp
@@ -0,0 +1,78 @@
+;;;;
+;;;; 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