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 (bvalue :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            response)
  89           (t
  90            (let* ((source (xml-source (body response)))
  91                   (type (xml-document-element source))
  92                   (class (response-specialized-class type)))
  93              (when class
  94                (change-class response class)
  95                (specialized-initialize response source))
  96              response)))))
  97
  98
  99 (defun close-keep-alive ()
 100   (when *keep-alive-stream*
 101     (ignore-errors (close *keep-alive-stream*))
 102     (setq *keep-alive-stream* nil)))
 103
 104
 105 (defun request-response (request &key
 106                          body-stream
 107                          keep-stream
 108                          (handler 'specialize-response))
 109   (setf (endpoint request) (redirected-endpoint (endpoint request)
 110                                                 (bucket request)))
 111   (ensure-amz-header request "date"
 112                      (iso8601-basic-timestamp-string (date request)))
 113   (multiple-value-bind (body code headers uri stream must-close phrase)
 114       (send request :want-stream body-stream
 115                     :stream *keep-alive-stream*)
 116     (declare (ignore uri))
 117     (let ((response
 118            (make-instance 'response
 119                           :request request
 120                           :body body
 121                           :http-code code
 122                           :http-phrase phrase
 123                           :http-headers headers)))
 124       (if (and keep-stream (not must-close))
 125           (progn
 126             (when *use-keep-alive*
 127               (unless (eq *keep-alive-stream* stream)
 128                 (close-keep-alive)
 129                 (setq *keep-alive-stream* stream)))
 130             (funcall handler response))
 131           (with-open-stream (stream stream)
 132             (declare (ignorable stream))
 133             (setq *keep-alive-stream* nil)
 134             (funcall handler response))))))
 135
 136 (defun submit-request (request
 137                        &key body-stream
 138                          (keep-stream *use-keep-alive*)
 139                          (handler 'specialize-response))
 140   ;; The original endpoint has to be stashed so it can be updated as
 141   ;; needed by AuthorizationHeaderMalformed responses after being
 142   ;; clobbered in the request by TemporaryRedirect responses.
 143   (let ((original-endpoint (endpoint request)))
 144     (loop
 145       (handler-case
 146           (let ((response (request-response request
 147                                             :keep-stream keep-stream
 148                                             :body-stream body-stream
 149                                             :handler handler)))
 150             (maybe-signal-error response)
 151             (setf (request response) request)
 152             (return response))
 153         (temporary-redirect (condition)
 154           (setf (endpoint request)
 155                 (request-error-endpoint condition)))
 156         (authorization-header-malformed (condition)
 157           (let ((region (request-error-region condition)))
 158             (setf (redirection-data original-endpoint (bucket request))
 159                   (list (endpoint request)
 160                         region))
 161             (setf (region request) region)))
 162         (permanent-redirect (condition)
 163           ;; Remember the new endpoint long-term
 164           (let ((new-endpoint (request-error-endpoint condition))
 165                 (new-region (cdr (assoc :x-amz-bucket-region
 166                                         (http-headers (request-error-response condition))))))
 167             (setf (redirection-data (endpoint request)
 168                                     (bucket request))
 169                   (list new-endpoint (or new-region (region request))))
 170             (setf (endpoint request) new-endpoint)
 171             (when new-region
 172               (setf (region request) new-region))))
 173         (internal-error ()
 174           ;; Per the S3 docs, InternalErrors should simply be retried
 175           (close-keep-alive))
 176         (error (e)
 177           ;; Ensure that we don't reuse the stream, it may be the source of
 178           ;; our error.  Then resignal.
 179           (close-keep-alive)
 180           (error e))))))