From 1324a8415ec2410dc98ab0f642248deeca4811ed Mon Sep 17 00:00:00 2001
From: Nick Levine <nlevine@ravenpack.com>
Date: Fri, 30 Sep 2016 11:59:49 +0200
Subject: [PATCH] Handle 5xx responses with empty bodies, and implement
 exponential backoff

---
 doc/index.html |  91 +++++++++++++++++++++++++++++++++++---
 errors.lisp    |  11 +++--
 interface.lisp | 118 ++++++++++++++++++++++++++++++++-----------------
 lifecycle.lisp |  23 ++++++----
 package.lisp   |   2 +
 response.lisp  |  26 +++++++++--
 6 files changed, 211 insertions(+), 60 deletions(-)

diff --git a/doc/index.html b/doc/index.html
index 1f375cf..82e8cf8 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -31,6 +31,7 @@ <h2>Contents</h2>
    <li> <a href='#dictionary'>The ZS3 Dictionary</a>
      <ul>
        <li> <a href='#credentials'>Credentials</a>
+       <li> <a href='#backoff'>Backoff</a>
        <li> <a href='#bucket-ops'>Operations on Buckets</a>
        <li> <a href='#querying-buckets'>Querying Buckets</a>
        <li> <a href='#object-ops'>Operations on Objects</a>
@@ -377,7 +378,50 @@ <h2>Contents</h2>
 
 
 
- <a name='bucket-ops'><h3>Operations on Buckets</h3></a>
+<a name='backoff'><h3>Backoff</h3></a>
+
+<p>
+    The response to some requests &mdash; a very small proportion
+    &mdash; will be an error internal to the AWS server. In these
+    circumstances an <cite>exponential backoff</cite>
+    policy is recommended.
+</p>
+
+<div class='item'>
+    <div class='type'><a name='*backoff*'>[Special variable]</a></div>
+    <div class='signature'>
+	<code class='name'>*backoff*</code>
+    </div>
+    
+    <blockquote class='description'>
+	<p>
+	Used as the default value of <code>:backoff</code> 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. 
+	</p>
+
+	<p>
+	The default value is <code>(3 . 100)</code>.
+	</p>
+
+	<p>
+	If a requst fails more times than permitted by
+	<code>*backoff*</code>, an error will be signalled:
+	</p>
+
+	<pre class="code">(ERROR #&lt;ZS3::INTERNAL-ERROR @ #x10008f1a8b2&gt;)</pre>
+
+	<p>
+	    It is the application's responsibility to handle this.</p>
+    </blockquote>
+</div>
+
+
+
+
+<a name='bucket-ops'><h3>Operations on Buckets</h3></a>
 
  <p>With ZS3, you can put, get, copy, and delete buckets. You can also
  get information about the bucket.
@@ -387,7 +431,7 @@ <h2>Contents</h2>
   <div class='signature'>
     <code class='name'>all-buckets</code>
     <span class='args'>
-      <code class='llkw'>&amp;key</code> <var>credentials</var>
+      <code class='llkw'>&amp;key</code> <var>credentials</var> <var>backoff</var>
     </span>
     <span class='result'>=> <var>bucket-vector</var></span>
   </div>
@@ -442,6 +486,7 @@ <h2>Contents</h2>
       <code class='llkw'>&amp;key</code>
       <var>prefix</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>key-vector</var></span>
   </div>
@@ -474,6 +519,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>boolean</var></span>
   </div>
@@ -495,6 +541,7 @@ <h2>Contents</h2>
       <var>public</var>
       <var>location</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -547,7 +594,9 @@ <h2>Contents</h2>
   <div class='signature'>
     <code class='name'>delete-bucket</code>
     <span class='args'>
-      <var>bucket</var> <code class='llkw'>&amp;key</code> <var>credentials</var>
+      <var>bucket</var> <code class='llkw'>&amp;key</code> 
+      <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -566,7 +615,9 @@ <h2>Contents</h2>
   <div class='signature'>
     <code class='name'>bucket-location</code>
     <span class='args'>
-      <var>bucket</var> <code class='llkw'>&amp;key</code> <var>credentials</var>
+      <var>bucket</var> <code class='llkw'>&amp;key</code>
+      <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>location</var></span>
   </div>
@@ -684,6 +735,7 @@ <h2>Contents</h2>
       <code class='llkw'>&amp;body</code>
       <var>days</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -719,6 +771,7 @@ <h2>Contents</h2>
       <var>key</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>status-string</var></span>
   </div>
@@ -753,6 +806,7 @@ <h2>Contents</h2>
       <var>max-keys</var>
       <var>delimiter</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>response</var></span>
   </div>
@@ -1094,6 +1148,7 @@ <h2>Contents</h2>
       <var>when-etag-matches</var> <var>unless-etag-matches</var> <br>
       <var>if-exists</var> <var>string-external-format</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>object</var></span>
   </div>
@@ -1164,6 +1219,7 @@ <h2>Contents</h2>
       <var>when-modified-since</var> <var>unless-modified-since</var>
       <var>when-etag-matches</var> <var>unless-etag-matches</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>vector</var></span>
   </div>
@@ -1192,6 +1248,7 @@ <h2>Contents</h2>
       <var>when-etag-matches</var>
       <var>unless-etag-matches</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>string</var></span>
   </div>
@@ -1221,6 +1278,7 @@ <h2>Contents</h2>
       <var>when-etag-matches</var>
       <var>unless-etag-matches</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>pathname</var></span>
   </div>
@@ -1256,6 +1314,7 @@ <h2>Contents</h2>
       <var>expires</var>
       <var>storage-class</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1337,6 +1396,7 @@ <h2>Contents</h2>
       <var>expires</var>
       <var>storage-class</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1373,6 +1433,7 @@ <h2>Contents</h2>
       <var>expires</var>
       <var>storage-class</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1406,6 +1467,7 @@ <h2>Contents</h2>
       <var>expires</var>
       <var>storage-class</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1447,6 +1509,7 @@ <h2>Contents</h2>
       <var>expires</var>
       <var>storage-class</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1495,6 +1558,7 @@ <h2>Contents</h2>
       <var>metadata</var> <var>public</var> <var>precondition-errors</var>
       <var>storage-class</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1544,6 +1608,7 @@ <h2>Contents</h2>
       <var>key</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1567,6 +1632,7 @@ <h2>Contents</h2>
       <var>keys</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>deleted-count</var>, <var>errors</var></span>
   </div>
@@ -1588,6 +1654,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>count</var></span>
   </div>
@@ -1608,6 +1675,7 @@ <h2>Contents</h2>
       <var>key</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>metadata-alist</var></span>
   </div>
@@ -1637,6 +1705,7 @@ <h2>Contents</h2>
       <var>storage-class</var> 
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1684,6 +1753,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <var>key</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>owner</var>, <var>grants</var></span>
   </div>
@@ -1705,6 +1775,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <var>key</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1856,6 +1927,7 @@ <h2>Contents</h2>
     <span class='args'>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>acl-person</var></span>
   </div>
@@ -1879,6 +1951,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <var>key</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1899,6 +1972,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <var>key</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1931,6 +2005,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1950,6 +2025,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1973,6 +2049,7 @@ <h2>Contents</h2>
       <code class='llkw'>&amp;key</code>
       <var>target-grants</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -1999,7 +2076,9 @@ <h2>Contents</h2>
   <div class='signature'>
     <code class='name'>disable-logging</code>
     <span class='args'>
-      <var>bucket</var> <code class='llkw'>&amp;key</code> <var>credentials</var>
+      <var>bucket</var> <code class='llkw'>&amp;key</code> 
+      <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> |</span>
   </div>
@@ -2018,6 +2097,7 @@ <h2>Contents</h2>
       <var>bucket</var>
       <code class='llkw'>&amp;key</code>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>target-bucket</var>,
       <var>target-prefix</var>,
@@ -2150,6 +2230,7 @@ <h2>Contents</h2>
       <var>key</var>
       <var>parameters</var>
       <var>credentials</var>
+      <var>backoff</var>
     </span>
     <span class='result'>=> <var>headers-alist</var>,
       <var>status-code</var>,
diff --git a/errors.lisp b/errors.lisp
index ba93808..5abfc1a 100644
--- a/errors.lisp
+++ b/errors.lisp
@@ -58,6 +58,11 @@
     (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)))
@@ -65,7 +70,7 @@
 ;;; Further specializing error messages/conditions
 
 (defun report-request-error (condition stream)
-  (format stream "~A: ~A"
+  (format stream "~A~@[: ~A~]"
           (code (request-error-response condition))
           (message (request-error-response condition))))
 
@@ -134,7 +139,7 @@
                 :response response
                 :data (error-data response)
                 ,@(mapcan #'slot-initializer slots))))))
-              
+
 
 ;;; The specific errors
 
@@ -186,7 +191,7 @@
              (report-request-error condition stream)
              (format stream "~&For more information, see:~%  ~A"
                             (linked-url condition)))))
-   
+
 
 (define-condition bucket-restrictions (linked)
   ()
diff --git a/interface.lisp b/interface.lisp
index 2660dba..8c55433 100644
--- a/interface.lisp
+++ b/interface.lisp
@@ -53,11 +53,12 @@
          (canned-access-policy access-policy))))
 
 (defun head (&key bucket key parameters
-             ((:credentials *credentials*) *credentials*))
+               ((: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*))
+  (let* ((security-token (security-token *credentials*))
          (response
           (submit-request (make-instance 'request
                                          :method :head
@@ -74,14 +75,16 @@ the object specified by the optional BUCKET and KEY arguments."
 
 ;;; Operations on buckets
 
-(defun all-buckets (&key ((:credentials *credentials*) *credentials*))
+(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*))
+                                 ((:credentials *credentials*) *credentials*)
+                                 ((:backoff *backoff*) *backoff*))
   "If BUCKET was created with a LocationConstraint, return its
 constraint."
   (let* ((request (make-instance 'request
@@ -94,7 +97,8 @@ constraint."
       location)))
 
 (defun bucket-region (bucket
-                      &key ((:credentials *credentials*) *credentials*))
+                      &key ((:credentials *credentials*) *credentials*)
+                        ((:backoff *backoff*) *backoff*))
   (or (bucket-location bucket)
       "us-east-1"))
 
@@ -104,7 +108,8 @@ constraint."
       (format nil "s3-~A.amazonaws.com" region)))
 
 (defun query-bucket (bucket &key prefix marker max-keys delimiter
-                     ((:credentials *credentials*) *credentials*))
+                              ((:credentials *credentials*) *credentials*)
+                              ((:backoff *backoff*) *backoff*))
   (submit-request (make-instance 'request
                                  :method :get
                                  :bucket bucket
@@ -122,7 +127,8 @@ constraint."
         (submit-request request)))))
 
 (defun all-keys (bucket &key prefix
-                 ((:credentials *credentials*) *credentials*))
+                          ((:credentials *credentials*) *credentials*)
+                          ((:backoff *backoff*) *backoff*))
   "Reutrn a vector of all KEY objects in BUCKET."
   (let ((response (query-bucket bucket :prefix prefix))
         (results '()))
@@ -138,7 +144,8 @@ constraint."
         (incf start (length keys))))))
 
 (defun bucket-exists-p (bucket &key
-                        ((:credentials *credentials*) *credentials*))
+                                 ((:credentials *credentials*) *credentials*)
+                                 ((:backoff *backoff*) *backoff*))
   (let ((code (nth-value 1 (head :bucket bucket
                                  :parameters
                                  (parameters-alist :max-keys 0)))))
@@ -148,7 +155,8 @@ constraint."
                       access-policy
                       public
                       location
-                      ((:credentials *credentials*) *credentials*))
+                             ((:credentials *credentials*) *credentials*)
+                             ((:backoff *backoff*) *backoff*))
   (let ((policy-header (access-policy-header access-policy public)))
     (submit-request (make-instance 'request
                                    :method :put
@@ -159,7 +167,8 @@ constraint."
                                    :amz-headers policy-header))))
 
 (defun delete-bucket (bucket &key
-                      ((:credentials *credentials*) *credentials*))
+                               ((:credentials *credentials*) *credentials*)
+                               ((:backoff *backoff*) *backoff*))
   (let* ((request (make-instance 'request
                                  :method :delete
                                  :bucket bucket))
@@ -223,7 +232,8 @@ constraint."
                                 (output :vector)
                                 (if-exists :supersede)
                                 (string-external-format :utf-8)
-                                ((:credentials *credentials*) *credentials*))
+                                ((:credentials *credentials*) *credentials*)
+                                ((:backoff *backoff*) *backoff*))
   (flet ((range-argument (start end)
            (when start
              (format nil "bytes=~D-~@[~D~]" start (and end (1- end)))))
@@ -286,7 +296,8 @@ constraint."
                    when-modified-since unless-modified-since
                    when-etag-matches unless-etag-matches
                    (if-exists :supersede)
-                   ((:credentials *credentials*) *credentials*))
+                     ((:credentials *credentials*) *credentials*)
+                     ((:backoff *backoff*) *backoff*))
   (get-object bucket key
               :output :vector
               :start start
@@ -303,7 +314,8 @@ constraint."
                    when-modified-since unless-modified-since
                    when-etag-matches unless-etag-matches
                    (if-exists :supersede)
-                   ((:credentials *credentials*) *credentials*))
+                     ((:credentials *credentials*) *credentials*)
+                     ((:backoff *backoff*) *backoff*))
   (get-object bucket key
               :output :string
               :string-external-format external-format
@@ -320,7 +332,8 @@ constraint."
                  when-modified-since unless-modified-since
                  when-etag-matches unless-etag-matches
                  (if-exists :supersede)
-                 ((:credentials *credentials*) *credentials*))
+                   ((:credentials *credentials*) *credentials*)
+                   ((:backoff *backoff*) *backoff*))
   (get-object bucket key
               :output (pathname file)
               :start start
@@ -346,7 +359,8 @@ constraint."
                                        expires
                                        content-type
                                        (storage-class "STANDARD")
-                                       ((:credentials *credentials*) *credentials*))
+                                       ((:credentials *credentials*) *credentials*)
+                                       ((:backoff *backoff*) *backoff*))
   (let ((content
          (etypecase object
            (string
@@ -390,7 +404,8 @@ constraint."
                    (content-type "binary/octet-stream")
                    expires
                    storage-class
-                   ((:credentials *credentials*) *credentials*))
+                   ((:credentials *credentials*) *credentials*)
+                   ((:backoff *backoff*) *backoff*))
   (when (or start end)
     (setf vector (subseq vector (or start 0) end)))
   (put-object vector bucket key
@@ -416,7 +431,8 @@ constraint."
                    (content-type "text/plain")
                    expires
                    storage-class
-                   ((:credentials *credentials*) *credentials*))
+                   ((:credentials *credentials*) *credentials*)
+                   ((:backoff *backoff*) *backoff*))
   (when (or start end)
     (setf string (subseq string (or start 0) end)))
   (put-object string bucket key
@@ -443,7 +459,8 @@ constraint."
                  (content-type "binary/octet-stream")
                  expires
                  storage-class
-                 ((:credentials *credentials*) *credentials*))
+                 ((:credentials *credentials*) *credentials*)
+                 ((:backoff *backoff*) *backoff*))
   (when (eq key t)
     (setf key (file-namestring file)))
   (let ((content (pathname file)))
@@ -472,7 +489,8 @@ constraint."
                    (content-type "binary/octet-stream")
                    expires
                    storage-class
-                   ((:credentials *credentials*) *credentials*))
+                   ((:credentials *credentials*) *credentials*)
+                   ((:backoff *backoff*) *backoff*))
   (let ((content (stream-subset-vector stream start end)))
     (put-object content bucket key
                 :access-policy access-policy
@@ -489,7 +507,8 @@ constraint."
 ;;; Delete & copy objects
 
 (defun delete-object (bucket key &key
-                        ((:credentials *credentials*) *credentials*))
+                                   ((: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
@@ -523,8 +542,10 @@ constraint."
                ("Code" (bind :error-code))
                ("Message" (bind :error-message)))))))
 
-(defun delete-objects (bucket keys &key
-                       ((:credentials *credentials*) *credentials*))
+(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 '())
@@ -560,7 +581,8 @@ constraint."
       (values deleted failed))))
 
 (defun delete-all-objects (bucket &key
-                           ((:credentials *credentials*) *credentials*))
+                                    ((: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.
@@ -578,7 +600,8 @@ constraint."
                     public
                     precondition-errors
                     (storage-class "STANDARD")
-                    ((:credentials *credentials*) *credentials*))
+                      ((:credentials *credentials*) *credentials*)
+                      ((:backoff *backoff*) *backoff*))
   "Copy the object identified by FROM-BUCKET/FROM-KEY to
 TO-BUCKET/TO-KEY.
 
@@ -635,8 +658,10 @@ users. Otherwise, a default ACL is present on the new object.
                                      (nconc headers policy-header))))))
 
 
-(defun object-metadata (bucket key &key
-                        ((:credentials *credentials*) *credentials*))
+(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)))
@@ -654,8 +679,10 @@ users. Otherwise, a default ACL is present on the new object.
 
 ;;; Convenience bit for storage class
 
-(defun set-storage-class (bucket key storage-class &key
-                          ((:credentials *credentials*) *credentials*))
+(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
@@ -672,7 +699,8 @@ STORAGE-CLASS."
   read access for all users.")
 
 (defun get-acl (&key bucket key
-                ((:credentials *credentials*) *credentials*))
+                  ((:credentials *credentials*) *credentials*)
+                  ((:backoff *backoff*) *backoff*))
   (let* ((request (make-instance 'request
                                  :method :get
                                  :bucket bucket
@@ -684,7 +712,8 @@ STORAGE-CLASS."
             (grants acl))))
 
 (defun put-acl (owner grants &key bucket key
-                ((:credentials *credentials*) *credentials*))
+                               ((:credentials *credentials*) *credentials*)
+                               ((:backoff *backoff*) *backoff*))
   (let* ((acl (make-instance 'access-control-list
                              :owner owner
                              :grants grants))
@@ -698,7 +727,8 @@ STORAGE-CLASS."
 
 
 (defun make-public (&key bucket key
-                    ((:credentials *credentials*) *credentials*))
+                      ((:credentials *credentials*) *credentials*)
+                      ((:backoff *backoff*) *backoff*))
   (multiple-value-bind (owner grants)
       (get-acl :bucket bucket :key key)
     (put-acl owner
@@ -707,7 +737,8 @@ STORAGE-CLASS."
              :key key)))
 
 (defun make-private (&key bucket key
-                     ((:credentials *credentials*) *credentials*))
+                       ((:credentials *credentials*) *credentials*)
+                       ((:backoff *backoff*) *backoff*))
   (multiple-value-bind (owner grants)
       (get-acl :bucket bucket :key key)
     (setf grants
@@ -729,7 +760,8 @@ STORAGE-CLASS."
 to write logfile objects into a particular bucket.")
 
 (defun enable-logging-to (bucket &key
-                          ((:credentials *credentials*) *credentials*))
+                                   ((:credentials *credentials*) *credentials*)
+                                   ((:backoff *backoff*) *backoff*))
   "Configure the ACL of BUCKET to accept logfile objects."
   (multiple-value-bind (owner grants)
       (get-acl :bucket bucket)
@@ -737,7 +769,8 @@ to write logfile objects into a particular bucket.")
     (put-acl owner grants :bucket bucket)))
 
 (defun disable-logging-to (bucket &key
-                           ((:credentials *credentials*) *credentials*))
+                                    ((:credentials *credentials*) *credentials*)
+                                    ((:backoff *backoff*) *backoff*))
   "Configure the ACL of BUCKET to remove permissions for the log
 delivery group."
   (multiple-value-bind (owner grants)
@@ -747,9 +780,11 @@ delivery group."
                             grants))
     (put-acl owner grants :bucket bucket)))
 
-(defun enable-logging (bucket target-bucket target-prefix &key
+(defun enable-logging (bucket target-bucket target-prefix
+                       &key
                        target-grants
-                       ((:credentials *credentials*) *credentials*))
+                         ((: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
@@ -779,7 +814,8 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX."
   bucket effectively disables logging.")
 
 (defun disable-logging (bucket &key
-                        ((:credentials *credentials*) *credentials*))
+                                 ((:credentials *credentials*) *credentials*)
+                                 ((:backoff *backoff*) *backoff*))
   "Disable the creation of access logs for BUCKET."
   (submit-request (make-instance 'request
                                  :method :put
@@ -788,7 +824,8 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX."
                                  :content *empty-logging-setup*)))
 
 (defun logging-setup (bucket &key
-                      ((:credentials *credentials*) *credentials*))
+                               ((:credentials *credentials*) *credentials*)
+                               ((:backoff *backoff*) *backoff*))
   (let ((setup (setup
                 (submit-request (make-instance 'request
                                                :bucket bucket
@@ -892,7 +929,8 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX."
   key strings.")
 
 (defun me (&key
-           ((:credentials *credentials*) *credentials*))
+             ((:credentials *credentials*) *credentials*)
+             ((:backoff *backoff*) *backoff*))
   "Return a PERSON object corresponding to the current credentials. Cached."
   (or (gethash (access-key *credentials*) *me-cache*)
       (setf
@@ -901,7 +939,7 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX."
          (owner response)))))
 
 (defun make-post-policy (&key expires conditions
-                         ((:credentials *credentials*) *credentials*))
+                           ((:credentials *credentials*) *credentials*))
   "Return an encoded HTTP POST policy string and policy signature as
 multiple values."
   (unless expires
diff --git a/lifecycle.lisp b/lifecycle.lisp
index b4a49d8..8abb7ad 100644
--- a/lifecycle.lisp
+++ b/lifecycle.lisp
@@ -184,7 +184,8 @@ by xml-binding the LIFECYCLE-CONFIGURATION binder with a document."
     () ())
 
 (defun bucket-lifecycle (bucket
-                         &key ((:credentials *credentials*) *credentials*))
+                         &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."
@@ -198,7 +199,8 @@ configuration."
 
 (defun delete-bucket-lifecycle (bucket
                                 &key
-                                ((:credentials *credentials*) *credentials*))
+                                  ((:credentials *credentials*) *credentials*)
+                                  ((:backoff *backoff*) *backoff*))
   "Delete the lifecycle configuration of BUCKET."
   (submit-request (make-instance 'request
                                  :method :delete
@@ -207,7 +209,8 @@ configuration."
 
 (defun (setf bucket-lifecycle) (rules bucket
                                 &key
-                                ((:credentials *credentials*) *credentials*))
+                                  ((: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."
@@ -233,9 +236,11 @@ configuration is deleted with DELETE-BUCKET-LIFECYCLE."
       (with-element "Days"
         (text (princ-to-string days))))))
 
-(defun restore-object (bucket key &key
-                       days
-                       ((:credentials *credentials*) *credentials*))
+(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
@@ -246,8 +251,10 @@ configuration is deleted with DELETE-BUCKET-LIFECYCLE."
                                    :key key
                                    :content content))))
 
-(defun object-restoration-status (bucket key &key
-                                  ((:credentials *credentials*) *credentials*))
+(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))))
 
diff --git a/package.lisp b/package.lisp
index 4252048..444b701 100644
--- a/package.lisp
+++ b/package.lisp
@@ -35,6 +35,8 @@
            #:access-key
            #:secret-key
            #:file-credentials)
+  ;; Backoff
+  (:export #:*backoff*)
   ;; Buckets
   (:export #:all-buckets
            #:creation-date
diff --git a/response.lisp b/response.lisp
index 5821fc6..ec84b98 100644
--- a/response.lisp
+++ b/response.lisp
@@ -85,6 +85,9 @@
     (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)))
@@ -133,6 +136,12 @@
             (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*)
@@ -140,7 +149,10 @@
   ;; 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)))
+  (let* ((original-endpoint (endpoint request))
+         (backoff *backoff*)
+         (tries (car backoff))
+         (delay (/ (cdr backoff) 1000)))
     (loop
       (handler-case
           (let ((response (request-response request
@@ -170,9 +182,15 @@
             (setf (endpoint request) new-endpoint)
             (when new-region
               (setf (region request) new-region))))
-        (internal-error ()
-          ;; Per the S3 docs, InternalErrors should simply be retried
-          (close-keep-alive))
+        (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.