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 specialized-initialize ((response amazon-error) (source null))
  62   (setf (code response) "InternalError"
  63         (message response) nil
  64         (error-data response) nil))
  65
  66 (defmethod print-object ((response amazon-error) stream)
  67   (print-unreadable-object (response stream :type t)
  68     (prin1 (code response) stream)))
  69
  70 ;;; Further specializing error messages/conditions
  71
  72 (defun report-request-error (condition stream)
  73   (format stream "~A~@[: ~A~]"
  74           (code (request-error-response condition))
  75           (message (request-error-response condition))))
  76
  77 (define-condition request-error (error)
  78   ((request
  79     :initarg :request
  80     :reader request-error-request)
  81    (response
  82     :initarg :response
  83     :reader request-error-response)
  84    (data
  85     :initarg :data
  86     :reader request-error-data))
  87   (:report report-request-error))
  88
  89 (defparameter *specific-errors* (make-hash-table :test 'equalp))
  90
  91 (defun specific-error (amazon-code)
  92   (gethash amazon-code *specific-errors* 'request-error))
  93
  94 (defgeneric signal-specific-error (response condition-name)
  95   (:method (response (condition-name t))
  96     (error 'request-error
  97            :request (request response)
  98            :response response
  99            :data (error-data response))))
 100
 101 (defgeneric maybe-signal-error (response)
 102   (:method ((response t))
 103     t)
 104   (:method ((response amazon-error))
 105     (signal-specific-error response (specific-error (code response)))))
 106
 107 (eval-when (:compile-toplevel :load-toplevel :execute)
 108   (defun error-reader-name (suffix)
 109     (intern (concatenate 'string (symbol-name 'request-error)
 110                          "-"
 111                          (symbol-name suffix))
 112             :zs3)))
 113
 114 (defmacro define-specific-error ((condition-name code)
 115                                  superclasses
 116                                  slots &rest options)
 117   (labels ((slot-name (slot)
 118              (first slot))
 119            (slot-code (slot)
 120              (second slot))
 121            (slot-keyword (slot)
 122              (keywordify (slot-name slot)))
 123            (slot-definition (slot)
 124              `(,(slot-name slot)
 125                :initarg ,(slot-keyword slot)
 126                :reader ,(error-reader-name (slot-name slot))))
 127            (slot-initializer (slot)
 128              (list (slot-keyword slot)
 129                    `(error-data-value ,(slot-code slot) response))))
 130     `(progn
 131        (setf (gethash ,code *specific-errors*) ',condition-name)
 132        (define-condition ,condition-name (,@superclasses request-error)
 133          ,(mapcar #'slot-definition slots)
 134          ,@options)
 135        (defmethod signal-specific-error ((response amazon-error)
 136                                          (condition-name (eql ',condition-name)))
 137          (error ',condition-name
 138                 :request (request response)
 139                 :response response
 140                 :data (error-data response)
 141                 ,@(mapcan #'slot-initializer slots))))))
 142
 143
 144 ;;; The specific errors
 145
 146 (define-specific-error (internal-error "InternalError") () ())
 147
 148 (define-specific-error (slow-down "SlowDown") () ())
 149
 150 (define-specific-error (no-such-bucket "NoSuchBucket") ()
 151   ((bucket-name "BucketName")))
 152
 153 (define-specific-error (no-such-key "NoSuchKey") ()
 154   ((key-name "Key")))
 155
 156 (define-specific-error (access-denied "AccessDenied") () ())
 157
 158 (define-specific-error (malformed-xml "MalformedXML") () ())
 159
 160 (define-condition redirect-error (error) ())
 161
 162 (define-specific-error (permanent-redirect "PermanentRedirect") (redirect-error)
 163   ((endpoint "Endpoint")))
 164
 165 (define-specific-error (temporary-redirect "TemporaryRedirect") (redirect-error)
 166   ((endpoint "Endpoint")))
 167
 168 (define-specific-error (signature-mismatch "SignatureDoesNotMatch") ()
 169   ((string-to-sign "StringToSign")
 170    (canonical-request "CanonicalRequest"))
 171   (:report (lambda (condition stream)
 172              (report-request-error condition stream)
 173              (format stream "You signed: ~S~%Amazon signed: ~S~%and~%~S"
 174                             (signed-string (request-error-request condition))
 175                             (request-error-string-to-sign condition)
 176                             (request-error-canonical-request condition)))))
 177
 178 (define-specific-error (precondition-failed "PreconditionFailed") ()
 179   ((condition "Condition")))
 180
 181 (define-specific-error (authorization-header-malformed
 182                         "AuthorizationHeaderMalformed") ()
 183   ((region "Region")))
 184
 185
 186 (define-condition linked ()
 187   ((url
 188     :initarg :url
 189     :reader linked-url))
 190   (:report (lambda (condition stream)
 191              (report-request-error condition stream)
 192              (format stream "~&For more information, see:~%  ~A"
 193                             (linked-url condition)))))
 194
 195
 196 (define-condition bucket-restrictions (linked)
 197   ()
 198   (:default-initargs
 199    :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/BucketRestrictions.html"))
 200
 201 (define-specific-error (invalid-bucket-name "InvalidBucketName")
 202     (bucket-restrictions)
 203   ())
 204
 205 (define-specific-error (bucket-exists "BucketAlreadyExists")
 206     (bucket-restrictions)
 207   ())
 208
 209 (define-specific-error (too-many-buckets "TooManyBuckets")
 210     (bucket-restrictions)
 211   ())
 212
 213
 214 (define-specific-error (ambiguous-grant "AmbiguousGrantByEmailAddress") (linked)
 215   ()
 216   (:default-initargs
 217    :url "http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTacl.html"))
 218
 219 (define-specific-error (bucket-not-empty "BucketNotEmpty") (linked)
 220   ()
 221   (:default-initargs
 222    :url "http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketDELETE.html"))
 223
 224 (define-specific-error (invalid-logging-target "InvalidTargetBucketForLogging")
 225     () ())
 226
 227 (define-specific-error (key-too-long "KeyTooLong") (linked)
 228   ()
 229   (:default-initargs
 230    :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/UsingMetadata.html"))
 231
 232 (define-specific-error (request-time-skewed "RequestTimeTooSkewed") (linked)
 233   ()
 234   (:default-initargs
 235    :url "http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#RESTAuthenticationTimeStamp"))
 236
 237 (define-specific-error (operation-aborted "OperationAborted") () ())