response.lisp

   1 ;;;;
   2 ;;;; Copyright (c) 2008, 2015 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 ;;;; response.lisp
  29
  30 (in-package #:zs3)
  31
  32
  33 (defvar *response-element-classes*
  34   (make-hash-table :test 'equal))
  35
  36 (defun set-element-class (element-name class)
  37   (setf (gethash element-name *response-element-classes*) class))
  38
  39 (defclass response ()
  40   ((request
  41     :initarg :request
  42     :accessor request)
  43    (body
  44     :initarg :body
  45     :accessor body)
  46    (http-code
  47     :initarg :http-code
  48     :accessor http-code)
  49    (http-phrase
  50     :initarg :http-phrase
  51     :accessor http-phrase)
  52    (http-headers
  53     :initarg :http-headers
  54     :accessor http-headers))
  55   (:default-initargs
  56    :request nil
  57    :body nil
  58    :http-code 999
  59    :http-phrase "<uninitialized>"
  60    :http-headers nil))
  61
  62
  63 (defmethod print-object ((response response) stream)
  64   (print-unreadable-object (response stream :type t :identity t)
  65     (format stream "~D ~S" (http-code response) (http-phrase response))))
  66
  67 (defgeneric xml-string (response)
  68   (:method (response)
  69     (flexi-streams:octets-to-string (body response) :external-format :utf-8)))
  70
  71 (defgeneric response-specialized-class (name)
  72   (:method (name)
  73     (gethash name *response-element-classes*)))
  74
  75 (defgeneric specialized-initialize (object source)
  76   (:method (object (source t))
  77     object))
  78
  79 (defgeneric content-length (response)
  80   (:method (response)
  81     (parse-integer (drakma:header-value :content-length (http-headers response)))))
  82
  83 (defgeneric specialize-response (response)
  84   (:method ((response response))
  85     (cond ((or (null (body response))
  86                (and (not (streamp (body response)))
  87                     (zerop (length (body response)))))
  88            (when (<= 500 (http-code response) 599)
  89               (change-class response 'amazon-error)
  90               (specialized-initialize response nil))
  91            response)
  92           (t
  93            (let* ((source (xml-source (body response)))
  94                   (type (xml-document-element source))
  95                   (class (response-specialized-class type)))
  96              (when class
  97                (change-class response class)
  98                (specialized-initialize response source))
  99              response)))))
 100
 101
 102 (defun close-keep-alive ()
 103   (when *keep-alive-stream*
 104     (ignore-errors (close *keep-alive-stream*))
 105     (setq *keep-alive-stream* nil)))
 106
 107
 108 (defun request-response (request &key
 109                          body-stream
 110                          keep-stream
 111                          (handler 'specialize-response))
 112   (setf (endpoint request) (redirected-endpoint (endpoint request)
 113                                                 (bucket request)))
 114   (ensure-amz-header request "date"
 115                      (iso8601-basic-timestamp-string (date request)))
 116   (multiple-value-bind (body code headers uri stream must-close phrase)
 117       (send request :want-stream body-stream
 118                     :stream *keep-alive-stream*)
 119     (declare (ignore uri))
 120     (let ((response
 121            (make-instance 'response
 122                           :request request
 123                           :body body
 124                           :http-code code
 125                           :http-phrase phrase
 126                           :http-headers headers)))
 127       (if (and keep-stream (not must-close))
 128           (progn
 129             (when *use-keep-alive*
 130               (unless (eq *keep-alive-stream* stream)
 131                 (close-keep-alive)
 132                 (setq *keep-alive-stream* stream)))
 133             (funcall handler response))
 134           (with-open-stream (stream stream)
 135             (declare (ignorable stream))
 136             (setq *keep-alive-stream* nil)
 137             (funcall handler response))))))
 138
 139 (defvar *backoff* (cons 3 100)
 140   "Used as the default value of :BACKOFF when submitting a request.
 141    The value should be a cons of two numbers: how many times to try
 142    before giving up, and how long to wait (in ms) before trying for
 143    the second time. Each subsequent attempt will double that time.")
 144
 145 (defun submit-request (request
 146                        &key body-stream
 147                          (keep-stream *use-keep-alive*)
 148                          (handler 'specialize-response))
 149   ;; The original endpoint has to be stashed so it can be updated as
 150   ;; needed by AuthorizationHeaderMalformed responses after being
 151   ;; clobbered in the request by TemporaryRedirect responses.
 152   (let* ((original-endpoint (endpoint request))
 153          (backoff *backoff*)
 154          (tries (car backoff))
 155          (delay (/ (cdr backoff) 1000)))
 156     (loop
 157       (handler-case
 158           (let ((response (request-response request
 159                                             :keep-stream keep-stream
 160                                             :body-stream body-stream
 161                                             :handler handler)))
 162             (maybe-signal-error response)
 163             (setf (request response) request)
 164             (return response))
 165         (temporary-redirect (condition)
 166           (setf (endpoint request)
 167                 (request-error-endpoint condition)))
 168         (authorization-header-malformed (condition)
 169           (let ((region (request-error-region condition)))
 170             (setf (redirection-data original-endpoint (bucket request))
 171                   (list (endpoint request)
 172                         region))
 173             (setf (region request) region)))
 174         (permanent-redirect (condition)
 175           ;; Remember the new endpoint long-term
 176           (let ((new-endpoint (request-error-endpoint condition))
 177                 (new-region (cdr (assoc :x-amz-bucket-region
 178                                         (http-headers (request-error-response condition))))))
 179             (setf (redirection-data (endpoint request)
 180                                     (bucket request))
 181                   (list new-endpoint (or new-region (region request))))
 182             (setf (endpoint request) new-endpoint)
 183             (when new-region
 184               (setf (region request) new-region))))
 185         (internal-error (e)
 186           ;; Per the S3 docs, InternalErrors should be retried. Up to
 187           ;; a point.
 188           (close-keep-alive)
 189           (when (minusp (decf tries))
 190             ;; We've exceeded our failure allowance. Resignal.
 191             (error e))
 192           (sleep delay)
 193           (incf delay delay))
 194         (error (e)
 195           ;; Ensure that we don't reuse the stream, it may be the source of
 196           ;; our error.  Then resignal.
 197           (close-keep-alive)
 198           (error e))))))