errors.lisp

   1 ;;;;
   2 ;;;; Copyright (c) 2008 Zachary Beane, All Rights Reserved
   3 ;;;;
   4 ;;;; Redistribution and use in source and binary forms, with or without
   5 ;;;; modification, are permitted provided that the following conditions
   6 ;;;; are met:
   7 ;;;;
   8 ;;;;   * Redistributions of source code must retain the above copyright
   9 ;;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;;
  11 ;;;;   * Redistributions in binary form must reproduce the above
  12 ;;;;     copyright notice, this list of conditions and the following
  13 ;;;;     disclaimer in the documentation and/or other materials
  14 ;;;;     provided with the distribution.
  15 ;;;;
  16 ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;;
  28 ;;;; errors.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defbinder error
  33   ("Error"
  34    ("Code" (bind :code))
  35    ("Message" (bind :message))
  36    (elements-alist :data)))
  37
  38 (defclass amazon-error (response)
  39   ((code
  40     :initarg :code
  41     :accessor code)
  42    (message
  43     :initarg :message
  44     :accessor message)
  45    (error-data
  46     :initarg :error-data
  47     :accessor error-data)))
  48
  49 (set-element-class "Error" 'amazon-error)
  50
  51 (defgeneric error-data-value (name instance)
  52   (:method (name (response amazon-error))
  53     (cdr (assoc name (error-data response) :test #'equalp))))
  54
  55 (defmethod specialized-initialize ((response amazon-error) source)
  56   (let ((bindings (xml-bind 'error source)))
  57     (setf (code response) (bvalue :code bindings))
  58     (setf (message response) (bvalue :message bindings))
  59     (setf (error-data response) (bvalue :data bindings))))
  60
  61 (defmethod print-object ((response amazon-error) stream)
  62   (print-unreadable-object (response stream :type t)
  63     (prin1 (code response) stream)))
  64
  65 ;;; Further specializing error messages/conditions
  66
  67 (defun report-request-error (condition stream)
  68   (format stream "~A: ~A"
  69           (code (request-error-response condition))
  70           (message (request-error-response condition))))
  71
  72 (define-condition request-error (error)
  73   ((request
  74     :initarg :request
  75     :reader request-error-request)
  76    (response
  77     :initarg :response
  78     :reader request-error-response)
  79    (data
  80     :initarg :data
  81     :reader request-error-data))
  82   (:report report-request-error))
  83
  84 (defparameter *specific-errors* (make-hash-table :test 'equalp))
  85
  86 (defun specific-error (amazon-code)
  87   (gethash amazon-code *specific-errors* 'request-error))
  88
  89 (defgeneric signal-specific-error (response condition-name)
  90   (:method (response (condition-name t))
  91     (error 'request-error
  92            :request (request response)
  93            :response response
  94            :data (error-data response))))
  95
  96 (defgeneric maybe-signal-error (response)
  97   (:method ((response t))
  98     t)
  99   (:method ((response amazon-error))
 100     (signal-specific-error response (specific-error (code response)))))
 101
 102 (eval-when (:compile-toplevel :load-toplevel :execute)
 103   (defun error-reader-name (suffix)
 104     (intern (concatenate 'string (symbol-name 'request-error)
 105                          "-"
 106                          (symbol-name suffix))
 107             :zs3)))
 108
 109 (defmacro define-specific-error ((condition-name code)
 110                                  superclasses
 111                                  slots &rest options)
 112   (labels ((slot-name (slot)
 113              (first slot))
 114            (slot-code (slot)
 115              (second slot))
 116            (slot-keyword (slot)
 117              (keywordify (slot-name slot)))
 118            (slot-definition (slot)
 119              `(,(slot-name slot)
 120                :initarg ,(slot-keyword slot)
 121                :reader ,(error-reader-name (slot-name slot))))
 122            (slot-initializer (slot)
 123              (list (slot-keyword slot)
 124                    `(error-data-value ,(slot-code slot) response))))
 125     `(progn
 126        (setf (gethash ,code *specific-errors*) ',condition-name)
 127        (define-condition ,condition-name (,@superclasses request-error)
 128          ,(mapcar #'slot-definition slots)
 129          ,@options)
 130        (defmethod signal-specific-error ((response amazon-error)
 131                                          (condition-name (eql ',condition-name)))
 132          (error ',condition-name
 133                 :request (request response)
 134                 :response response
 135                 :data (error-data response)
 136                 ,@(mapcan #'slot-initializer slots))))))
 137
 138
 139 ;;; The specific errors
 140
 141 (define-specific-error (internal-error "InternalError") () ())
 142
 143 (define-specific-error (slow-down "SlowDown") () ())
 144
 145 (define-specific-error (no-such-bucket "NoSuchBucket") ()
 146   ((bucket-name "BucketName")))
 147
 148 (define-specific-error (no-such-key "NoSuchKey") ()
 149   ((key-name "Key")))
 150
 151 (define-specific-error (access-denied "AccessDenied") () ())
 152
 153 (define-specific-error (malformed-xml "MalformedXML") () ())
 154
 155 (define-condition redirect-error (error) ())
 156
 157 (define-specific-error (permanent-redirect "PermanentRedirect") (redirect-error)
 158   ((endpoint "Endpoint")))
 159
 160 (define-specific-error (temporary-redirect "TemporaryRedirect") (redirect-error)
 161   ((endpoint "Endpoint")))
 162
 163 (define-specific-error (signature-mismatch "SignatureDoesNotMatch") ()
 164   ((string-to-sign "StringToSign")
 165    (canonical-request "CanonicalRequest"))
 166   (:report (lambda (condition stream)
 167              (report-request-error condition stream)
 168              (format stream "You signed: ~S~%Amazon signed: ~S~%and~%~S"
 169                             (signed-string (request-error-request condition))
 170                             (request-error-string-to-sign condition)
 171                             (request-error-canonical-request condition)))))
 172
 173 (define-specific-error (precondition-failed "PreconditionFailed") ()
 174   ((condition "Condition")))
 175
 176 (define-specific-error (authorization-header-malformed
 177                         "AuthorizationHeaderMalformed") ()
 178   ((region "Region")))
 179
 180
 181 (define-condition linked ()
 182   ((url
 183     :initarg :url
 184     :reader linked-url))
 185   (:report (lambda (condition stream)
 186              (report-request-error condition stream)
 187              (format stream "~&For more information, see:~%  ~A"
 188                             (linked-url condition)))))
 189
 190
 191 (define-condition bucket-restrictions (linked)
 192   ()
 193   (:default-initargs
 194    :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/BucketRestrictions.html"))
 195
 196 (define-specific-error (invalid-bucket-name "InvalidBucketName")
 197     (bucket-restrictions)
 198   ())
 199
 200 (define-specific-error (bucket-exists "BucketAlreadyExists")
 201     (bucket-restrictions)
 202   ())
 203
 204 (define-specific-error (too-many-buckets "TooManyBuckets")
 205     (bucket-restrictions)
 206   ())
 207
 208
 209 (define-specific-error (ambiguous-grant "AmbiguousGrantByEmailAddress") (linked)
 210   ()
 211   (:default-initargs
 212    :url "http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTacl.html"))
 213
 214 (define-specific-error (bucket-not-empty "BucketNotEmpty") (linked)
 215   ()
 216   (:default-initargs
 217    :url "http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketDELETE.html"))
 218
 219 (define-specific-error (invalid-logging-target "InvalidTargetBucketForLogging")
 220     () ())
 221
 222 (define-specific-error (key-too-long "KeyTooLong") (linked)
 223   ()
 224   (:default-initargs
 225    :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/UsingMetadata.html"))
 226
 227 (define-specific-error (request-time-skewed "RequestTimeTooSkewed") (linked)
 228   ()
 229   (:default-initargs
 230    :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#RESTAuthenticationTimeStamp"))
 231
 232 (define-specific-error (operation-aborted "OperationAborted") () ())