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