pax_global_header00006660000000000000000000000064132200370170014505gustar00rootroot0000000000000052 comment=bab5017b56dbcc6d9b6def68eb59e443ce50b4c1 zs3-1.3.1/000077500000000000000000000000001322003701700122265ustar00rootroot00000000000000zs3-1.3.1/.gitignore000066400000000000000000000000071322003701700142130ustar00rootroot00000000000000*.fasl zs3-1.3.1/LICENSE000066400000000000000000000025551322003701700132420ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; zs3-1.3.1/README000066400000000000000000000011441322003701700131060ustar00rootroot00000000000000 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 . zs3-1.3.1/acl.lisp000066400000000000000000000204141322003701700136570ustar00rootroot00000000000000;;;; ;;;; 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 t) (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 t) (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)) (with-element "ID" (text (id person))) (with-element "DisplayName" (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")) (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)) (with-element "Grant" (with-element "Grantee" (attribute* "xmlns" "xsi" *xsi*) (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)) (with-xml-output (with-element "AccessControlPolicy" (attribute "xmlns" "http://s3.amazonaws.com/doc/2006-03-01/") (with-element "Owner" (acl-serialize (owner acl))) (with-element "AccessControlList" (dolist (grant (remove-duplicates (grants acl) :test #'acl-eqv)) (acl-serialize grant)))))) ;;; Parsing XML ACL responses (defbinder access-control-policy ("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 'access-control-policy 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))) zs3-1.3.1/bucket-listing.lisp000066400000000000000000000160011322003701700160410ustar00rootroot00000000000000;;;; ;;;; 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)))))) zs3-1.3.1/cloudfront.lisp000066400000000000000000000521351322003701700153040ustar00rootroot00000000000000;;;; ;;;; 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.") (defbinder distribution-error-response ("ErrorResponse" ("Error" ("Type" (bind :type)) ("Code" (bind :code)) ("Message" (bind :message)) (optional ("Detail" (bind :detail)))) ("RequestId" (bind :request-id)))) (define-condition distribution-error (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 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) (default-root-object :initarg :default-root-object :accessor default-root-object :initform nil) (comment :initarg :comment :initform nil :accessor comment) (logging-bucket :initarg :logging-bucket :initform nil :accessor logging-bucket) (logging-prefix :initarg :logging-prefix :initform nil :accessor logging-prefix) (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) (with-xml-output (with-element "DistributionConfig" (attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/") (with-element "Origin" (text (origin-bucket distribution))) (with-element "CallerReference" (text (caller-reference distribution))) (dolist (cname (cnames distribution)) (with-element "CNAME" (text cname))) (when (comment distribution) (with-element "Comment" (text (comment distribution)))) (with-element "Enabled" (text (if (enabledp distribution) "true" "false"))) (when (default-root-object distribution) (with-element "DefaultRootObject" (text (default-root-object distribution)))) (let ((logging-bucket (logging-bucket distribution)) (logging-prefix (logging-prefix distribution))) (when (and logging-bucket logging-prefix) (with-element "Logging" (with-element "Bucket" (text logging-bucket)) (with-element "Prefix" (text logging-prefix)))))))) (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)))) (defbinder distribution-config ("DistributionConfig" ("Origin" (bind :origin)) ("CallerReference" (bind :caller-reference)) (sequence :cnames ("CNAME" (bind :cname))) (optional ("Comment" (bind :comment))) ("Enabled" (bind :enabled)) (optional ("Logging" ("Bucket" (bind :logging-bucket)) ("Prefix" (bind :logging-prefix)))) (optional ("DefaultRootObject" (bind :default-root-object))))) (defbinder distribution ("Distribution" ("Id" (bind :id)) ("Status" (bind :status)) ("LastModifiedTime" (bind :last-modified-time)) ("InProgressInvalidationBatches" (bind :in-progress-invalidation-batches)) ("DomainName" (bind :domain-name)) (include distribution-config))) (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) :logging-bucket (bvalue :logging-bucket bindings) :logging-prefix (bvalue :logging-prefix bindings) :default-root-object (bvalue :default-root-object 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 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 default-root-object) (sync logging-bucket) (sync logging-prefix) (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)) (defbinder distribution-list ("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 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 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)))) (defbinder invalidation-batch ("InvalidationBatch" (sequence :paths ("Path" (bind :path))) ("CallerReference" (bind :caller-reference)))) (defbinder invalidation ("Invalidation" ("Id" (bind :id)) ("Status" (bind :status)) ("CreateTime" (bind :create-time)) (include invalidation-batch))) (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) (with-xml-output (with-element "InvalidationBatch" (attribute "xmlns" "http://cloudfront.amazonaws.com/doc/2010-08-01/") (dolist (path (paths invalidation)) (with-element "Path" (text path))) (with-element "CallerReference" (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 response)))) (defmethod refresh ((invalidation invalidation)) (let ((document (invalidation-request invalidation :url-suffix (format nil "/~A" (id invalidation))))) (merge-bindings invalidation (xml-bind 'invalidation document)))) zs3-1.3.1/credentials.lisp000066400000000000000000000072771322003701700154310ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2008, 2015 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))) (defgeneric security-token (credentials) (:method ((object t)) nil) (:method ((list cons)) (third list))) ;;; Lazy-loading credentials (defclass lazy-credentials-mixin () ()) (defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin) (slot (eql 'access-key))) (nth-value 0 (initialize-lazy-credentials credentials))) (defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin) (slot (eql 'secret-key))) (nth-value 1 (initialize-lazy-credentials credentials))) (defmethod slot-unbound ((class t) (credentials lazy-credentials-mixin) (slot (eql 'security-token))) (nth-value 2 (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) (security-token :accessor security-token))) (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)) (setf (security-token credentials) (read-line stream nil)))))) (defun file-credentials (file) (make-instance 'file-credentials :file file)) zs3-1.3.1/crypto.lisp000066400000000000000000000115031322003701700144370ustar00rootroot00000000000000;;;; ;;;; 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) (defparameter *empty-string-sha256* (ironclad:byte-array-to-hex-string (ironclad:digest-sequence :sha256 (make-array 0 :element-type 'octet)))) (defparameter *newline-vector* (make-array 1 :element-type 'octet :initial-element 10)) (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 *newline-vector*)) (defun make-digester (key &key (digest-algorithm :sha1)) (when (stringp key) (setf key (string-octets key))) (make-instance 'digester :hmac (ironclad:make-hmac key digest-algorithm))) (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 digest (digester) (:method (digester) (ironclad:hmac-digest (hmac 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-sha256 (file) (ironclad:digest-file :sha256 file)) (defun file-sha256/hex (file) (ironclad:byte-array-to-hex-string (file-sha256 file))) (defun vector-sha256 (vector) (ironclad:digest-sequence :sha256 vector)) (defun vector-sha256/hex (vector) (ironclad:byte-array-to-hex-string (vector-sha256 vector))) (defun strings-sha256/hex (strings) (when strings (let ((digest (ironclad:make-digest :sha256))) (ironclad:update-digest digest (string-octets (first strings))) (dolist (string (rest strings)) (ironclad:update-digest digest *newline-vector*) (ironclad:update-digest digest (string-octets string))) (ironclad:byte-array-to-hex-string (ironclad:produce-digest digest))))) (defun strings-hmac-sha256/hex (key strings) (when strings (when (stringp key) (setf key (string-octets key))) (let ((digest (ironclad:make-hmac key :sha256))) (ironclad:update-hmac digest (string-octets (first strings))) (dolist (string (rest strings)) (ironclad:update-hmac digest *newline-vector*) (ironclad:update-hmac digest (string-octets string))) (ironclad:byte-array-to-hex-string (ironclad:hmac-digest digest))))) (defun vector-md5/b64 (vector) (base64:usb8-array-to-base64-string (ironclad:digest-sequence :md5 vector))) (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))) (defun hmac-sha256 (key strings) (let ((digester (make-digester key :digest-algorithm :sha256))) (if (consp strings) (dolist (s strings) (add-string s digester)) (add-string strings digester)) (digest digester))) zs3-1.3.1/doc/000077500000000000000000000000001322003701700127735ustar00rootroot00000000000000zs3-1.3.1/doc/LICENSE000066400000000000000000000025551322003701700140070ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; zs3-1.3.1/doc/index.html000066400000000000000000003042151322003701700147750ustar00rootroot00000000000000 ZS3 - Amazon S3 and CloudFront from Common Lisp

ZS3 - Amazon S3 and CloudFront from Common Lisp

ZS3 is a Common Lisp library for working with Amazon's Simple Storage Service (S3) and CloudFront content delivery service. It is available under a BSD-style license; see LICENSE for details. Development of ZS3 is hosted on GitHub. The latest version is 1.3.1, released on December 24th, 2017.

Download shortcut: http://www.xach.com/lisp/zs3.tgz

Contents

Installation

ZS3 depends on the following libraries:

The easiest way to install ZS3 and all its required libraries is with Quicklisp. After Quicklisp is installed, the following will fetch and load ZS3: 

    (ql:quickload "zs3")

For more information about incorporating ASDF-using libraries like ZS3 into your own projects, see this short tutorial.

Overview

ZS3 provides an interface to two separate, but related, Amazon services: S3 and CloudFront

Using Amazon S3 involves working with two kinds of resources: buckets and objects.

Buckets are containers, and are used to organize and manage objects. Buckets are identified by their name, which must be unique across all of S3. A user may have up to 100 buckets in S3.

Objects are stored within buckets. Objects consist of arbitrary binary data, from 1 byte to 5 gigabytes. They are identified by a key, which must be unique within a bucket. Objects can also have associated S3-specific metadata and HTTP metadata.

For full documentation of the Amazon S3 system, see the Amazon S3 Documentation. ZS3 uses the REST interface for all its operations.

Using Amazon CloudFront involves working with distributions. Distributions are objects that associate an S3 bucket with primary cloudfront.net hostname and zero or more arbitrary CNAMEs. S3 objects requested through a CloudFront distribution are distributed to and cached in multiple locations throughout the world, reducing latency and improving throughput, compared to direct S3 requests.

For full documentation of the Amazon CloudFront system, see the Amazon CloudFront Documentation.

For help with using ZS3, please see the zs3-devel mailing list.

Example Use

  * (asdf:oos 'asdf:load-op '#:zs3)
  => lots of stuff

  * (defpackage #:demo (:use #:cl #:zs3))
  => #<PACKAGE "DEMO">

  * (in-package #:demo)
  => #<PACKAGE "DEMO">

  * (setf *credentials* (file-credentials "~/.aws"))
  => #<FILE-CREDENTIALS {100482AF91}>

  * (bucket-exists-p "zs3-demo")
  => NIL

  * (create-bucket "zs3-demo")
  => #<RESPONSE 200 "OK" {10040D3281}>

  * (http-code *)
  => 200

  * (put-vector (octet-vector 8 6 7 5 3 0 9 ) "zs3-demo" "jenny")
  => #<RESPONSE 200 "OK" {10033EC2E1}>

  * (create-bucket "zs3 demo")
  Error:
   InvalidBucketName: The specified bucket is not valid.
   For more information, see:
     http://docs.aws.amazon.com/AmazonS3/latest/dev/BucketRestrictions.html
  [Condition of type INVALID-BUCKET-NAME]

  * (copy-object :from-bucket "zs3-demo" :from-key "jenny" :to-key "j2")
  => #<RESPONSE 200 "OK" {10040E3EA1}>

  * (get-vector "zs3-demo" "j2")
  => #(8 6 7 5 3 0 9),
     ((:X-AMZ-ID-2 . "Huwo...")
      (:X-AMZ-REQUEST-ID . "304...")
      (:DATE . "Sat, 27 Sep 2008 15:01:03 GMT")
      (:LAST-MODIFIED . "Sat, 27 Sep 2008 14:57:31 GMT")
      (:ETAG . "\"f9e71fe2c41a10c0a78218e98a025520\"")
      (:CONTENT-TYPE . "binary/octet-stream")
      (:CONTENT-LENGTH . "7")
      (:CONNECTION . "close")
      (:SERVER . "AmazonS3"))     

  * (put-string "Nämen" "zs3-demo" "bork")
  => #<RESPONSE 200 "OK" {10047A3791}>

  * (values (get-vector "zs3-demo" "bork"))
  => #(78 195 164 109 101 110)

  * (values (get-file "zs3-demo" "bork" "bork.txt"))
  => #P"bork.txt"

  * (setf *distribution* (create-distribution "zs3-demo" :cnames "cdn.wigflip.com")
  => #<DISTRIBUTION X2S94L4KLZK5G0 for "zs3-demo.s3.amazonaws.com" [InProgress]>

  * (progn (sleep 180) (refresh *distribution*))
  => #<DISTRIBUTION X2S94L4KLZK5G0 for "zs3-demo.s3.amazonaws.com" [Deployed]>

  * (domain-name *distribution*)
  => "x214g1hzpjm1zp.cloudfront.net"

  * (cnames *distribution*)
  => ("cdn.wigflip.com")

  * (put-string "Hello, world" "zs3-demo" "cloudfront" :public t)
  #<RESPONSE 200 "OK" {10042689F1}>

  * (drakma:http-request "http://x214g1hzpjm1zp.cloudfront.net/cloudfront")
  "Hello, world"
  200
  ((:X-AMZ-ID-2 . "NMc3IY3NzHGGEvV/KlzPgZMyDfPVT+ITtHo47Alqg00MboTxSX2f5XJzVTErfuHr")
   (:X-AMZ-REQUEST-ID . "52B050DC18638A00")
   (:DATE . "Thu, 05 Mar 2009 16:24:25 GMT")
   (:LAST-MODIFIED . "Thu, 05 Mar 2009 16:24:10 GMT")
   (:ETAG . "\"bc6e6f16b8a077ef5fbc8d59d0b931b9\"")
   (:CONTENT-TYPE . "text/plain")
   (:CONTENT-LENGTH . "12")
   (:SERVER . "AmazonS3")
   (:X-CACHE . "Miss from cloudfront")
   (:VIA . "1.0 ad78cb56da368c171e069e4444b2cbf6.cloudfront.net:11180")
   (:CONNECTION . "close"))
  #<PURI:URI http://x214g1hzpjm1zp.cloudfront.net/cloudfront>
  #<FLEXI-STREAMS:FLEXI-IO-STREAM {1002CE0781}>
  T
  "OK"     

  * (drakma:http-request "http://x214g1hzpjm1zp.cloudfront.net/cloudfront")
  "Hello, world"
  200
  ((:X-AMZ-ID-2 . "NMc3IY3NzHGGEvV/KlzPgZMyDfPVT+ITtHo47Alqg00MboTxSX2f5XJzVTErfuHr")
   (:X-AMZ-REQUEST-ID . "52B050DC18638A00")
   (:DATE . "Thu, 05 Mar 2009 16:24:25 GMT")
   (:LAST-MODIFIED . "Thu, 05 Mar 2009 16:24:10 GMT")
   (:ETAG . "\"bc6e6f16b8a077ef5fbc8d59d0b931b9\"")
   (:CONTENT-TYPE . "text/plain")
   (:CONTENT-LENGTH . "12")
   (:SERVER . "AmazonS3")
   (:AGE . "311")
   (:X-CACHE . "Hit from cloudfront")
   (:VIA . "1.0 0d78cb56da368c171e069e4444b2cbf6.cloudfront.net:11180")
   (:CONNECTION . "close"))
  #<PURI:URI http://x214g1hzpjm1zp.cloudfront.net/cloudfront>
  #<FLEXI-STREAMS:FLEXI-IO-STREAM {100360A781}>
  T
  "OK"

Limitations

ZS3 supports many of the features of Amazon's S3 REST interface. Some features are unsupported or incompletely supported:

The ZS3 Dictionary

The following sections document the symbols that are exported from ZS3.

Credentials

[Special variable]
*credentials*

*CREDENTIALS* is the source of the Amazon Access Key and Secret Key for authenticated requests. Any object that has methods for the ACCESS-KEY and SECRET-KEY generic functions may be used.

If *CREDENTIALS* is a cons, it is treated as a list, and the first element of the list is taken as the access key and the second element of the list is taken as the secret key.

The default value of *CREDENTIALS* is NIL, which will signal an error. You must set *CREDENTIALS* to something that follows the credentials generic function protocol to use ZS3.

All ZS3 functions that involve authenticated requests take an optional :CREDENTIALS keyword parameter. This parameter is bound to *CREDENTIALS* for the duration of the function call.

The following illustrates how to implement a credentials object that gets the access and secret key from external environment variables. 

  (defclass environment-credentials () ())

  (defmethod access-key ((credentials environment-credentials))
    (declare (ignore credentials))
    (getenv "AWS_ACCESS_KEY"))

  (defmethod secret-key ((credentials environment-credentials))
    (declare (ignore credentials))
    (getenv "AWS_SECRET_KEY"))

  (setf *credentials* (make-instance 'environment-credentials))
[Generic function]
access-key credentials => access-key-string

Returns the access key for credentials.

[Function]
security-token credentials => security-token-string

Returns the security token string for credentials, or NIL if there is no associated security token.

[Generic function]
secret-key credentials => secret-key-string

Returns the secret key for credentials.

[Function]
file-credentials pathname => credentials

Loads credentials on demand from pathname. The file named by pathname should be a text file with the access key on the first line and the secret key on the second line.

It can be used like so: 

  (setf *credentials* (file-credentials "/etc/s3.conf"))

Responses

Some operations return a response as an additional value. All response objects can be interrogated to obtain the HTTP code, headers and phrase.

The outcome of some requests — a very small proportion — will be an error internal to the AWS server. In these circumstances an exponential backoff policy operates; if this encounters too many failures then ZS3 signals an internal-error which can be interrogated to obtain the response object, and through that the HTTP response code and headers: 

* e
#<ZS3:INTERNAL-ERROR @ #x1000296bc92>
* (setf r (zs3:request-error-response e))
#<ZS3::AMAZON-ERROR "InternalError">
* (zs3:http-code r)
500
* (zs3:http-headers r)
((:X-AMZ-REQUEST-ID . "3E20E3BAC24AB9AA")
 (:X-AMZ-ID-2 . "80sxu4PDKtx1BWLOcSrUVWD90mMMVaMx6y9c+sz5VBGa2eAES2YlNaefn5kqRsfvrbaF+7QGNXA=")
 (:CONTENT-TYPE . "application/xml")
 (:TRANSFER-ENCODING . "chunked")
 (:DATE . "Fri, 30 Sep 2016 10:10:11 GMT")
 (:CONNECTION . "close")
 (:SERVER . "AmazonS3"))
* (zs3:http-phrase r)
"Internal Server Error"
*
[Special variable]
*backoff*

Used as the default value of :backoff when submitting a request. The value should be a cons of two numbers: how many times to try before giving up, and how long to wait (in ms) before trying for the second time. Each subsequent attempt will double that time.

The default value is (3 . 100).

If a requst fails more times than permitted by *backoff*, an error will be signalled. It is the application's responsibility to handle this error.

[Function]
request-error-response request-error => response

Returns the response object associated with a request-error.

[Function]
http-code response => code

Returns the HTTP code associated with a response object.

[Function]
http-headers response => headers

Returns the HTTP headers associated with a response object.

[Function]
http-phrase response => phrase

Returns the HTTP phrase associated with a response object.

Operations on Buckets

With ZS3, you can put, get, copy, and delete buckets. You can also get information about the bucket.

[Function]
all-buckets &key credentials backoff => bucket-vector

Returns a vector of all bucket objects. Bucket object attributes are accessible via NAME and CREATION-DATE.

[Function]
creation-date bucket-object => creation-universal-time

Returns the creation date of bucket-object, which must be a bucket object, as a universal time.

[Function]
name object => name-string

Returns the string name of object, which must be a key object or bucket object.

[Function]
all-keys bucket &key prefix credentials backoff => key-vector

Returns a vector of all key objects in bucket with names that start with the string prefix. If no prefix is specified, returns all keys. Keys in the vector are in alphabetical order by name. Key object attributes are accessible via NAME, SIZE, ETAG, LAST-MODIFIED, OWNER, and STORAGE-CLASS.

This function is built on QUERY-BUCKET and may involve multiple requests if a bucket has more than 1000 keys.

[Function]
bucket-exists-p bucket &key credentials backoff => boolean

Returns true if bucket exists.

[Function]
create-bucket name &key access-policy public location credentials backoff => response

Creates a bucket named name.

If provided, access-policy should be one of the following:

  • :PRIVATE - bucket owner is granted :FULL-CONTROL; this is the default behavior if no access policy is provided
  • :PUBLIC-READ - all users, regardless of authentication, can query the bucket's contents
  • :PUBLIC-READ-WRITE - all users, regardless of authentication, can query the bucket's contents and create new objects in the bucket
  • :AUTHENTICATED-READ - authenticated Amazon AWS users can query the bucket

For more information about access policies, see Canned ACL in the Amazon S3 developer documentation.

If public is true, it has the same effect as providing an access-policy of :PUBLIC-READ. An error is signaled if both public and access-policy are provided.

If location is specified, the bucket will be created in a region matching the given location constraint. If no location is specified, the bucket is created in the US. Valid locations change over time, but currently include "EU", "us-west-1", "us-west-2", "eu-west-1", "eu-central-1", "ap-southeast-1", "ap-southeast-2", "ap-northeast-1", and "sa-east-1". See Regions and Endpoints in the Amazon S3 developer documentation for the current information about location constraints.

[Function]
delete-bucket bucket &key credentials backoff => response

Deletes bucket. Signals a BUCKET-NOT-EMPTY error if the bucket is not empty, or a NO-SUCH-BUCKET error if there is no bucket with the given name.

[Function]
bucket-location bucket &key credentials backoff => location

Returns the location specified when creating a bucket, or NIL if no location was specified.

[Function]
bucket-lifecycle bucket => rules-list

Returns a list of lifecycle rules for bucket. Signals a NO-SUCH-LIFECYCLE-CONFIGURATION error if the bucket has no lifecycle rules configured.

Bucket lifecycle rules are used to control the automatic deletion of objects in a bucket. For more information about bucket lifecycle configuration, see Object Expiration in the Amazon S3 developer documentation.

[Function]
(setf bucket-lifecycle) rules bucket => rules, response

Sets the lifecycle configuration of bucket to the designator for a list of bucket lifecycle rules rules.

To create a bucket lifecycle rule, use LIFECYCLE-RULE. For example, to automatically delete objects with keys matching a "logs/" prefix after 30 days: 

(setf (bucket-lifecycle "my-bucket") (lifecycle-rule :prefix "logs/" :days 30))

To delete a bucket's lifecycle configuration, use an empty list of rules, e.g. 

(setf (bucket-lifecycle "my-bucket") nil)
[Function]
lifecycle-rule &key action prefix days date => rule

Creates a rule object suitable for passing to (SETF BUCKET-LIFECYCLE).

action should be either :expire (the default) or :transition. For :expire, matching objects are deleted. For :transition, matching objects are transitioned to the GLACIER storage class. For more information about S3-to-Glacier object transition, see Object Archival (Transition Objects to the Glacier Storage Class) in the Amazon S3 Developer's Guide.

prefix is a string; all objects in a bucket with keys matching the prefix will be affected by the rule.

days is the number of days after which an object will be affected.

date is the date after which objects will be affected.

Only one of days or date may be provided.

[Function]
restore-object bucket key &body days credentials backoff => response

Initiates a restoration operation on the object identified by bucket and key. A restoration operation can take several hours to complete. The restored object is temporarily stored with the reduced redundancy storage class. The status of the operation may monitored via OBJECT-RESTORATION-STATUS.

days is the number of days for which the restored object should be avilable for normal retrieval before transitioning back to archival storage.

Object restoration operation is only applicable to objects that have been transitioned to Glacier storage by the containing bucket's lifecycle configuration.

For more information, see POST Object restore in the S3 documentation.

[Function]
object-restoration-status bucket key &key credentials backoff => status-string

Returns a string describing the status of restoring the object identified by bucket and key. If no restoration is in progress, or the operation is not applicable, returns NIL.

Querying Buckets

S3 has a flexible interface for querying a bucket for information about its contents. ZS3 supports this interface via QUERY-BUCKET, CONTINUE-BUCKET-QUERY, and related functions.

[Function]
query-bucket bucket &key prefix marker max-keys delimiter credentials backoff => response

Query bucket for key information. Returns a response object that has the result of the query. Response attributes are accessible via BUCKET-NAME, PREFIX, MARKER, DELIMITER, TRUNCATEDP, KEYS, and COMMON-PREFIXES.

Amazon might return fewer key objects than actually match the query parameters, based on max-keys or the result limit of 1000 key objects. In that case, TRUNCATEDP for response is true, and CONTINUE-BUCKET-QUERY can be used with response be used to get successive responses for the query parameters.

When prefix is supplied, only key objects with names that start with prefix will be returned in response.

When marker is supplied, only key objects with names occurring lexically after marker will be returned in response.

When max-keys is supplied, it places an inclusive upper limit on the number of key objects returned in response. Note that Amazon currently limits responses to at most 1000 key objects even if max-keys is greater than 1000.

When delimiter is supplied, key objects that have the delimiter string after prefix in their names are not returned in the KEYS attribute of the response, but are instead accumulated into the COMMON-PREFIXES attribute of the response. For example: 

  * (all-keys "zs3-demo")
  => #(#<KEY "a" 4>
       #<KEY "b/1" 4>
       #<KEY "b/2" 4>
       #<KEY "b/3" 4>
       #<KEY "c/10" 4>
       #<KEY "c/20" 4>
       #<KEY "c/30" 4>)

  * (setf *response* (query-bucket "zs3-demo" :delimiter "/"))
  => #<BUCKET-LISTING "zs3-demo">

  * (values (keys *response*) (common-prefixes *response*))
  => #(#<KEY "a" 4>),
     #("b/"
       "c/")

  * (setf *response* (query-bucket "zs3-demo" :delimiter "/" :prefix "b/"))
  => #<BUCKET-LISTING "zs3-demo">

  * (values (keys *response*) (common-prefixes *response*))
  => #(#<KEY "b/1" 4>
       #<KEY "b/2" 4>
       #<KEY "b/3" 4>),
     #()

For more information about bucket queries, see GET Bucket in the Amazon S3 developer documentation.

[Function]
continue-bucket-query response => response

If response is a truncated response from a previous call to QUERY-BUCKET, continue-bucket-query returns the result of resuming the query at the truncation point. When there are no more results, continue-bucket-query returns NIL.

[Function]
bucket-name response => name

Returns the name of the bucket used in the call to QUERY-BUCKET that produced response.

[Function]
keys response => keys-vector

Returns the vector of key objects in response. Key object attributes are accessible via NAME, SIZE, ETAG, LAST-MODIFIED, and OWNER.

[Function]
common-prefixes response => prefix-vector

Returns a vector of common prefix strings, based on the delimiter argument of the QUERY-BUCKET call that produced response.

[Function]
prefix response => prefix-string

Returns the prefix given to the QUERY-BUCKET call that produced response. If present, all keys in response have prefix-string as a prefix.

[Function]
marker response => marker

Returns the marker given to the QUERY-BUCKET call that produced response. If present, it lexically precedes all key names in the response.

[Function]
delimiter response => delimiter

Returns the delimiter used in the QUERY-BUCKET call that produced response.

[Function]
truncatedp response => boolean

Returns true if response is truncated; that is, if there is more data to retrieve for a given QUERY-BUCKET query. CONTINUE-BUCKET-QUERY may be used to fetch more data.

[Function]
last-modified key-object => universal-time

Returns a universal time representing the last modified time of key-object.

[Function]
etag key-object => etag-string

Returns the etag for key-object.

[Function]
size key-object => size

Returns the size, in octets, of key-object.

[Function]
owner key-object => owner

Returns the owner of key-object, or NIL if no owner information is available.

[Function]
storage-class key-object => storage-class

Returns the storage class of key-object.

Operations on Objects

Objects are the stored binary data in S3. Every object is uniquely identified by a bucket/key pair. ZS3 has several functions for storing and fetching objects, and querying object attributes.

[Function]
get-object bucket key &key output
start end
when-modified-since unless-modified-since
when-etag-matches unless-etag-matches
if-exists string-external-format credentials backoff => object

Fetch the object referenced by bucket and key. The secondary value of all successful requests is an alist of Drakma-style response HTTP headers.

If output is :VECTOR (the default), the object's octets are returned in a vector.

If output is :STRING, the object's octets are converted to a string using the encoding specified by string-external-format, which defaults to :UTF-8. See External formats in the FLEXI-STREAMS documentation for supported values for the string external format. Note that, even when output is :STRING, the start and end arguments operate on the object's underlying octets, not the string representation in a particular encoding. It's possible to produce a subsequence of the object's octets that are not valid in the desired encoding.

If output is a string or pathname, the object's octets are saved to a file identified by the string or pathname. The if-exists argument is passed to WITH-OPEN-FILE to control the behavior when the output file already exists. It defaults to :SUPERSEDE.

If output is :STREAM, a stream is returned from which the object's contents may be read.

start marks the first index fetched from the object's data. end specifies the index after the last octet fetched. If start is NIL, it defaults to 0. If end is nil, it defaults to the total length of the object. If both start and end are provided, start must be less than or equal to end.

when-modified-since and unless-modified-since are optional. If when-modified-since is provided, the result will be the normal object value if the object has been modified since the provided universal time, NIL otherwise. The logic is reversed for unless-modified-since.

when-etag-matches and unless-etag-matches are optional. If when-etag-matches is provided, the result will be the normal object value if the object's etag matches the provided string, NIL otherwise. The logic is reversed for unless-etag-matches.

[Function]
get-vector bucket key &key start end when-modified-since unless-modified-since when-etag-matches unless-etag-matches credentials backoff => vector

get-vector is a convenience interface to GET-OBJECT. It is equivalent to calling: 

  (get-object bucket key :output :vector ...)
[Function]
get-string bucket key &key external-format start end when-modified-since unless-modified-since when-etag-matches unless-etag-matches credentials backoff => string
get-string is a convenience interface to GET-OBJECT. It is equivalent to calling: 
  (get-object bucket key :output :string :string-external-format external-format ...)
[Function]
get-file bucket key file &key start end when-modified-since unless-modified-since when-etag-matches unless-etag-matches credentials backoff => pathname

get-file is a convenience interface to GET-OBJECT. It is equivalent to calling: 

  (get-object bucket key :output file ...)
[Function]
put-object object bucket key &key access-policy public metadata string-external-format cache-control content-encoding content-disposition content-type expires storage-class tagging credentials backoff => response

Stores the octets of object in the location identified by bucket and key.

If object is an octet vector, it is stored directly.

If object is a string, it is converted to an octet vector using string-external-format, which defaults to :UTF-8, then stored. See External formats in the FLEXI-STREAMS documentation for supported values for the string external format.

If object is a pathname, its contents are loaded in memory as an octet vector and stored.

If provided, access-policy should be one of the following:

  • :PRIVATE - object owner is granted :FULL-CONTROL; this is the default behavior if no access policy is provided
  • :PUBLIC-READ - all users, regardless of authentication, can read the object
  • :AUTHENTICATED-READ - authenticated Amazon AWS users can read the object

For more information about access policies, see Canned ACL in the Amazon S3 developer documentation.

If public is true, it has the same effect as providing an access-policy of :PUBLIC-READ. An error is signaled if both public and access-policy are provided.

If provided, metadata should be an alist of Amazon metadata to set on the object. When the object is fetched again, the metadata will be returned in HTTP headers prefixed with "x-amz-meta-".

The cache-control, content-encoding, content-disposition, content-type, and expires values are all used to set HTTP properties of the object that are returned with subsequent GET or HEAD requests. If content-type is not set, it defaults to "binary/octet-stream". The others default to NIL. If expires is provided, it should be a universal time.

If provided, storage-class should refer to one of the standard storage classes available for S3; currently the accepted values are the strings "STANDARD" and "REDUCED_REDUNDANCY". Using other values may trigger an API error from S3. For more information about reduced redundancy storage, see reduced Redundancy Storage in the Developer Guide.

If provided, tagging specifies the set of tags to be associated with the object. The set is given as an alist. For more information, see Object Tagging in the Developer Guide.

[Function]
put-vector vector bucket key &key start end access-policy public metadata content-disposition content-encoding content-type expires storage-class tagging credentials backoff => response

put-vector is a convenience interface to PUT-OBJECT. It is similar to calling: 

  (put-object vector bucket key ...)

If one of start or end is provided, they are used as bounding index designators on the string, and only a subsequence is used.

[Function]
put-string string bucket key &key start end external-format access-policy public metadata content-disposition content-encoding content-type expires storage-class tagging credentials backoff => response

put-string is a convenience interface to PUT-OBJECT. It is similar to calling: 

  (put-object string bucket key :string-external-format external-format ...)

If one of start or end is supplied, they are used as bounding index designators on the string, and only a substring is used.

[Function]
put-file file bucket key &key start end access-policy public metadata content-disposition content-encoding content-type expires storage-class tagging credentials backoff => response

put-file is a convenience interface to PUT-OBJECT. It is almost equivalent to calling: 

  (put-object (pathname file) bucket key ...)

If key is T, the FILE-NAMESTRING of the file is used as the key instead of key.

If one of start or end is supplied, only a subset of the file is used. If start is not NIL, start octets starting from the beginning of the file are skipped. If end is not NIL, octets in the file at and after end are ignored. An error of type CL:END-OF-FILE is signaled if end is provided and the file size is less than end.

[Function]
put-stream file bucket key &key start end access-policy public metadata content-disposition content-encoding content-type expires storage-class tagging credentials backoff => response

put-stream is similar to to PUT-OBJECT. It has the same effect as collecting octets from stream into a vector and using: 

  (put-object vector bucket key ...)

If start is not NIL, start octets starting from the current position in the stream are skipped before collecting.

If end is NIL, octets are collected until the end of the stream is reached.

If end is not NIL, collecting octets stops just before reaching end in the stream. An error of type CL:END-OF-FILE is signaled if the stream ends prematurely.

[Function]
copy-object &key from-bucket from-key to-bucket to-key
access-policy public
when-etag-matches unless-etag-matches
when-modified-since unless-modified-since
metadata public precondition-errors storage-class tagging credentials backoff => response

Copies the object identified by from-bucket and from-key to a new location identified by to-bucket and to-key. If to-bucket is NIL, from-bucket is used as the target. If to-key is nil, from-key is used as the target. An error is signaled if both to-bucket and to-key are NIL.

access-policy and public have the same effect on the target object as in PUT-OBJECT.

The precondition arguments when-etag-matches, unless-etag-matches, when-modified-since, and unless-modified-since work the same way they do in GET-OBJECT, but with one difference: if precondition-errors is true, an PRECONDITION-FAILED error is signaled when a precondition does not hold, instead of returning NIL.

If metadata is explicitly provided, it follows the same behavior as with PUT-OBJECT. Passing NIL means that the new object has no metadata. Otherwise, the metadata is copied from the original object.

If tagging is explicitly provided, it follows the same behavior as with PUT-OBJECT. Passing NIL means that the new object has no tags. Otherwise, tagging is copied from the original object.

If storage-class is provided, it should refer to one of the standard storage classes available for S3; currently the accepted values are the strings "STANDARD" and "REDUCED_REDUNDANCY". Using other values may trigger an API error from S3. For more information about reduced redundancy storage, see Reduced Redundancy Storage in the Developer Guide.

[Function]
delete-object bucket key &key credentials backoff => response

Deletes the object identified by bucket and key.

If bucket is a valid bucket for which you have delete access granted, S3 will always return a success response, even if key does not reference an existing object.

[Function]
delete-objects bucket keys &key credentials backoff => deleted-count, errors

Deletes keys, which should be a sequence of keys, from bucket. The primary value is the number of objects deleted. The secondary value is a list of error plists; if there are no errors deleting any of the keys, the secondary value is NIL.

[Function]
delete-all-objects bucket &key credentials backoff => count

Deletes all objects in bucket and returns the count of objects deleted.

[Function]
object-metadata bucket key &key credentials backoff => metadata-alist

Returns the metadata for the object identified by bucket and key, or NIL if there is no metadata. For example: 

  * (put-string "Hadjaha!" "zs3-demo" "hadjaha.txt" :metadata (parameters-alist :language "Swedish"))
  => #<RESPONSE 200 "OK" {1003BD2841}>    

  * (object-metadata "zs3-demo" "hadjaha.txt")
  => ((:LANGUAGE . "Swedish"))
[Function]
set-storage-class bucket key storage-class &key credentials backoff => response

Sets the storage class of the object identified by bucket and key to storage-class. This is a convenience function that uses COPY-OBJECT to make storage class changes.

The storage class of an object can be determined by querying the bucket with ALL-KEYS or QUERY-BUCKET and using STORAGE-CLASS on one of the resulting key objects.

Access Control

Each S3 resource has an associated access control list that is created automatically when the resource is created. The access control list specifies the resource owner and a list of permission grants.

Grants consist of a permission and a grantee. The permission must be one of :READ, :WRITE, :READ-ACL, :WRITE-ACL, or :FULL-CONTROL. The grantee should be a person object, an acl-group object, or an acl-email object.

ZS3 has several functions that assist in reading, modifying, and storing access control lists.

[Function]
get-acl &key bucket key credentials backoff => owner, grants

Returns the owner and grant list for a resource as multiple values.

[Function]
put-acl owner grants &key bucket key credentials backoff => response

Sets the owner and grant list of a resource.

[Function]
grant permission &key to => grant

Returns a grant object that represents a permission (one of :READ, :WRITE, :READ-ACL, :WRITE-ACL, or :FULL-CONTROL) for the grantee to. For example: 

  * (grant :full-control :to (acl-email "bob@example.com"))
  => #<GRANT :FULL-CONTROL to "bob@example.com">

  * (grant :read :to *all-users*)
  => #<GRANT :READ to "AllUsers">

It can be used to create or modify a grant list for use with PUT-ACL.

[Function]
acl-eqv a b => boolean

Returns true if a and b are equivalent ACL-related objects (person, group, email, or grant).

[Special variable]
*all-users*

This acl-group includes all users, including unauthenticated clients.

[Special variable]
*aws-users*

This acl-group object includes only users that have an Amazon Web Services account.

[Special variable]
*log-delivery*

This acl-group object includes the S3 system user that creates logfile objects. See also ENABLE-LOGGING-TO.

[Function]
acl-email email-address => acl-email

Returns an acl-email object, which can be used as a grantee for GRANT.

[Function]
acl-person id &optional display-name => acl-person

Returns an acl-person object for use as a resource owner (for PUT-ACL) or as a grantee (for GRANT). id must be a string representing the person's Amazon AWS canonical ID; for information about getting the canonical ID, see the Managing Access with ACLS in the Amazon S3 developer documentation. If display-name is provided, it is used only for printing the object in Lisp; it is ignored when passed to S3.

[Function]
me &key credentials backoff => acl-person

Returns the acl-person object associated with the current credentials.

This data requires a S3 request, but the result is always the same per credentials and is cached.

[Function]
make-public &key bucket key credentials backoff => response

Makes a resource publicly accessible, i.e. readable by the *ALL-USERS* group.

[Function]
make-private &key bucket key credentials backoff => response

Removes public access to a resource, i.e. removes all access grants for the *ALL-USERS* group.

Access Logging

S3 offers support for logging information about client requests. Logfile objects are delivered by a system user in the *LOG-DELIVERY* group to a bucket of your choosing. For more information about S3 access logging and the logfile format, see the Server Access Logging in the Amazon S3 developer documentation.

[Function]
enable-logging-to bucket &key credentials backoff => response
Adds the necessary permission grants to bucket to allow S3 to write logfile objects into it.
[Function]
disable-logging-to bucket &key credentials backoff => response

Changes the access control list of bucket to remove all grants for the *LOG-DELIVERY* group.

[Function]
enable-logging bucket target-bucket target-prefix &key target-grants credentials backoff => response

Enables logging of all requests involving bucket. Logfile objects are created in target-bucket and each logfile's key starts with target-prefix.

When a new logfile is created, its list of access control grants is extended with target-grants, if any.

If target-bucket does not have the necessary grants to allow logging, the grants are implicitly added by calling ENABLE-LOGGING-TO.

[Function]
disable-logging bucket &key credentials backoff => response
Disables logging for bucket.
[Function]
logging-setup bucket &key credentials backoff => target-bucket, target-prefix, target-grants

If logging is enabled for bucket, returns the target bucket, target prefix, and target grants as multiple values.

Object Tagging

In S3, a set of tags can be associated with each key and bucket. Tagging offers a way to categorize objects that is orthogonal to key prefixes. They resemble object metadata but, unlike metadata, tagging be used in access control, lifecycle rules, and metrics. For more information, please refer to the Object Tagging section on the S3 Developer Guide.

[Function]
get-tagging &key bucket key credentials backoff => tag-set

Returns the object's current tag set as an alist.

[Function]
put-tagging tag-set &key bucket key credentials backoff => response

Sets the object's tagging resource to the given set of tags. The tags are given as an alist.

[Function]
delete-tagging &key bucket key credentials backoff => response

Deletes the tagging resource associated with the object.

Miscellaneous Operations

[Special variable]
*use-ssl*

When true, requests to S3 are sent via HTTPS. The default is NIL.

[Special variable]
*use-keep-alive*

When true, HTTP keep-alives are used to reuse a single network connection for multiple requests.

[Macro]
with-keep-alive &body body => |

Evaluate body in a context where *USE-KEEP-ALIVE* is true.

[Function]
make-post-policy &key expires conditions credentials => policy, signature

Returns an encoded HTML POST form policy and its signature as multiple values. The policy can be used to conditionally allow any user to put objects into S3.

expires must be a universal time after which the policy is no longer accepted.

conditions must be a list of conditions that the posted form fields must satisfy. Each condition is a list of a condition keyword, a form field name, and the form field value. For example, the following are all valid conditions:

  • (:starts-with "key" "uploads/")
  • (:eq "bucket" "user-uploads")
  • (:eq "acl" "public-read")
  • (:range "content-length-range" 1 10000)

These conditions are converted into a post policy description, base64-encoded, and returned as policy. The signature is returned as signature. These values can then be embedded in an HTML form and used to allow direct browser uploads.

For example, if policy is "YSBwYXRlbnRseSBmYWtlIHBvbGljeQ==" and the policy signature is "ZmFrZSBzaWduYXR1cmU=", you could construct a form like this:

<form action="http://user-uploads.s3.amazonaws.com/" method="post" enctype="multipart/form-data">
<input type="input" name="key" value="uploads/fun.jpg">
<input type=hidden name="acl" value="public-read">
<input type=hidden name="AWSAccessKeyId" value="8675309JGT9876430310">
<input type=hidden name="Policy" value="YSBwYXRlbnRseSBmYWtlIHBvbGljeQ==">
<input type=hidden name='Signature' value="ZmFrZSBzaWduYXR1cmU=">
<input name='file' type='file'>
<input type=submit value='Submit'>
</form>

For full, detailed documentation of browser-based POST uploads and policy documents, see Browser-Based Uploads Using POST in the Amazon S3 developer documentation.

[Function]
head &key bucket key parameters credentials backoff => headers-alist, status-code, phrase

Submits a HTTP HEAD request for the resource identified by bucket and optionally key. Returns the Drakma headers, HTTP status code, and HTTP phrase as multiple values.

When parameters is supplied, it should be an alist of keys and values to pass as GET request parameters. For example: 

  * (head :bucket "zs3-demo" :parameters (parameters-alist :max-keys 0))
  => ((:X-AMZ-ID-2  . "...")
      (:X-AMZ-REQUEST-ID . "...")
      (:DATE . "Sat, 27 Sep 2008 19:00:35 GMT")
      (:CONTENT-TYPE . "application/xml")
      (:TRANSFER-ENCODING . "chunked")
      (:SERVER . "AmazonS3")
      (:CONNECTION . "close")),
      200,
      "OK"
[Function]
authorized-url &key bucket key vhost expires ssl sub-resource credentials => url

Creates an URL that allows temporary access to a resource regardless of its ACL.

If neither bucket nor key is specified, the top-level bucket listing is accessible. If key is not specified, listing the keys of bucket is accessible. If both bucket and key are specified, the object specified by bucket and key is accessible.

expires is required, and should be the integer universal time after which the URL is no longer valid.

vhost controls the construction of the url. If vhost is nil, the constructed URL refers to the bucket, if present, as part of the path. If vhost is :AMAZON, the bucket name is used as a prefix to the Amazon hostname. If vhost is :FULL, the bucket name becomes the full hostname of the url. For example: 

  * (authorized-url :bucket "foo" :key "bar" :vhost nil)
  => "http://s3.amazonaws.com/foo/bar?..."

  * (authorized-url :bucket "foo" :key "bar" :vhost :amazon)
  => "http://foo.s3.amazonaws.com/bar?..."

  * (authorized-url :bucket "foo.example.com" :key "bar" :vhost :full)
  =>  "http://foo.example.com/bar?..."

If ssl is true, the URL has "https" as the scheme, otherwise it has "http".

If sub-resource is specified, it is used as part of the query string to access a specific sub-resource. Example Amazon sub-resources include "acl" for access to the ACL, "location" for location information, and "logging" for logging information. For more information about the various sub-resources, see the Amazon S3 developer documentation.

[Function]
resource-url &key bucket key vhost ssl sub-resource => url

Returns an URL that can be used to reference a resource. See AUTHORIZED-URL for more info.

Utility Functions

[Function]
octet-vector &rest octets => octet-vector

Returns a vector of type (simple-array (unsigned-byte 8) (*)) initialized with octets.

[Function]
now+ delta => universal-time

Returns a universal time that represents the current time incremented by delta seconds. It's useful for passing as the :EXPIRES parameter to functions like PUT-OBJECT and AUTHORIZED-URL.

[Function]
now- delta => universal-time

Like NOW+, but decrements the current time instead of incrementing it.

[Function]
file-etag pathname => etag

Returns the etag of pathname. This can be useful for the conditional arguments :WHEN-ETAG-MATCHES and :UNLESS-ETAG-MATCHES in GET-OBJECT and COPY-OBJECT.

[Function]
parameters-alist &rest parameters &key &allow-other-keys => alist

Returns an alist based on all keyword arguments passed to the function. Keywords are converted to their lowercase symbol name and values are converted to strings. For example: 

  * (parameters-alist :name "Bob" :age 21)
  => (("name" . "Bob") ("age" . "21"))

This can be used to construct Amazon metadata alists for PUT-OBJECT and COPY-OBJECT, or request parameters in HEAD.

[Function]
clear-redirects => |

Clear ZS3's internal cache of redirections.

Most ZS3 requests are submitted against the Amazon S3 endpoint "s3.amazonaws.com". Some requests, however, are permanently redirected by S3 to new endpoints. ZS3 maintains an internal cache of permanent redirects, but it's possible for that cache to get out of sync if external processes alter the bucket structure

For example, if the bucket "eu.zs3" is created with a EU location constraint, S3 will respond to requests to that bucket with a permanent redirect to "eu.zs3.s3.amazonaws.com", and ZS3 will cache that redirect information. But if the bucket is deleted and recreated by a third party, the redirect might no longer be necessary.

CloudFront

CloudFront functions allow the creation and manipulation of distributions. In ZS3, distributions are represented by objects that reflect the state of a distributon at some point in time. It's possible for the distribution to change behind the scenes without notice, e.g. when a distribution's status is updated from "InProgress" to "Deployed".

The functions ENABLE, DISABLE, ENSURE-CNAME, REMOVE-CNAME, and SET-COMMENT are designed so that regardless of the state of the distribution provided, after the function completes, the new state of the distribution will reflect the desired update. The functions STATUS, CNAMES, and ENABLEDP do not automatically refresh the object and therefore might reflect outdated information. To ensure the object has the most recent information, use REFRESH. For example, to fetch the current, live status, use (status (refresh distribution)).

[Function]
all-distributions => |

Returns a list of all distributions.

[Function]
create-distribution bucket-name &key cnames enabled comment => distribution
Creates and returns a new distribution object that will cache objects from the bucket named by bucket-name.

If cnames is provided, it is taken as a designator for a list of additional domain names that can be used to access the distribution.

If enabled is NIL, the distribution is initially created in a disabled state. The default value is is T.

If comment is provided, it becomes part of the newly created distribution.

[Function]
delete-distribution distribution => |

Deletes distribution. Distributions must be disabled before deletion; see DISABLE.

[Function]
refresh distribution => distribution

Queries Amazon for the latest information regarding distribution and destructively modifies the instance with the new information. Returns its argument.

[Function]
enable distribution => |

Enables distribution.

[Function]
disable distribution => |

Disables distribution.

[Function]
ensure-cname distribution cname => |

Adds cname to the CNAMEs of distribution, if necessary.

[Function]
remove-cname distribution cname => |

Removes cname from the CNAMEs of distribution.

[Function]
set-comment distribution comment => |

Sets the comment of distribution to comment.

[Function]
distributions-for-bucket bucket-name => |

Returns a list of distributions that have bucket-name as the origin bucket.

[Condition]
distribution-error

All errors signaled as a result of a CloudFront request error are subtypes of distribution-error.

[Condition]
distribution-not-disabled

Distributions must be fully disabled before they are deleted. If they have not been disabled, or the status of the distribution is still "InProgress", distribution-not-disabled is signaled.

[Condition]
cname-already-exists

A CNAME may only appear on one distribution. If you attempt to add a CNAME to a distribution that is already present on some other distribution, cname-already-exists is signaled.

[Condition]
too-many-distributions

If creating a new distribution via CREATE-DISTRIBUTION would exceed the account limit of total distributions, too-many-distributions is signaled.

[Function]
status distribution => status

Returns a string describing the status of distribution. The status is either "InProgress", meaning that the distribution's configuration has not fully propagated through the CloudFront system, or "Deployed".

[Function]
origin-bucket distribution => origin-bucket

Returns the origin bucket for distribution. It is different from a normal ZS3 bucket name, because it has ".s3.amazonaws.com" as a suffix.

[Function]
domain-name distribution => domain-name

Returns the domain name through which CloudFront-enabled access to a resource may be made.

[Function]
cnames distribution => cnames
Returns a list of CNAMEs associated with distribution.
[Function]
enabledp distribution => boolean

Returns true if distribution is enabled, NIL otherwise.

[Function]
invalidate-paths distribution paths => invalidation

Initiates the invalidation of resources identified by paths in distribution. paths should consist of key names that correspond to objects in the distribution's S3 bucket.

The invalidation object reports on the status of the invalidation request. It can be queried with STATUS and refreshed with REFRESH. 

* (invalidate-paths distribution '("/css/site.css" "/js/site.js"))
#<INVALIDATION "I1HJC711OFAVKO" [InProgress]>
* (progn (sleep 300) (refresh *))
#<INVALIDATION "I1HJC711OFAVKO" [Completed]>

References

Acknowledgements

Several people on freenode #lisp pointed out typos and glitches in this documentation. Special thanks to Bart "_3b" Botta for providing a detailed documentation review that pointed out glitches, omissions, and overly confusing passages.

James Wright corrected a problem with computing the string to sign and URL encoding.

Feedback

If you have any questions or comments about ZS3, please email me, Zach Beane

For ZS3 announcements and development discussion, please see the zs3-devel mailing list.

2016-06-17

Copyright © 2008-2016 Zachary Beane, All Rights Reserved

zs3-1.3.1/doc/style.css000066400000000000000000000021211322003701700146410ustar00rootroot00000000000000 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; }zs3-1.3.1/errors.lisp000066400000000000000000000200751322003701700144370ustar00rootroot00000000000000;;;; ;;;; 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) (defbinder error ("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 source))) (setf (code response) (bvalue :code bindings)) (setf (message response) (bvalue :message bindings)) (setf (error-data response) (bvalue :data bindings)))) (defmethod specialized-initialize ((response amazon-error) (source null)) (setf (code response) "InternalError" (message response) nil (error-data response) nil)) (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 t)) (error 'request-error :request (request response) :response response :data (error-data response)))) (defgeneric maybe-signal-error (response) (:method ((response t)) 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 (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") (canonical-request "CanonicalRequest")) (:report (lambda (condition stream) (report-request-error condition stream) (format stream "You signed: ~S~%Amazon signed: ~S~%and~%~S" (signed-string (request-error-request condition)) (request-error-string-to-sign condition) (request-error-canonical-request condition))))) (define-specific-error (precondition-failed "PreconditionFailed") () ((condition "Condition"))) (define-specific-error (authorization-header-malformed "AuthorizationHeaderMalformed") () ((region "Region"))) (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.aws.amazon.com/AmazonS3/latest/dev/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.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTacl.html")) (define-specific-error (bucket-not-empty "BucketNotEmpty") (linked) () (:default-initargs :url "http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketDELETE.html")) (define-specific-error (invalid-logging-target "InvalidTargetBucketForLogging") () ()) (define-specific-error (key-too-long "KeyTooLong") (linked) () (:default-initargs :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/UsingMetadata.html")) (define-specific-error (request-time-skewed "RequestTimeTooSkewed") (linked) () (:default-initargs :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#RESTAuthenticationTimeStamp")) (define-specific-error (operation-aborted "OperationAborted") () ()) zs3-1.3.1/interface.lisp000066400000000000000000001300071322003701700150600ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2008, 2015 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*) ((:backoff *backoff*) *backoff*)) "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* ((security-token (security-token *credentials*)) (response (submit-request (make-instance 'request :method :head :bucket bucket :key key :amz-headers (when security-token (list (cons "security-token" security-token))) :parameters parameters)))) (values (http-headers response) (http-code response) (http-phrase response)))) ;;; Operations on buckets (defun all-buckets (&key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "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*) ((:backoff *backoff*) *backoff*)) "If BUCKET was created with a LocationConstraint, return its constraint." (let* ((request (make-instance 'request :method :get :sub-resource "location" :extra-http-headers `(,(when (security-token *credentials*) (cons "x-amz-security-token" (security-token *credentials*)))) :bucket bucket)) (response (submit-request request)) (location (location response))) (when (plusp (length location)) location))) (defun bucket-region (bucket &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (or (bucket-location bucket) "us-east-1")) (defun region-endpoint (region) (if (string= region "us-east-1") (or *s3-endpoint* "s3.amazonaws.com") (format nil "s3-~A.amazonaws.com" region))) (defun query-bucket (bucket &key prefix marker max-keys delimiter ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) "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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (let* ((request (make-instance 'request :method :delete :bucket bucket)) (endpoint (endpoint request)) (bucket (bucket request))) (prog1 (submit-request request) (setf (redirection-data 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) (let ((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) (let ((input (body response))) (read-sequence buffer input) buffer)) response)) (defun stream-identity-handler (response) (check-request-success response) 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*) ((:backoff *backoff*) *backoff*)) (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* ((security-token (security-token *credentials*)) (request (make-instance 'request :method :get :bucket bucket :key key :amz-headers (when security-token (list (cons "security-token" security-token))) :extra-http-headers (parameters-alist ;; nlevine 2016-06-15 -- not only is this apparently ;; unnecessary, it also sends "connection" in the ;; signed headers, which results in a ;; SignatureDoesNotMatch error. ;; :connection (unless *use-keep-alive* "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)) ((eql output :stream) 'stream-identity-handler) ((or (stringp output) (pathnamep output)) (make-file-writer-handler output :if-exists if-exists)) (t (error "Unknown ~S option ~S -- should be ~ :VECTOR, :STRING, :STREAM, or a pathname" :output output))))) (catch 'not-modified (handler-case (let ((response (submit-request request :keep-stream (or (eql output :stream) *use-keep-alive*) :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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (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 format-tagging-header (tagging) (format nil "~{~a=~a~^&~}" (mapcan #'(lambda (kv) (list (drakma:url-encode (car kv) :iso-8859-1) (drakma:url-encode (cdr kv) :iso-8859-1))) tagging))) (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 (storage-class "STANDARD") tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (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)) (security-token (security-token *credentials*))) (setf storage-class (or storage-class "STANDARD")) (submit-request (make-instance 'request :method :put :bucket bucket :key key :metadata metadata :amz-headers (append policy-header (when security-token (list (cons "security-token" security-token))) (when tagging (list (cons "tagging" (format-tagging-header tagging))))) :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 storage-class tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (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 :storage-class storage-class :tagging tagging)) (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 storage-class tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (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 :storage-class storage-class :tagging tagging)) (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 storage-class tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (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 :storage-class storage-class :tagging tagging))) (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 storage-class tagging ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (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 :storage-class storage-class :tagging tagging))) ;;; Delete & copy objects (defun delete-object (bucket key &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Delete one object from BUCKET identified by KEY." (let ((security-token (security-token *credentials*))) (submit-request (make-instance 'request :method :delete :bucket bucket :key key :amz-headers (when security-token (list (cons "security-token" security-token))))))) (defun bulk-delete-document (keys) (coerce (cxml:with-xml-output (cxml:make-octet-vector-sink) (cxml:with-element "Delete" (map nil (lambda (key) (cxml:with-element "Object" (cxml:with-element "Key" (cxml:text (name key))))) keys))) 'octet-vector)) (defbinder delete-objects-result ("DeleteResult" (sequence :results (alternate ("Deleted" ("Key" (bind :deleted-key))) ("Error" ("Key" (bind :error-key)) ("Code" (bind :error-code)) ("Message" (bind :error-message))))))) (defun delete-objects (bucket keys &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Delete the objects in BUCKET identified by the sequence KEYS." (let ((deleted 0) (failed '()) (subseqs (floor (length keys) 1000))) (flet ((bulk-delete (keys) (unless (<= 1 (length keys) 1000) (error "Can only delete 1 to 1000 objects per request ~ (~D attempted)." (length keys))) (let* ((content (bulk-delete-document keys)) (md5 (vector-md5/b64 content))) (let* ((response (submit-request (make-instance 'request :method :post :sub-resource "delete" :bucket bucket :content content :content-md5 md5))) (bindings (xml-bind 'delete-objects-result (body response))) (results (bvalue :results bindings))) (dolist (result results (values deleted failed)) (if (bvalue :deleted-key result) (incf deleted) (push result failed))))))) (loop for start from 0 by 1000 for end = (+ start 1000) repeat subseqs do (bulk-delete (subseq keys start end))) (let ((remainder (subseq keys (* subseqs 1000)))) (when (plusp (length remainder)) (bulk-delete (subseq keys (* subseqs 1000))))) (values deleted failed)))) (defun delete-all-objects (bucket &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Delete all objects in BUCKET." ;; FIXME: This should probably bucket-query and incrementally delete ;; instead of fetching all keys upfront. (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 (storage-class "STANDARD") (tagging nil tagging-supplied-p) ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "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. If TAGGING is provided, it should be an alist of tag keys and values to be set on the new object's tagging resource. Otherwise, the source object's tagging 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")) (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))) :storage-class storage-class :metadata-directive (if metadata-supplied-p "REPLACE" "COPY") :tagging-directive (if tagging-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)) (tagging-header (when tagging-supplied-p (list (cons "tagging" (format-tagging-header tagging)))))) (submit-request (make-instance 'request :method :put :bucket to-bucket :key to-key :metadata metadata :amz-headers (nconc headers policy-header tagging-header)))))) (defun object-metadata (bucket key &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "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)))))) ;;; Convenience bit for storage class (defun set-storage-class (bucket key storage-class &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Set the storage class of the object identified by BUCKET and KEY to STORAGE-CLASS." (copy-object :from-bucket bucket :from-key key :storage-class storage-class)) ;;; 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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) (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*) ((:backoff *backoff*) *backoff*)) "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*) ((:backoff *backoff*) *backoff*)) "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*) ((:backoff *backoff*) *backoff*)) "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*) ((:backoff *backoff*) *backoff*)) "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*) ((:backoff *backoff*) *backoff*)) (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) (ecase 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 :encode-slash nil) sub-resource)))) (defun authorized-url (&key bucket key vhost expires ssl sub-resource content-disposition content-type ((:credentials *credentials*) *credentials*)) (unless (and expires (integerp expires) (plusp expires)) (error "~S option must be a positive integer" :expires)) (let* ((region (bucket-region bucket)) (region-endpoint (region-endpoint region)) (endpoint (case vhost (:cname bucket) (:amazon (format nil "~A.~A" bucket region-endpoint)) (:wasabi (format nil "~a.s3.wasabisys.com" bucket)) ((nil) region-endpoint))) (extra-parameters (append (if content-disposition (list (cons "response-content-disposition" content-disposition))) (if content-type (list (cons "response-content-type" content-type))))) (request (make-instance 'url-based-request :method :get :bucket bucket :region region :endpoint endpoint :sub-resource sub-resource :key key :expires (unix-time expires) :parameters extra-parameters))) (setf (amz-headers request) nil) (setf (parameters request) (parameters-alist "X-Amz-Algorithm" "AWS4-HMAC-SHA256" "X-Amz-Credential" (format nil "~A/~A/~A/s3/aws4_request" (access-key *credentials*) (iso8601-basic-date-string (date request)) (region request)) "X-Amz-Date" (iso8601-basic-timestamp-string (date request)) "X-Amz-Expires" (- expires (get-universal-time)) "X-Amz-SignedHeaders" (format nil "~{~A~^;~}" (signed-headers request)))) (push (cons "X-Amz-Signature" (request-signature request)) (parameters request)) (let ((parameters (alist-to-url-encoded-string (parameters request)))) (case vhost (:cname (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A" ssl bucket (url-encode key :encode-slash nil) sub-resource parameters)) (:amazon (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A" ssl endpoint (url-encode key :encode-slash nil) sub-resource parameters)) (:wasabi (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A" ssl endpoint (url-encode key :encode-slash nil) sub-resource parameters)) ((nil) (format nil "http~@[s~*~]://~A/~@[~A/~]~@[~A~]?~@[~A&~]~A" ssl endpoint (url-encode bucket) (url-encode key :encode-slash nil) 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*) ((:backoff *backoff*) *backoff*)) "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)))) ;;; Tagging (defbinder get-tagging-result ("Tagging" ("TagSet" (sequence :tag-set ("Tag" ("Key" (bind :key)) ("Value" (bind :value))))))) (defun get-tagging (&key bucket key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Returns the current contents of the object's tagging resource as an alist." (let* ((request (make-instance 'request :method :get :bucket bucket :key key :sub-resource "tagging")) (response (submit-request request)) (tagging (xml-bind 'get-tagging-result (body response)))) (mapcar #'(lambda (tag) (cons (bvalue :key tag) (bvalue :value tag))) (bvalue :tag-set tagging)))) (defun put-tagging (tag-set &key bucket key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Sets the tag set, given as an alist, to the object's tagging resource." (let* ((content (with-xml-output (with-element "Tagging" (with-element "TagSet" (dolist (tag tag-set) (with-element "Tag" (with-element "Key" (cxml:text (car tag))) (with-element "Value" (cxml:text (cdr tag))))))))) (request (make-instance 'request :method :put :bucket bucket :key key :sub-resource "tagging" :content content))) (submit-request request))) (defun delete-tagging (&key bucket key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Deletes the object's tagging resource." (let* ((request (make-instance 'request :method :delete :bucket bucket :key key :sub-resource "tagging"))) (submit-request request))) zs3-1.3.1/lifecycle.lisp000066400000000000000000000234321322003701700150620ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2012 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. ;;;; ;;;; lifecycle.lisp (in-package #:zs3) ;;; Object expiration for buckets (defbinder lifecycle-configuration ("LifecycleConfiguration" (sequence :rules ("Rule" ("ID" (bind :id)) ("Prefix" (bind :prefix)) ("Status" (bind :status)) (alternate ("Expiration" (alternate ("Days" (bind :days)) ("Date" (bind :date)))) ("Transition" (alternate ("Days" (bind :days)) ("Date" (bind :date))) ("StorageClass" (bind :storage-class)))))))) (defclass lifecycle-rule () ((id :initarg :id :accessor id) (prefix :initarg :prefix :accessor prefix) (enabledp :initarg :enabledp :accessor enabledp) (days :documentation "The number of days after which the rule action will take effect. Can be zero, meaning that it should take effect the next time Amazon's periodic transitioning process runs. One of DAYS or DATE must be provided." :initarg :days :accessor days) (date :documentation "The date at [XXX after?] which the rule takes effect. One of DAYS or DATE must be provided." :initarg :date :accessor date) (action :documentation "The action of this rule; must be either :EXPIRE (the default) or :TRANSITION. :TRANSITION means matching objects will transition to Glacier storage." :initarg :action :accessor action)) (:documentation "A lifecycle rule. See http://docs.amazonwebservices.com/AmazonS3/latest/dev/object-lifecycle-mgmt.html#intro-lifecycle-rules.") (:default-initargs :prefix (string (gensym)) :enabledp t :days nil :date nil :action :expire)) (defmethod print-object ((rule lifecycle-rule) stream) (print-unreadable-object (rule stream :type t) (format stream "~S ~(~A~) prefix ~S ~ ~:[on ~A~;in ~:*~D day~:P~*~] ~ (~:[disabled~;enabled~])" (id rule) (action rule) (prefix rule) (days rule) (date rule) (enabledp rule)))) ;;; FIXME: The GFs for ENABLE and DISABLE should really be moved ;;; somewhere out of cloudfront.lisp now that I'm adding more methods. (defmethod disable ((rule lifecycle-rule)) (setf (enabledp rule) nil)) (defmethod enable ((rule lifecycle-rule)) (setf (enabledp rule) t)) (defun lifecycle-rule (&key id prefix (enabled t) days date (action :expire)) (unless id (setf id (string (gensym)))) (unless prefix (error "Missing PREFIX argument")) (when (or (not (or days date)) (and days date)) (error "Exactly one of :DAYS or :DATE must be provided")) (make-instance 'lifecycle-rule :id id :prefix prefix :enabledp enabled :days days :date date :action action)) (defun lifecycle-document (rules) "Return an XML document that can be posted as the lifecycle configuration of a bucket. See http://docs.amazonwebservices.com/AmazonS3/latest/dev/object-lifecycle-mgmt.html#intro-lifecycle-rules for details." (flet ((timeframe-element (rule) (if (days rule) (with-element "Days" (text (princ-to-string (days rule)))) (with-element "Date" (text (date rule)))))) (with-xml-output (with-element "LifecycleConfiguration" (dolist (rule rules) (with-element "Rule" (with-element "ID" (text (id rule))) (with-element "Prefix" (text (prefix rule))) (with-element "Status" (text (if (enabledp rule) "Enabled" "Disabled"))) (ecase (action rule) (:expire (with-element "Expiration" (timeframe-element rule))) (:transition (with-element "Transition" (timeframe-element rule) (with-element "StorageClass" (text "GLACIER"))))))))))) (defun bindings-lifecycle-rules (bindings) "Create a list of lifecycle rules from BINDINGS, which are obtained by xml-binding the LIFECYCLE-CONFIGURATION binder with a document." (let ((rules '())) (dolist (rule-bindings (bvalue :rules bindings) (nreverse rules)) (alist-bind (id prefix status days date storage-class) rule-bindings (push (make-instance 'lifecycle-rule :id id :prefix prefix :enabledp (string= status "Enabled") :action (if storage-class :transition :expire) :date date :days (and days (parse-integer days))) rules))))) (define-specific-error (no-such-lifecycle-configuration "NoSuchLifecycleConfiguration") () ()) (defun bucket-lifecycle (bucket &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Return the bucket lifecycle rules for BUCKET. Signals NO-SUCH-LIFECYCLE-CONFIGURATION if the bucket has no lifecycle configuration." (let ((response (submit-request (make-instance 'request :method :get :bucket bucket :sub-resource "lifecycle")))) (bindings-lifecycle-rules (xml-bind 'lifecycle-configuration (body response))))) (defun delete-bucket-lifecycle (bucket &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Delete the lifecycle configuration of BUCKET." (submit-request (make-instance 'request :method :delete :bucket bucket :sub-resource "lifecycle"))) (defun (setf bucket-lifecycle) (rules bucket &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) "Set the lifecycle configuration of BUCKET to RULES. RULES is coerced to a list if needed. If RULES is NIL, the lifecycle configuration is deleted with DELETE-BUCKET-LIFECYCLE." (when (null rules) (return-from bucket-lifecycle (delete-bucket-lifecycle bucket))) (unless (listp rules) (setf rules (list rules))) (let* ((content (lifecycle-document rules)) (md5 (vector-md5/b64 content))) (values rules (submit-request (make-instance 'request :method :put :bucket bucket :sub-resource "lifecycle" :content-md5 md5 :content content))))) ;;; Restoring from glacier (defun restore-request-document (days) (with-xml-output (with-element "RestoreRequest" (with-element "Days" (text (princ-to-string days)))))) (defun restore-object (bucket key &key days ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (let* ((content (restore-request-document days)) (md5 (vector-md5/b64 content))) (submit-request (make-instance 'request :method :post :content-md5 md5 :sub-resource "restore" :bucket bucket :key key :content content)))) (defun object-restoration-status (bucket key &key ((:credentials *credentials*) *credentials*) ((:backoff *backoff*) *backoff*)) (let ((headers (head :bucket bucket :key key))) (cdr (assoc :x-amz-restore headers)))) (define-specific-error (restore-already-in-progress "RestoreAlreadyInProgress") () ()) zs3-1.3.1/location.lisp000066400000000000000000000040551322003701700147330ustar00rootroot00000000000000;;;; ;;;; 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) (defbinder location-constraint ("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-constraint source))) (setf (location response) (bvalue :location bindings)) response)) (defun location-constraint-xml (location) (format nil "~ ~A~ " location)) zs3-1.3.1/logging.lisp000066400000000000000000000065421322003701700145540ustar00rootroot00000000000000;;;; ;;;; 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))) (defbinder bucket-logging-status ("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)) (with-xml-output (with-element "BucketLoggingStatus" (when (target-bucket logging-setup) (with-element "LoggingEnabled" (simple-element "TargetBucket" (target-bucket logging-setup)) (simple-element "TargetPrefix" (target-prefix logging-setup)) (when (target-grants logging-setup) (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 'bucket-logging-status source))) (setf (setup response) (bindings-logging-setup bindings)) response)) zs3-1.3.1/objects.lisp000066400000000000000000000047741322003701700145640ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; ;;;; objects.lisp (in-package #:zs3) (defclass person () ((id :initarg :id :accessor id) (display-name :initarg :display-name :accessor display-name))) (defmethod print-object ((person person) stream) (print-unreadable-object (person stream :type t) (format stream "~S" (display-name person)))) (defclass bucket () ((name :initarg :name :accessor name) (creation-date :initarg :creation-date :accessor creation-date))) (defmethod print-object ((bucket bucket) stream) (print-unreadable-object (bucket stream :type t) (format stream "~S" (name bucket)))) (defmethod name ((string string)) string) (defclass key () ((name :initarg :name :accessor name) (last-modified :initarg :last-modified :accessor last-modified) (etag :initarg :etag :accessor etag) (size :initarg :size :accessor size) (owner :initarg :owner :accessor owner) (storage-class :initarg :storage-class :accessor storage-class))) (defmethod print-object ((key key) stream) (print-unreadable-object (key stream :type t) (format stream "~S ~D" (name key) (size key)))) zs3-1.3.1/package.lisp000066400000000000000000000130021322003701700145060ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2008, 2015 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. ;;;; ;;;; package.lisp (defpackage #:zs3 (:use #:cl) ;; In documentation order and grouping: ;; Credentials (:export #:*credentials* #:access-key #:secret-key #:file-credentials) ;; Responses (:export #:*backoff* #:request-error-response #:http-code #:http-headers #:http-phrase) ;; Buckets (:export #:all-buckets #:creation-date #:name #:all-keys #:bucket-exists-p #:create-bucket #:delete-bucket #:bucket-location #:bucket-lifecycle #:lifecycle-rule) ;; Bucket queries (:export #:query-bucket #:continue-bucket-query #:bucket-name #:keys #:common-prefixes #:prefix #:marker #:delimiter #:truncatedp #:last-modified #:etag #:size #:owner #:storage-class) ;; Objects (:export #:get-object #:get-vector #:get-string #:get-file #:put-object #:put-vector #:put-string #:put-file #:put-stream #:copy-object #:delete-object #:delete-objects #:delete-all-objects #:object-metadata #:set-storage-class #:restore-object #:object-restoration-status) ;; Access Control (:export #:get-acl #:put-acl #:grant #:acl-eqv #:*all-users* #:*aws-users* #:*log-delivery* #:acl-email #:acl-person #:me #:make-public #:make-private) ;; Logging (:export #:enable-logging-to #:disable-logging-to #:enable-logging #:disable-logging #:logging-setup) ;; Tagging (:export #:get-tagging #:put-tagging #:delete-tagging) ;; Misc. (:export #:*use-ssl* #:*use-keep-alive* #:*keep-alive-stream* #:with-keep-alive #:*s3-endpoint* #:*s3-region* #:*use-content-md5* #:*signed-payload* #:make-post-policy #:head #:authorized-url #:resource-url) ;; Util (:export #:octet-vector #:now+ #:now- #:file-etag #:parameters-alist #:clear-redirects) ;; Conditions (:export #:slow-down #:no-such-bucket #:no-such-key #:access-denied #:signature-mismatch #:precondition-failed #:invalid-bucket-name #:bucket-exists #:too-many-buckets #:ambiguous-grant #:bucket-not-empty #:invalid-logging-target #:key-too-long #:request-time-skewed #:operation-aborted #:no-such-lifecycle-configuration #:restore-already-in-progress #:internal-error) ;; Cloudfront distribution management (:export #:status #:origin-bucket #:domain-name #:cnames #:default-root-object #:logging-bucket #:logging-prefix #:enabledp #:comment ;; Queries & updates #:all-distributions #:create-distribution #:delete-distribution #:refresh #:enable #:disable #:ensure-cname #:remove-cname #:set-comment #:distributions-for-bucket ;; Invalidations #:invalidate-paths ;; Conditions #:distribution-error #:distribution-error-type #:distribution-error-code #:distribution-error-http-status-code #:distribution-error-detail #:distribution-not-disabled #:cname-already-exists #:too-many-distributions) (:shadow #:method) (:shadowing-import-from #:cxml #:with-element #:text #:attribute #:attribute*)) zs3-1.3.1/post.lisp000066400000000000000000000051441322003701700141100ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; ;;;; post.lisp (in-package #:zs3) (defclass post-policy () ((expires :initarg :expires :accessor expires) (conditions :initarg :conditions :accessor conditions))) (defgeneric policy-serialize (object stream)) (defmethod policy-serialize ((condition cons) stream) (destructuring-bind (type field value &optional value2) condition (ecase type ((:eq :starts-with) (format stream "[~S, \"$~A\", ~S]" (string-downcase type) field value)) (:range (format stream "[~S, ~D, ~D]" field value value2))))) (defmethod policy-serialize ((policy post-policy) stream) (format stream "{\"expiration\": ~S, \"conditions\": [" (iso8601-date-string (expires policy))) (when (conditions policy) (destructuring-bind (first &rest rest) (conditions policy) (when first (policy-serialize first stream) (dolist (condition rest) (format stream ",") (policy-serialize condition stream))))) (format stream "]}")) (defun policy-string64 (policy) (string64 (with-output-to-string (stream) (policy-serialize policy stream)))) (defun policy-signature (key policy) (sign-string key (policy-string64 policy))) zs3-1.3.1/redirects.lisp000066400000000000000000000053331322003701700151070ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; ;;;; redirects.lisp (in-package #:zs3) (defvar *permanent-redirects* (make-hash-table :test 'equalp) "Some bucket operations make permanent redirects to different endpoints. This table stores access-key/bucket redirects for use when creating requests.") (defun redirect-key (endpoint bucket &key ((:credentials *credentials*) *credentials*)) (list endpoint bucket (access-key *credentials*))) (defun redirection-data (endpoint bucket &key ((:credentials *credentials*) *credentials*)) (gethash (redirect-key endpoint bucket) *permanent-redirects*)) (defun redirected-endpoint (endpoint bucket &key ((:credentials *credentials*) *credentials*)) (or (first (redirection-data endpoint bucket)) endpoint)) (defun redirected-region (endpoint bucket &key ((:credentials *credentials*) *credentials*)) (second (redirection-data endpoint bucket))) (defun (setf redirection-data) (new-value endpoint bucket &key ((:credentials *credentials*) *credentials*)) (check-type new-value list) (let ((key (redirect-key endpoint bucket))) (if (not new-value) (progn (remhash key *permanent-redirects*) new-value) (setf (gethash key *permanent-redirects*) new-value)))) (defun clear-redirects () (clrhash *permanent-redirects*)) zs3-1.3.1/request.lisp000066400000000000000000000415551322003701700146210ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2008, 2015 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. ;;;; ;;;; request.lisp (in-package #:zs3) (defvar *s3-endpoint* "s3.amazonaws.com") (defvar *s3-region* "us-east-1") (defvar *use-ssl* nil) (defvar *use-content-md5* t) (defvar *signed-payload* nil "When true, compute the SHA256 hash for the body of all requests when submitting to AWS.") (defvar *use-keep-alive* nil "When set to t, this library uses the drakma client with keep alive enabled. This means that a stream will be reused for multiple requests. The stream itself will be bound to *keep-alive-stream*") (defvar *keep-alive-stream* nil "When using http keep-alive, this variable is bound to the stream which is being kept open for repeated usage. It is up to client code to ensure that only one thread at a time is making requests that could use the same stream object concurrently. One way to achive this would be to create a separate binding per thread. The with-keep-alive macro can be useful here.") (defmacro with-keep-alive (&body body) "Create thread-local bindings of the zs3 keep-alive variables around a body of code. Ensure the stream is closed at exit." `(let ((*use-keep-alive* t) (*keep-alive-stream* nil)) (unwind-protect (progn ,@body) (when *keep-alive-stream* (ignore-errors (close *keep-alive-stream*)))))) (defclass request () ((credentials :initarg :credentials :accessor credentials :documentation "An object that has methods for ACCESS-KEY and SECRET-KEY. A list of two strings (the keys) suffices.") (endpoint :initarg :endpoint :accessor endpoint) (region :initarg :region :accessor region) (ssl :initarg :ssl :accessor ssl) (method :initarg :method :accessor method :documentation "e.g. :GET, :PUT, :DELETE") (bucket :initarg :bucket :accessor bucket :documentation "A string naming the bucket to address in the request. If NIL, request is not directed at a specific bucket.") (key :initarg :key :accessor key :documentation "A string naming the key to address in the request. If NIL, request is not directed at a specific key.") (sub-resource :initarg :sub-resource :accessor sub-resource :documentation "A sub-resource to address as part of the request, without a leading \"?\", e.g. \"acl\", \"torrent\". If PARAMETERS is set, this must be NIL.") (parameters :initarg :parameters :accessor parameters :documentation "An alist of string key/value pairs to send as CGI-style GET parameters with the request. If SUB-RESOURCE is set, these must be NIL.") (content-type :initarg :content-type :accessor content-type) (content-md5 :initarg :content-md5 :accessor content-md5) (content-length :initarg :content-length :accessor content-length) (content :initarg :content :accessor content) (metadata :initarg :metadata :accessor metadata :documentation "An alist of Amazon metadata to attach to a request. These should be straight string key/value pairs, WITHOUT any \"x-amz-meta-\" prefix.") (amz-headers :initarg :amz-headers :accessor amz-headers :documentation "An alist of extra Amazon request headers. These should be straight string key/value pairs, WITHOUT any \"x-amz-\" prefix.") (date :initarg :date :accessor date) (signed-string :initarg :signed-string :accessor signed-string) (extra-http-headers :initarg :extra-http-headers :accessor extra-http-headers :documentation "An alist of extra HTTP headers to include in the request.")) (:default-initargs ;; :date and :content-md5 are specially treated, should not be nil :credentials *credentials* :method :get :endpoint *s3-endpoint* :region *s3-region* :ssl *use-ssl* :bucket nil :key nil :sub-resource nil :parameters nil :content-type nil :content-length t :content nil :metadata nil :amz-headers nil :extra-http-headers nil)) (defmethod slot-unbound ((class t) (request request) (slot (eql 'date))) (setf (date request) (get-universal-time))) (defmethod slot-unbound ((class t) (request request) (slot (eql 'content-md5))) (setf (content-md5 request) (when *use-content-md5* (let ((content (content request))) (cond ((pathnamep content) (file-md5/b64 content)) ((stringp content) (vector-md5/b64 (flexi-streams:string-to-octets content))) ((vectorp content) (vector-md5/b64 content))))))) (defmethod slot-unbound ((class t) (request request) (slot (eql 'signed-string))) (setf (signed-string request) (format nil "~{~A~^~%~}" (string-to-sign-lines request)))) (defgeneric amz-header-value (request name) (:method (request name) (cdr (assoc name (amz-headers request) :test 'string=)))) (defgeneric ensure-amz-header (request name value) (:method (request name value) (unless (amz-header-value request name) (push (cons name value) (amz-headers request))))) (defmethod initialize-instance :after ((request request) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (when (eql (method request) :head) ;; https://forums.aws.amazon.com/thread.jspa?messageID=340398 - ;; when using the bare endpoint, the 301 redirect for a HEAD ;; request does not include enough info to actually redirect. Use ;; the bucket endpoint pre-emptively instead (setf (endpoint request) (format nil "~A.~A" (bucket request) *s3-endpoint*))) (ensure-amz-header request "date" (iso8601-basic-timestamp-string (date request))) (ensure-amz-header request "content-sha256" (payload-sha256 request)) (let ((target-region (redirected-region (endpoint request) (bucket request)))) (when target-region (setf (region request) target-region))) (when (content-md5 request) (push (cons "Content-MD5" (content-md5 request)) (extra-http-headers request))) (unless (integerp (content-length request)) (let ((content (content request))) (setf (content-length request) (etypecase content (null 0) (pathname (file-size content)) (vector (length content))))))) (defgeneric host (request) (:method ((request request)) (or (redirected-endpoint (endpoint request) (bucket request)) (endpoint request)))) (defgeneric http-method (request) (:method (request) (string-upcase (method request)))) (defun puri-canonicalized-path (path) (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path)))) (with-output-to-string (stream) (if (puri:uri-path parsed) (write-string (puri:uri-path parsed) stream) (write-string "/" stream)) (when (puri:uri-query parsed) (write-string "?" stream) (write-string (puri:uri-query parsed) stream))))) (defgeneric signed-path (request) (:method (request) (let ((*print-pretty* nil)) (puri-canonicalized-path (with-output-to-string (stream) (write-char #\/ stream) (when (bucket request) (write-string (url-encode (name (bucket request))) stream) (write-char #\/ stream)) (when (key request) (write-string (url-encode (name (key request)) :encode-slash nil) stream)) (when (sub-resource request) (write-string "?" stream) (write-string (url-encode (sub-resource request)) stream))))))) (defgeneric request-path (request) (:method (request) (let ((*print-pretty* nil)) (with-output-to-string (stream) (write-char #\/ stream) (when (and (bucket request) (string= (endpoint request) (region-endpoint (region request)))) (write-string (url-encode (name (bucket request))) stream) (write-char #\/ stream)) (when (key request) (write-string (url-encode (name (key request)) :encode-slash nil) stream)) (when (sub-resource request) (write-string "?" stream) (write-string (url-encode (sub-resource request)) stream)))))) (defgeneric all-amazon-headers (request) (:method (request) (nconc (loop for ((key . value)) on (amz-headers request) collect (cons (format nil "x-amz-~(~A~)" key) value)) (loop for ((key . value)) on (metadata request) collect (cons (format nil "x-amz-meta-~(~A~)" key) value))))) (defgeneric date-string (request) (:method (request) (http-date-string (date request)))) ;;; AWS 4 authorization (defun headers-for-signing (request) (append (all-amazon-headers request) (extra-http-headers request) (parameters-alist "host" (host request) "content-type" (content-type request)))) (defun canonical-headers (headers) (flet ((trim (string) (string-trim " " string))) (let ((encoded (loop for (name . value) in headers collect (cons (string-downcase name) (trim value))))) (sort encoded #'string< :key 'car)))) (defun signed-headers (request) (mapcar 'first (canonical-headers (headers-for-signing request)))) (defun parameters-for-signing (request) (cond ((sub-resource request) (list (cons (sub-resource request) ""))) (t (parameters request)))) (defun canonical-parameters (parameters) (let ((encoded (loop for (name . value) in parameters collect (cons (url-encode name) (url-encode value))))) (sort encoded #'string< :key 'car))) (defun canonical-parameters-string (request) (format nil "~{~A=~A~^&~}" (alist-plist (canonical-parameters (parameters-for-signing request))))) (defun path-to-sign (request) "Everything in the PATH of the request, up to the first ?" (let ((path (request-path request))) (subseq path 0 (position #\? path)))) (defun canonicalized-request-lines (request) "Return a list of lines canonicalizing the request according to http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html." (let* ((headers (headers-for-signing request)) (canonical-headers (canonical-headers headers))) (alexandria:flatten (list (http-method request) (path-to-sign request) (canonical-parameters-string request) (loop for (name . value) in canonical-headers collect (format nil "~A:~A" name value)) "" (format nil "~{~A~^;~}" (signed-headers request)) (or (amz-header-value request "content-sha256") "UNSIGNED-PAYLOAD"))))) (defun string-to-sign-lines (request) "Return a list of strings to sign to construct the Authorization header." (list "AWS4-HMAC-SHA256" (iso8601-basic-timestamp-string (date request)) (with-output-to-string (s) (format s "~A/~A/s3/aws4_request" (iso8601-basic-date-string (date request)) (region request))) (strings-sha256/hex (canonicalized-request-lines request)))) (defun make-signing-key (credentials &key region service) "The signing key is derived from the credentials, region, date, and service. A signing key could be saved, shared, and reused, but ZS3 just recomputes it all the time instead." (let* ((k1 (format nil "AWS4~A" (secret-key credentials))) (date-key (hmac-sha256 k1 (iso8601-basic-date-string))) (region-key (hmac-sha256 date-key region)) (service-key (hmac-sha256 region-key service))) (hmac-sha256 service-key "aws4_request"))) (defun payload-sha256 (request) (if *signed-payload* (let ((payload (content request))) (etypecase payload ((or null empty-vector) *empty-string-sha256*) (vector (vector-sha256/hex payload)) (pathname (file-sha256/hex payload)))) "UNSIGNED-PAYLOAD")) (defun request-signature (request) (let ((key (make-signing-key *credentials* :region (region request) :service "s3"))) (strings-hmac-sha256/hex key (string-to-sign-lines request) ))) (defmethod authorization-header-value ((request request)) (let ((key (make-signing-key *credentials* :region (region request) :service "s3")) (lines (string-to-sign-lines request))) (with-output-to-string (s) (write-string "AWS4-HMAC-SHA256" s) (format s " Credential=~A/~A/~A/s3/aws4_request" (access-key *credentials*) (iso8601-basic-date-string (date request)) (region request)) (format s ",SignedHeaders=~{~A~^;~}" (signed-headers request)) (format s ",Signature=~A" (strings-hmac-sha256/hex key lines))))) (defgeneric drakma-headers (request) (:method (request) (let ((base (list* (cons "Date" (http-date-string (date request))) (cons "Authorization" (authorization-header-value request)) (all-amazon-headers request)))) (append (extra-http-headers request) base)))) (defgeneric url (request) (:method (request) (format nil "http~@[s~*~]://~A~A" (ssl request) (endpoint request) (request-path request)))) (defun send-file-content (fun request) (with-open-file (stream (content request) :element-type '(unsigned-byte 8)) (let* ((buffer-size 8000) (buffer (make-octet-vector buffer-size))) (flet ((read-exactly (size) (assert (= size (read-sequence buffer stream))))) (multiple-value-bind (loops rest) (truncate (content-length request) buffer-size) (dotimes (i loops) (read-exactly buffer-size) (funcall fun buffer t)) (read-exactly rest) (funcall fun (subseq buffer 0 rest) nil)))))) (defgeneric send (request &key want-stream stream) (:method (request &key want-stream stream) (let ((continuation (drakma:http-request (url request) :redirect nil :want-stream want-stream :stream stream :keep-alive *use-keep-alive* :close (not *use-keep-alive*) :content-type (content-type request) :additional-headers (drakma-headers request) :method (method request) :force-binary t :content-length (content-length request) :parameters (parameters request) :content :continuation))) (let ((content (content request))) (if (pathnamep content) (send-file-content continuation request) (funcall continuation content nil)))))) (defmethod access-key ((request request)) (access-key (credentials request))) (defmethod secret-key ((request request)) (secret-key (credentials request))) (defmethod security-token ((request request)) (security-token (credentials request))) zs3-1.3.1/response.lisp000066400000000000000000000171431322003701700147630ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2008, 2015 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. ;;;; ;;;; response.lisp (in-package #:zs3) (defvar *response-element-classes* (make-hash-table :test 'equal)) (defun set-element-class (element-name class) (setf (gethash element-name *response-element-classes*) class)) (defclass response () ((request :initarg :request :accessor request) (body :initarg :body :accessor body) (http-code :initarg :http-code :accessor http-code) (http-phrase :initarg :http-phrase :accessor http-phrase) (http-headers :initarg :http-headers :accessor http-headers)) (:default-initargs :request nil :body nil :http-code 999 :http-phrase "" :http-headers nil)) (defmethod print-object ((response response) stream) (print-unreadable-object (response stream :type t :identity t) (format stream "~D ~S" (http-code response) (http-phrase response)))) (defgeneric xml-string (response) (:method (response) (flexi-streams:octets-to-string (body response) :external-format :utf-8))) (defgeneric response-specialized-class (name) (:method (name) (gethash name *response-element-classes*))) (defgeneric specialized-initialize (object source) (:method (object (source t)) object)) (defgeneric content-length (response) (:method (response) (parse-integer (drakma:header-value :content-length (http-headers response))))) (defgeneric specialize-response (response) (:method ((response response)) (cond ((or (null (body response)) (and (not (streamp (body response))) (zerop (length (body response))))) (when (<= 500 (http-code response) 599) (change-class response 'amazon-error) (specialized-initialize response nil)) response) (t (let* ((source (xml-source (body response))) (type (xml-document-element source)) (class (response-specialized-class type))) (when class (change-class response class) (specialized-initialize response source)) response))))) (defun close-keep-alive () (when *keep-alive-stream* (ignore-errors (close *keep-alive-stream*)) (setq *keep-alive-stream* nil))) (defun request-response (request &key body-stream keep-stream (handler 'specialize-response)) (setf (endpoint request) (redirected-endpoint (endpoint request) (bucket request))) (ensure-amz-header request "date" (iso8601-basic-timestamp-string (date request))) (multiple-value-bind (body code headers uri stream must-close phrase) (send request :want-stream body-stream :stream *keep-alive-stream*) (declare (ignore uri)) (let ((response (make-instance 'response :request request :body body :http-code code :http-phrase phrase :http-headers headers))) (if (and keep-stream (not must-close)) (progn (when *use-keep-alive* (unless (eq *keep-alive-stream* stream) (close-keep-alive) (setq *keep-alive-stream* stream))) (funcall handler response)) (with-open-stream (stream stream) (declare (ignorable stream)) (setq *keep-alive-stream* nil) (funcall handler response)))))) (defvar *backoff* (cons 3 100) "Used as the default value of :BACKOFF when submitting a request. The value should be a cons of two numbers: how many times to try before giving up, and how long to wait (in ms) before trying for the second time. Each subsequent attempt will double that time.") (defun submit-request (request &key body-stream (keep-stream *use-keep-alive*) (handler 'specialize-response)) ;; The original endpoint has to be stashed so it can be updated as ;; needed by AuthorizationHeaderMalformed responses after being ;; clobbered in the request by TemporaryRedirect responses. (let* ((original-endpoint (endpoint request)) (backoff *backoff*) (tries (car backoff)) (delay (/ (cdr backoff) 1000))) (loop (handler-case (let ((response (request-response request :keep-stream keep-stream :body-stream body-stream :handler handler))) (maybe-signal-error response) (setf (request response) request) (return response)) (temporary-redirect (condition) (setf (endpoint request) (request-error-endpoint condition))) (authorization-header-malformed (condition) (let ((region (request-error-region condition))) (setf (redirection-data original-endpoint (bucket request)) (list (endpoint request) region)) (setf (region request) region))) (permanent-redirect (condition) ;; Remember the new endpoint long-term (let ((new-endpoint (request-error-endpoint condition)) (new-region (cdr (assoc :x-amz-bucket-region (http-headers (request-error-response condition)))))) (setf (redirection-data (endpoint request) (bucket request)) (list new-endpoint (or new-region (region request)))) (setf (endpoint request) new-endpoint) (when new-region (setf (region request) new-region)))) (internal-error (e) ;; Per the S3 docs, InternalErrors should be retried. Up to ;; a point. (close-keep-alive) (when (minusp (decf tries)) ;; We've exceeded our failure allowance. Resignal. (error e)) (sleep delay) (incf delay delay)) (error (e) ;; Ensure that we don't reuse the stream, it may be the source of ;; our error. Then resignal. (close-keep-alive) (error e)))))) zs3-1.3.1/tests.lisp000066400000000000000000000045021322003701700142620ustar00rootroot00000000000000;;;; tests.lisp ;;;; ;;;; This is for simple prerelase sanity testing, not general ;;;; use. Please ignore. (defpackage #:zs3-tests (:use #:cl #:zs3)) (in-package #:zs3-tests) (setf *credentials* (file-credentials "~/.aws")) (defparameter *test-bucket* "zs3-tests33") (when (bucket-exists-p *test-bucket*) (delete-bucket *test-bucket*)) (create-bucket *test-bucket*) (put-file "/etc/issue" *test-bucket* "printcap") (put-string "Hello, world" *test-bucket* "hello") (put-string "Plus good" *test-bucket* "plus+good") (put-vector (octet-vector 8 6 7 5 3 0 9) *test-bucket* "jenny") (all-buckets) (all-keys *test-bucket*) (delete-object *test-bucket* "printcap") (delete-object *test-bucket* "hello") (delete-object *test-bucket* "plus+good") (delete-object *test-bucket* "jenny") (put-string "Hello, world" *test-bucket* "hello" :start 1 :end 5) (string= (get-string *test-bucket* "hello") (subseq "Hello, world" 1 5)) (put-file "tests.lisp" *test-bucket* "self" :start 1 :end 5) (string= (get-string *test-bucket* "self") ";;; ") (defparameter *jenny* (octet-vector 8 6 7 5 3 0 9)) (put-vector *jenny* *test-bucket* "jenny" :start 1 :end 6 :public t) (equalp (get-vector *test-bucket* "jenny") (subseq *jenny* 1 6)) (drakma:http-request (resource-url :bucket *test-bucket* :key "jenny")) (delete-object *test-bucket* "hello") (delete-object *test-bucket* "self") (delete-object *test-bucket* "jenny") (put-string "Tildedot" *test-bucket* "slash~dot") (put-string "Spacedot" *test-bucket* "slash dot") (delete-object *test-bucket* "slash/dot") (delete-object *test-bucket* "slash~dot") (delete-object *test-bucket* "slash dot") ;;; Subresources (put-string "Fiddle dee dee" *test-bucket* "fiddle") (make-public :bucket *test-bucket* :key "fiddle") (make-private :bucket *test-bucket* :key "fiddle") (delete-object *test-bucket* "fiddle") ;;; Different regions (delete-bucket *test-bucket*) (create-bucket *test-bucket* :location "eu-central-1") (put-string "Hello, world" *test-bucket* "hello") ;;; CloudFront distributions (defparameter *distro* (create-distribution *test-bucket* :cnames "zs3-tests.cdn.wigflip.com" :enabled nil :comment "Testing, 1 2 3")) (progn (sleep 240) (delete-distribution *distro*)) (delete-bucket *test-bucket*) zs3-1.3.1/utils.lisp000066400000000000000000000302111322003701700142540ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; ;;;; utils.lisp (in-package #:zs3) (defvar *months* #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) (defvar *days* #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) (deftype octet () '(unsigned-byte 8)) (deftype octet-vector (&optional size) `(simple-array octet (,size))) (deftype empty-vector () `(vector * 0)) (defun http-date-string (&optional (time (get-universal-time))) "Return a HTTP-style date string." (multiple-value-bind (second minute hour day month year day-of-week) (decode-universal-time time 0) (let ((*print-pretty* nil)) (format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT" (aref *days* day-of-week) day (aref *months* (1- month)) year hour minute second)))) (defun iso8601-date-string (&optional (time (get-universal-time))) "Return an ISO8601-style date string." (multiple-value-bind (second minute hour day month year) (decode-universal-time time 0) (let ((*print-pretty* nil)) (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ" year month day hour minute second)))) (defun iso8601-basic-timestamp-string (&optional (time (get-universal-time))) "Return an ISO8601-style basic date string." (multiple-value-bind (second minute hour day month year) (decode-universal-time time 0) (let ((*print-pretty* nil)) (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0DZ" year month day hour minute second)))) (defun iso8601-basic-date-string (&optional (time (get-universal-time))) "Return an ISO8601-style basic date string." (multiple-value-bind (second minute hour day month year) (decode-universal-time time 0) (declare (ignore second minute hour)) (let ((*print-pretty* nil)) (format nil "~4,'0D~2,'0D~2,'0D" year month day)))) (defun string-octets (string) "Return the UTF-8 encoding of STRING as a vector of octets." (flexi-streams:string-to-octets string :external-format :utf-8)) (defun string64 (string) (cl-base64:usb8-array-to-base64-string (string-octets string))) (defun url-decode (string) (with-output-to-string (out) (let ((code 0)) (labels ((in-string (char) (case char (#\% #'h1) (t (write-char char out) #'in-string))) (weight (char) (let ((weight (digit-char-p char 16))) (unless weight (error "~S is not a hex digit" char)) weight)) (h1 (char) (setf code (ash (weight char) 4)) #'h2) (h2 (char) (incf code (weight char)) (write-char (code-char code) out) #'in-string)) (let ((state #'in-string)) (loop for char across string do (setf state (funcall state char)))))))) ;;; The following two functions were adatpted from Drakma source. It ;;; has been adapted to more closely follow the description of ;;; UriEncode() in ;;; http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html (defun url-encode (string &key (encode-slash t)) "Returns a URL-encoded version of the string STRING using the LispWorks external format EXTERNAL-FORMAT." (let ((*print-pretty* nil)) (with-output-to-string (out) (loop for octet across (string-octets (or string "")) for char = (code-char octet) ;;'A'-'Z', 'a'-'z', '0'-'9', '-', '.', '_', and '~' do (cond ((or (char<= #\0 char #\9) (char<= #\a char #\z) (char<= #\A char #\Z) (and (not encode-slash) (char= char #\/)) (find char "-._~" :test #'char=)) (write-char char out)) ((or (char= char #\Space) (char= char #\+)) (write-string "%20" out)) (t (format out "~:@(%~2,'0x~)" octet))))))) (defun alist-to-url-encoded-string (alist) "ALIST is supposed to be an alist of name/value pairs where both names and values are strings. This function returns a string where this list is represented as for the content type `application/x-www-form-urlencoded', i.e. the values are URL-encoded using the external format EXTERNAL-FORMAT, the pairs are joined with a #\\& character, and each name is separated from its value with a #\\= character." (let ((*print-pretty* nil)) (with-output-to-string (out) (loop for first = t then nil for (name . value) in alist unless first do (write-char #\& out) do (format out "~A=~A" (url-encode name) (url-encode value)))))) (defun save (response file) "Write a sequence of octets RESPONSE to FILE." (with-open-file (stream file :direction :output :if-exists :supersede :element-type 'octet) (write-sequence response stream)) (probe-file file)) (defun parse-amazon-timestamp (string) "Convert the ISO 8601-format STRING to a universal time." (flet ((number-at (start length) (parse-integer string :start start :end (+ start length)))) (let ((year (number-at 0 4)) (month (number-at 5 2)) (day (number-at 8 2)) (hour (number-at 11 2)) (minute (number-at 14 2)) (second (number-at 17 2))) (encode-universal-time second minute hour day month year 0)))) (defun stringify (thing) (typecase thing (string thing) (symbol (symbol-name thing)) (t (princ-to-string thing)))) (defun parameters-alist (&rest args &key &allow-other-keys) "Construct an ALIST based on all keyword arguments passed to the function. Keywords are converted to their lowercase symbol name and values are converted to strings." (loop for (key value) on args by #'cddr when value collect (cons (if (symbolp key) (string-downcase (symbol-name key)) key) (stringify value)))) (defun last-entry (array) "If ARRAY has one ore more entries, return the last one. Otherwise, return NIL." (and (plusp (length array)) (aref array (1- (length array))))) (defun file-size (file) (with-open-file (stream file :element-type 'octet) (file-length stream))) (defvar +unix-time-difference+ (encode-universal-time 0 0 0 1 1 1970 0)) (defun unix-time (&optional (universal-time (get-universal-time))) (- universal-time +unix-time-difference+)) (defun octet-vector (&rest octets) (make-array (length octets) :element-type 'octet :initial-contents octets)) (defun keywordify (string-designator) (intern (string string-designator) :keyword)) (defun make-octet-vector (size) (make-array size :element-type 'octet)) (defun now+ (delta) (+ (get-universal-time) delta)) (defun now- (delta) (- (get-universal-time) delta)) (defun copy-n-octets (count input output) "Copy the first N octets from the stream INPUT to the stream OUTPUT." (let ((buffer (make-octet-vector 4096))) (multiple-value-bind (loops rest) (truncate count 4096) (dotimes (i loops) (read-sequence buffer input) (write-sequence buffer output)) (let ((trailing-count (read-sequence buffer input :end rest))) (assert (= trailing-count rest)) (write-sequence buffer output :end rest))))) (defun starts-with (prefix string) (and (<= (length prefix) (length string)) (string= prefix string :end2 (length prefix)))) (defun ends-with (suffix string) (and (<= (length suffix) (length string)) (string= suffix string :start2 (- (length string) (length suffix))))) ;;; Getting stream/file subset vectors (defparameter *file-buffer-size* 8192) (defun make-file-buffer () (make-octet-vector *file-buffer-size*)) (defun read-exactly-n-octets (stream n &optional buffer) "Read exactly N octets from STREAM into BUFFER. If fewer than N octets are read, signal an CL:END-OF-FILE error. If BUFFER is not supplied or is NIL, create a fresh buffer of length N and return it." (unless buffer (setf buffer (make-octet-vector n))) (let ((end (min (length buffer) n))) (let ((count (read-sequence buffer stream :end end))) (unless (= n count) (error 'end-of-file :stream stream)) buffer))) (defun read-complete-file-buffer (stream &optional buffer) "Read a complete buffer of size *FILE-BUFFER-SIZE*." (read-exactly-n-octets stream *file-buffer-size* buffer)) (defun merge-file-buffers (buffers size) "Create one big vector from BUFFERS and TRAILER." (let ((output (make-octet-vector size)) (start 0)) (dotimes (i (ceiling size *file-buffer-size*)) (replace output (pop buffers) :start1 start) (incf start *file-buffer-size*)) output)) (defun skip-stream-octets (stream count) "Read and discard COUNT octets from STREAM." (let ((buffer (make-file-buffer))) (multiple-value-bind (loops rest) (truncate count *file-buffer-size*) (dotimes (i loops) (read-complete-file-buffer stream buffer)) (read-exactly-n-octets stream rest buffer))) t) (defun drained-stream-vector (stream) "Read octets from STREAM until EOF and them as an octet vector." (let ((buffers '()) (size 0)) (loop (let* ((buffer (make-file-buffer)) (count (read-sequence buffer stream))) (incf size count) (push buffer buffers) (when (/= count *file-buffer-size*) (return (merge-file-buffers (nreverse buffers) size))))))) (defun partial-stream-vector (stream n) "Read N octets from STREAM and return them in an octet vector." (let ((buffers '())) (multiple-value-bind (loops rest) (truncate n *file-buffer-size*) (dotimes (i loops) (let ((buffer (make-file-buffer))) (read-complete-file-buffer stream buffer) (push buffer buffers))) (push (read-exactly-n-octets stream rest) buffers) (merge-file-buffers (nreverse buffers) n)))) (defun stream-subset-vector (stream start end) (unless start (setf start 0)) (when (minusp start) (error "START must be non-negative")) (when (and end (< end start)) (error "END must be greater than START")) (when (plusp start) (skip-stream-octets stream start)) (if (not end) (drained-stream-vector stream) (partial-stream-vector stream (- end start)))) (defun file-subset-vector (file start end) (with-open-file (stream file :element-type 'octet) (stream-subset-vector stream start end))) (defun alist-plist (alist) (loop for (key . value) in alist collect key collect value)) zs3-1.3.1/xml-binding.lisp000066400000000000000000000271011322003701700153300ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; ;;;; xml-binding.lisp (in-package #:zs3) ;;; utility (defun skip-document-start (source) (let ((type (klacks:peek source))) (when (eql :start-document type) (klacks:consume source)) (values))) (defun skip-characters (source) (loop (if (member (klacks:peek source) '(:characters :comment)) (klacks:consume source) (return)))) (defun collect-characters (source) (with-output-to-string (stream) (loop (multiple-value-bind (type data) (klacks:peek source) (cond ((eql type :characters) (write-string data stream) (klacks:consume source)) (t (return))))))) (defun collect-rest-alist (source) "Collect the rest of SOURCE, up to an un-nested closing tag, as an alist of element names and their character contents." (let ((result '())) (loop (multiple-value-bind (type uri lname) (klacks:peek source) (declare (ignore uri)) (ecase type (:characters (klacks:consume source)) (:end-element (return (nreverse result))) (:start-element (klacks:consume source) (push (cons lname (collect-characters source)) result) (klacks:find-event source :end-element) (klacks:consume source))))))) ;;; Match failure conditions (define-condition xml-binding-error (error) ((expected :initarg :expected :accessor expected) (actual :initarg :actual :accessor actual)) (:report (lambda (condition stream) (format stream "Unexpected XML structure: expected ~S, got ~S instead" (expected condition) (actual condition))))) ;;; API (defvar *binder-definitions* (make-hash-table)) (defclass binder () ((source :initarg :source :accessor source) (closure :initarg :closure :accessor closure))) (defmacro defbinder (name &body source) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',name *binder-definitions*) (make-instance 'binder :closure (make-binder ',@source) :source ',@source)))) (defun find-binder (name &optional (errorp t)) (let ((binder (gethash name *binder-definitions*))) (or binder (and errorp (error "No binder named ~S" name))))) (defun xml-bind (binder-name source) (funcall (closure (find-binder binder-name)) source)) (defun try-to-xml-bind (binder-name source) "Like XML-BIND, but catches any XML-BINDING-ERRORs; if any errors are caught, NIL is the primary value and the error object is the secondary value." (handler-case (xml-bind binder-name source) (xml-binding-error (c) (values nil c)))) ;;; Creating the matchers/binders (defvar *current-element-name*) (defun create-element-start-matcher (element-name kk) "Return a function that expects to see the start of ELEMENT-NAME next in SOURCE." (lambda (source bindings k) (skip-characters source) (multiple-value-bind (type uri lname qname) (klacks:peek source) (declare (ignore uri qname)) (when (not (eql type :start-element)) (error 'xml-binding-error :expected (list :start-element element-name) :actual (list :event type))) (when (string/= element-name lname) (error 'xml-binding-error :expected (list :start-element element-name) :actual (list type lname))) (klacks:consume source) (funcall kk source bindings k)))) (defun create-element-end-matcher (element-name kk) "Return a function that expects to see the end of ELEMENT-NAME next in SOURCE." (lambda (source bindings k) (skip-characters source) (multiple-value-bind (type uri lname qname) (klacks:peek source) (declare (ignore uri qname)) (when (not (eql type :end-element)) (error 'xml-binding-error :expected (list :end-element element-name) :actual (list :event type lname))) (when (string/= element-name lname) (error 'xml-binding-error :expected (list :end-element element-name) :actual (list type lname))) (klacks:consume source) (funcall kk source bindings k)))) (defun create-bindings-extender (key kk) "Return a function that extends BINDINGS with KEY and a value of whatever character data is pending in SOURCE." (lambda (source bindings k) (funcall kk source (acons key (collect-characters source) bindings) k))) (defun create-skipper (element-name kk) "Return a function that skips input in SOURCE until it sees a closing tag for ELEMENT-NAME. Nested occurrences of elements with the same ELEMENT-NAME are also skipped." (let ((depth 0)) (lambda (source bindings k) (loop (multiple-value-bind (type uri lname) (klacks:consume source) (declare (ignore uri)) (cond ((and (eql type :end-element) (string= lname element-name)) (if (zerop depth) (return (funcall kk source bindings k)) (decf depth))) ((and (eql type :start-element) (string= lname element-name)) (incf depth)))))))) (defun create-bindings-returner () "Return a function that does nothing but return its BINDINGS, effectively ending matching." (lambda (source bindings k) (declare (ignore source k)) (nreverse bindings))) (defmacro catching-xml-errors (&body body) `(handler-case (progn ,@body) (xml-binding-error (c) (values nil c)))) (defun create-sequence-binder (key forms kk) "Return a function that creates a list of sub-bindings based on a sub-matcher, with KEY as the key." (let ((binder (create-binder forms (create-bindings-returner)))) (lambda (source bindings k) (let ((sub-bindings '())) (loop (skip-characters source) (multiple-value-bind (sub-binding failure) (catching-xml-errors (funcall binder source nil k)) (if failure (return (funcall kk source (acons key (nreverse sub-bindings) bindings) k)) (push sub-binding sub-bindings)))))))) (defun create-alist-binder (key kk) "Return a function that returns the rest of SOURCE as an alist of element-name/element-content data." (lambda (source bindings k) (funcall kk source (acons key (collect-rest-alist source) bindings) k))) (defun create-optional-binder (subforms kk) (let ((binder (create-binder subforms kk))) (lambda (source bindings k) (skip-characters source) (multiple-value-bind (optional-bindings failure) (catching-xml-errors (funcall binder source bindings k)) (if failure (funcall kk source bindings k) optional-bindings))))) (defun create-alternate-binder (subforms kk) (let ((binders (mapcar (lambda (form) (create-binder form kk)) subforms))) (lambda (source bindings k) ;; FIXME: This xml-binding-error needs :expected and :action ;; ooptions. Can get actual with peeking and expected by getting ;; the cl:cars of subforms...maybe. (dolist (binder binders (error 'xml-binding-error)) (multiple-value-bind (alt-bindings failure) (catching-xml-errors (funcall binder source bindings k)) (unless failure (return alt-bindings))))))) (defun create-sub-binder-binder (binder-name kk) (lambda (source bindings k) (let ((binder (find-binder binder-name))) (let ((sub-bindings (funcall (closure binder) source))) (funcall k source (append sub-bindings bindings) kk))))) (defun create-special-processor (operator form k) "Handle special pattern processing forms like BIND, SKIP-REST, SEQUENCE, etc." (ecase operator (include (create-sub-binder-binder (second form) k)) (alternate (create-alternate-binder (rest form) k)) (bind (create-bindings-extender (second form) k)) (optional (create-optional-binder (second form) k)) (skip-rest (create-skipper *current-element-name* k)) (sequence (destructuring-bind (key subforms) (rest form) (create-sequence-binder key subforms k))) (elements-alist (create-alist-binder (second form) k)))) (defun create-binder (form &optional (k (create-bindings-returner))) "Process FORM as an XML binder pattern and return a closure to process an XML source." (let ((operator (first form))) (etypecase operator (string (let ((*current-element-name* operator)) (create-element-start-matcher *current-element-name* (create-binder (rest form) k)))) (null (create-element-end-matcher *current-element-name* k)) (cons (create-binder operator (create-binder (rest form) k))) (symbol (create-special-processor operator form k))))) (defun xml-source (source) (typecase source (cxml::cxml-source source) (t (cxml:make-source source)))) (defun make-binder (form) (let ((binder (create-binder form (create-bindings-returner)))) (lambda (source) (let ((source (xml-source source))) (skip-document-start source) (funcall binder source nil (create-bindings-returner)))))) (defun xml-document-element (source) (nth-value 2 (klacks:find-event (xml-source source) :start-element))) (defun bvalue (key bindings) (cdr (assoc key bindings))) (defun bfun (key) (lambda (binding) (bvalue key binding))) (defmacro alist-bind (bindings alist &body body) (let ((binds (gensym))) (flet ((one-binding (var) (let ((keyword (intern (symbol-name var) :keyword))) `(when (eql (caar ,binds) ,keyword) (setf ,var (cdr (pop ,binds))))))) `(let ,bindings (let ((,binds ,alist)) ,@(mapcar #'one-binding bindings) ,@body))))) ;;; Protocol (defgeneric merge-bindings (object bindings) (:documentation "Update OBJECT with the data from BINDINGS.")) zs3-1.3.1/xml-output.lisp000066400000000000000000000031211322003701700152520ustar00rootroot00000000000000;;;; ;;;; Copyright (c) 2012 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. ;;;; ;;;; xml-output.lisp (in-package #:zs3) (defmacro with-xml-output (&body body) `(cxml:with-xml-output (cxml:make-octet-vector-sink) ,@body)) (defun simple-element (name value) (with-element name (cxml:text value))) zs3-1.3.1/zs3.asd000066400000000000000000000046151322003701700134440ustar00rootroot00000000000000;;;; ;;;; 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. ;;;; ;;;; zs3.asd (asdf:defsystem #:zs3 :depends-on (#:drakma #:alexandria #:cxml #:ironclad #:puri #:cl-base64) :version "1.3.1" :description "A Common Lisp library for working with Amazon's Simple Storage Service (S3) and CloudFront content delivery service." :author "Zach Beane " :license "BSD" :serial t :components ((:file "package") (:file "utils") (:file "crypto") (:file "xml-binding") (:file "xml-output") (:file "credentials") (:file "post") (:file "redirects") (:file "request") (:file "response") (:file "objects") (:file "bucket-listing") (:file "errors") (:file "acl") (:file "logging") (:file "location") (:file "interface") (:file "cloudfront") (:file "lifecycle")))