Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

228 lines (183 sloc) 7.823 kb
;;;;
;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;;
;;;; * Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;;
;;;; * Redistributions in binary form must reproduce the above
;;;; copyright notice, this list of conditions and the following
;;;; disclaimer in the documentation and/or other materials
;;;; provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
;;;; 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 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"))
(:report (lambda (condition stream)
(report-request-error condition stream)
(format stream "You signed: ~S~%Amazon signed: ~S"
(signed-string (request-error-request condition))
(request-error-string-to-sign condition)))))
(define-specific-error (precondition-failed "PreconditionFailed") ()
((condition "Condition")))
(define-condition linked ()
((url
:initarg :url
:reader linked-url))
(:report (lambda (condition stream)
(report-request-error condition stream)
(format stream "~&For more information, see:~% ~A"
(linked-url condition)))))
(define-condition bucket-restrictions (linked)
()
(:default-initargs
:url "http://docs.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") () ())
Jump to Line
Something went wrong with that request. Please try again.