From 64949b160d9d99d63c28322736aafee067a766c5 Mon Sep 17 00:00:00 2001 From: Nick Levine Date: Fri, 30 Sep 2016 10:22:51 +0200 Subject: [PATCH 1/5] zs3:head needs to pass amz security headers --- interface.lisp | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/interface.lisp b/interface.lisp index a04131d..2660dba 100644 --- a/interface.lisp +++ b/interface.lisp @@ -57,12 +57,16 @@ "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 ((response - (submit-request (make-instance 'request - :method :head - :bucket bucket - :key key - :parameters parameters)))) + (let* ((security-token (security-token *credentials*)) + (response + (submit-request (make-instance 'request + :method :head + :bucket bucket + :key key + :amz-headers + (when security-token + (list (cons "security-token" security-token))) + :parameters parameters)))) (values (http-headers response) (http-code response) From 1324a8415ec2410dc98ab0f642248deeca4811ed Mon Sep 17 00:00:00 2001 From: Nick Levine Date: Fri, 30 Sep 2016 11:59:49 +0200 Subject: [PATCH 2/5] 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 @@

Contents

  • The ZS3 Dictionary
    • Credentials +
    • Backoff
    • Operations on Buckets
    • Querying Buckets
    • Operations on Objects @@ -377,7 +378,50 @@

      Contents

      -

      Operations on Buckets

       +

      Backoff

       + +

      + The response to some requests — a very small proportion + — will be an error internal to the AWS server. In these + circumstances an exponential backoff + policy is recommended. +

      + +
      +
      [Special variable]
      +
      + *backoff* +
      + +
      +

      + 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. +

      + +

      + The default value is (3 . 100). +

      + +

      + If a requst fails more times than permitted by + *backoff*, an error will be signalled: +

      + + 
      (ERROR #<ZS3::INTERNAL-ERROR @ #x10008f1a8b2>)
      + +

      + It is the application's responsibility to handle this.

      +
      +
      + + + + +

      Operations on Buckets

      With ZS3, you can put, get, copy, and delete buckets. You can also get information about the bucket. @@ -387,7 +431,7 @@

      Contents

      all-buckets - &key credentials + &key credentials backoff => bucket-vector
      @@ -442,6 +486,7 @@

      Contents

      &key prefix credentials + backoff => key-vector @@ -474,6 +519,7 @@

      Contents

      bucket &key credentials + backoff => boolean @@ -495,6 +541,7 @@

      Contents

      public location credentials + backoff => | @@ -547,7 +594,9 @@

      Contents

      delete-bucket - bucket &key credentials + bucket &key + credentials + backoff => |
      @@ -566,7 +615,9 @@

      Contents

      bucket-location - bucket &key credentials + bucket &key + credentials + backoff => location
      @@ -684,6 +735,7 @@

      Contents

      &body days credentials + backoff => | @@ -719,6 +771,7 @@

      Contents

      key &key credentials + backoff => status-string @@ -753,6 +806,7 @@

      Contents

      max-keys delimiter credentials + backoff => response @@ -1094,6 +1148,7 @@

      Contents

      when-etag-matches unless-etag-matches
      if-exists string-external-format credentials + backoff => object @@ -1164,6 +1219,7 @@

      Contents

      when-modified-since unless-modified-since when-etag-matches unless-etag-matches credentials + backoff => vector @@ -1192,6 +1248,7 @@

      Contents

      when-etag-matches unless-etag-matches credentials + backoff => string @@ -1221,6 +1278,7 @@

      Contents

      when-etag-matches unless-etag-matches credentials + backoff => pathname @@ -1256,6 +1314,7 @@

      Contents

      expires storage-class credentials + backoff => | @@ -1337,6 +1396,7 @@

      Contents

      expires storage-class credentials + backoff => | @@ -1373,6 +1433,7 @@

      Contents

      expires storage-class credentials + backoff => | @@ -1406,6 +1467,7 @@

      Contents

      expires storage-class credentials + backoff => | @@ -1447,6 +1509,7 @@

      Contents

      expires storage-class credentials + backoff => | @@ -1495,6 +1558,7 @@

      Contents

      metadata public precondition-errors storage-class credentials + backoff => | @@ -1544,6 +1608,7 @@

      Contents

      key &key credentials + backoff => | @@ -1567,6 +1632,7 @@

      Contents

      keys &key credentials + backoff => deleted-count, errors @@ -1588,6 +1654,7 @@

      Contents

      bucket &key credentials + backoff => count @@ -1608,6 +1675,7 @@

      Contents

      key &key credentials + backoff => metadata-alist @@ -1637,6 +1705,7 @@

      Contents

      storage-class &key credentials + backoff => | @@ -1684,6 +1753,7 @@

      Contents

      bucket key credentials + backoff => owner, grants @@ -1705,6 +1775,7 @@

      Contents

      bucket key credentials + backoff => | @@ -1856,6 +1927,7 @@

      Contents

      &key credentials + backoff => acl-person @@ -1879,6 +1951,7 @@

      Contents

      bucket key credentials + backoff => | @@ -1899,6 +1972,7 @@

      Contents

      bucket key credentials + backoff => | @@ -1931,6 +2005,7 @@

      Contents

      bucket &key credentials + backoff => | @@ -1950,6 +2025,7 @@

      Contents

      bucket &key credentials + backoff => | @@ -1973,6 +2049,7 @@

      Contents

      &key target-grants credentials + backoff => | @@ -1999,7 +2076,9 @@

      Contents

      disable-logging - bucket &key credentials + bucket &key + credentials + backoff => |
      @@ -2018,6 +2097,7 @@

      Contents

      bucket &key credentials + backoff => target-bucket, target-prefix, @@ -2150,6 +2230,7 @@

      Contents

      key parameters credentials + backoff       => headers-alist, status-code, 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. From a0fdadad2174fe1a162cd5ee772f270579a37089 Mon Sep 17 00:00:00 2001 From: Nick Levine Date: Fri, 30 Sep 2016 12:56:42 +0200 Subject: [PATCH 3/5] export and document readers for interrogating response objects. --- doc/index.html | 135 +++++++++++++++++++++++++++++++++++++++---------- lifecycle.lisp | 14 ++--- package.lisp | 8 ++- 3 files changed, 123 insertions(+), 34 deletions(-) diff --git a/doc/index.html b/doc/index.html index 82e8cf8..0fa12c2 100644 --- a/doc/index.html +++ b/doc/index.html @@ -31,7 +31,7 @@

      Contents

    • The ZS3 Dictionary
      • Credentials -
      • Backoff +
      • Responses
      • Operations on Buckets
      • Querying Buckets
      • Operations on Objects @@ -378,7 +378,13 @@

        Contents

        -

        Backoff

         +

        Responses

         + +

        + Some operations return a response as an additional value. All + response objects can be interrogated to obtain the HTTP code, + headers and phrase. +

        The response to some requests — a very small proportion @@ -408,17 +414,94 @@

        Contents

        If a requst fails more times than permitted by - *backoff*, an error will be signalled: -

        + *backoff*, an error will be signalled. It is the + application's responsibility to handle this error.

        + +
        +* e
+#<ZS3::INTERNAL-ERROR @ #x1000296bc92>
+* (setf r (zs3:request-error-response e))
+#<ZS3::AMAZON-ERROR "InternalError">
+* (zs3:http-code r)
+500
+* (zs3:http-headers r)
+((:X-AMZ-REQUEST-ID . "3E20E3BAC24AB9AA")
+ (:X-AMZ-ID-2 . "80sxu4PDKtx1BWLOcSrUVWD90mMMVaMx6y9c+sz5VBGa2eAES2YlNaefn5kqRsfvrbaF+7QGNXA=")
+ (:CONTENT-TYPE . "application/xml")
+ (:TRANSFER-ENCODING . "chunked")
+ (:DATE . "Fri, 30 Sep 2016 10:10:11 GMT")
+ (:CONNECTION . "close")
+ (:SERVER . "AmazonS3"))
+* (zs3:http-phrase r)
+"Internal Server Error"
+*
        + + + - 
        (ERROR #<ZS3::INTERNAL-ERROR @ #x10008f1a8b2>)
        -

        - It is the application's responsibility to handle this.

        +
        +
        [Function]
        +
        + request-error-response + + request-error + + => response +
        + +
        +

        Returns the response object associated with a request-error. +

        +
        + + +
        +
        [Function]
        +
        + http-code + + response + + => code +
        + +
        +

        Returns the HTTP code associated with a response object.

        +
        +
        [Function]
        +
        + http-headers + + response + + => headers +
        + +
        +

        Returns the HTTP headers associated with a response object. +

        +
        + + +
        +
        [Function]
        +
        + http-phrase + + response + + => phrase +
        + +
        +

        Returns the HTTP phrase associated with a response object. +

        +

        Operations on Buckets

         @@ -543,7 +626,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -598,7 +681,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -658,7 +741,7 @@

        Contents

        rules bucket - => | + => rules, response
        @@ -737,7 +820,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1316,7 +1399,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1398,7 +1481,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1435,7 +1518,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1469,7 +1552,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1511,7 +1594,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1560,7 +1643,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1610,7 +1693,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1707,7 +1790,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1777,7 +1860,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1953,7 +2036,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -1974,7 +2057,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -2007,7 +2090,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -2027,7 +2110,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -2051,7 +2134,7 @@

        Contents

        credentials backoff - => | + => response
        @@ -2080,7 +2163,7 @@

        Contents

        credentials backoff - => | + => response
        diff --git a/lifecycle.lisp b/lifecycle.lisp index 8abb7ad..5588add 100644 --- a/lifecycle.lisp +++ b/lifecycle.lisp @@ -221,12 +221,14 @@ configuration is deleted with DELETE-BUCKET-LIFECYCLE." (setf rules (list rules))) (let* ((content (lifecycle-document rules)) (md5 (vector-md5/b64 content))) - (submit-request (make-instance 'request - :method :put - :bucket bucket - :sub-resource "lifecycle" - :content-md5 md5 - :content content)))) + (values + rules + (submit-request (make-instance 'request + :method :put + :bucket bucket + :sub-resource "lifecycle" + :content-md5 md5 + :content content))))) ;;; Restoring from glacier diff --git a/package.lisp b/package.lisp index 444b701..a78dcb1 100644 --- a/package.lisp +++ b/package.lisp @@ -35,8 +35,12 @@ #:access-key #:secret-key #:file-credentials) - ;; Backoff - (:export #:*backoff*) + ;; Responses + (:export #:*backoff* + #:request-error-response + #:http-code + #:http-headers + #:http-phrase) ;; Buckets (:export #:all-buckets #:creation-date From 66807fcc1d5402f5c6dc305f95ee0163f8b2c9fb Mon Sep 17 00:00:00 2001 From: Nick Levine Date: Fri, 30 Sep 2016 14:49:56 +0200 Subject: [PATCH 4/5] (minor) doc cleanup --- doc/index.html | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/index.html b/doc/index.html index 0fa12c2..dc186ce 100644 --- a/doc/index.html +++ b/doc/index.html @@ -133,6 +133,9 @@

        Contents

        * (create-bucket "zs3-demo") => #<RESPONSE 200 "OK" {10040D3281}> + * (http-code *) + => 200 + * (put-vector (octet-vector 8 6 7 5 3 0 9 ) "zs3-demo" "jenny") => #<RESPONSE 200 "OK" {10033EC2E1}> From f3576f3e61651cc610deb05bfa845a3b0fb8db63 Mon Sep 17 00:00:00 2001 From: Nick Levine Date: Thu, 13 Oct 2016 11:13:08 +0200 Subject: [PATCH 5/5] doc cleanups --- doc/index.html | 50 ++++++++++++++++++++++++++------------------------ package.lisp | 3 ++- 2 files changed, 28 insertions(+), 25 deletions(-) diff --git a/doc/index.html b/doc/index.html index dc186ce..4e48ee7 100644 --- a/doc/index.html +++ b/doc/index.html @@ -390,12 +390,34 @@

        Contents

        - The response to some requests — a very small proportion - — will be an error internal to the AWS server. In these - circumstances an exponential backoff - policy is recommended. + The outcome of some requests — a very small proportion + — will be an error internal to the AWS server. In these + circumstances an exponential backoff policy operates; if this + encounters too many failures then ZS3 signals an internal-error + which can be interrogated to obtain the response object, and + through that the HTTP response code and headers:

        + +
        +* e
+#<ZS3:INTERNAL-ERROR @ #x1000296bc92>
+* (setf r (zs3:request-error-response e))
+#<ZS3::AMAZON-ERROR "InternalError">
+* (zs3:http-code r)
+500
+* (zs3:http-headers r)
+((:X-AMZ-REQUEST-ID . "3E20E3BAC24AB9AA")
+ (:X-AMZ-ID-2 . "80sxu4PDKtx1BWLOcSrUVWD90mMMVaMx6y9c+sz5VBGa2eAES2YlNaefn5kqRsfvrbaF+7QGNXA=")
+ (:CONTENT-TYPE . "application/xml")
+ (:TRANSFER-ENCODING . "chunked")
+ (:DATE . "Fri, 30 Sep 2016 10:10:11 GMT")
+ (:CONNECTION . "close")
+ (:SERVER . "AmazonS3"))
+* (zs3:http-phrase r)
+"Internal Server Error"
+*
        +
        [Special variable]
        @@ -419,26 +441,6 @@

        Contents

        If a requst fails more times than permitted by *backoff*, an error will be signalled. It is the application's responsibility to handle this error.

        - -
        -* e
-#<ZS3::INTERNAL-ERROR @ #x1000296bc92>
-* (setf r (zs3:request-error-response e))
-#<ZS3::AMAZON-ERROR "InternalError">
-* (zs3:http-code r)
-500
-* (zs3:http-headers r)
-((:X-AMZ-REQUEST-ID . "3E20E3BAC24AB9AA")
- (:X-AMZ-ID-2 . "80sxu4PDKtx1BWLOcSrUVWD90mMMVaMx6y9c+sz5VBGa2eAES2YlNaefn5kqRsfvrbaF+7QGNXA=")
- (:CONTENT-TYPE . "application/xml")
- (:TRANSFER-ENCODING . "chunked")
- (:DATE . "Fri, 30 Sep 2016 10:10:11 GMT")
- (:CONNECTION . "close")
- (:SERVER . "AmazonS3"))
-* (zs3:http-phrase r)
-"Internal Server Error"
-*
        -
        diff --git a/package.lisp b/package.lisp index a78dcb1..c76255d 100644 --- a/package.lisp +++ b/package.lisp @@ -141,7 +141,8 @@ #:request-time-skewed #:operation-aborted #:no-such-lifecycle-configuration - #:restore-already-in-progress) + #:restore-already-in-progress + #:internal-error) ;; Cloudfront distribution management (:export #:status #:origin-bucket