response.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 ;;;; response.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defvar *response-element-classes*
  33   (make-hash-table :test 'equal))
  34
  35 (defun set-element-class (element-name class)
  36   (setf (gethash element-name *response-element-classes*) class))
  37
  38 (defclass response ()
  39   ((request
  40     :initarg :request
  41     :accessor request)
  42    (body
  43     :initarg :body
  44     :accessor body)
  45    (http-code
  46     :initarg :http-code
  47     :accessor http-code)
  48    (http-phrase
  49     :initarg :http-phrase
  50     :accessor http-phrase)
  51    (http-headers
  52     :initarg :http-headers
  53     :accessor http-headers))
  54   (:default-initargs
  55    :request nil
  56    :body nil
  57    :http-code 999
  58    :http-phrase "<uninitialized>"
  59    :http-headers nil))
  60
  61
  62 (defmethod print-object ((response response) stream)
  63   (print-unreadable-object (response stream :type t :identity t)
  64     (format stream "~D ~S" (http-code response) (http-phrase response))))
  65
  66 (defgeneric xml-string (response)
  67   (:method (response)
  68     (flexi-streams:octets-to-string (body response) :external-format :utf-8)))
  69
  70 (defgeneric response-specialized-class (name)
  71   (:method (name)
  72     (gethash name *response-element-classes*)))
  73
  74 (defgeneric specialized-initialize (object source)
  75   (:method (object (source t))
  76     object))
  77
  78 (defgeneric content-length (response)
  79   (:method (response)
  80     (parse-integer (bvalue :content-length (http-headers response)))))
  81
  82 (defgeneric specialize-response (response)
  83   (:method ((response response))
  84     (cond ((or (null (body response))
  85                (and (not (streamp (body response)))
  86                     (zerop (length (body response)))))
  87            response)
  88           (t
  89            (let* ((source (xml-source (body response)))
  90                   (type (xml-document-element source))
  91                   (class (response-specialized-class type)))
  92              (when class
  93                (change-class response class)
  94                (specialized-initialize response source))
  95              response)))))
  96
  97 (defun request-response (request &key
  98                          body-stream
  99                          keep-stream
 100                          (handler 'specialize-response))
 101   (setf (endpoint request) (redirected-endpoint (endpoint request)
 102                                                 (bucket request)))
 103   (ensure-amz-header request "date"
 104                      (iso8601-basic-timestamp-string (date request)))
 105   (multiple-value-bind (body code headers uri stream must-close phrase)
 106       (send request :want-stream body-stream)
 107     (declare (ignore uri must-close))
 108     (let ((response
 109            (make-instance 'response
 110                           :request request
 111                           :body body
 112                           :http-code code
 113                           :http-phrase phrase
 114                           :http-headers headers)))
 115       (if keep-stream
 116           (funcall handler response)
 117           (with-open-stream (stream stream)
 118             (funcall handler response))))))
 119
 120 (defun submit-request (request
 121                        &key body-stream keep-stream
 122                          (handler 'specialize-response))
 123   ;; The original endpoint has to be stashed so it can be updated as
 124   ;; needed by AuthorizationHeaderMalformed responses after being
 125   ;; clobbered in the request by TemporaryRedirect responses.
 126   (let ((original-endpoint (endpoint request)))
 127     (loop
 128       (handler-case
 129           (let ((response (request-response request
 130                                             :keep-stream keep-stream
 131                                             :body-stream body-stream
 132                                             :handler handler)))
 133             (maybe-signal-error response)
 134             (setf (request response) request)
 135             (return response))
 136         (temporary-redirect (condition)
 137           (setf (endpoint request)
 138                 (request-error-endpoint condition)))
 139         (authorization-header-malformed (condition)
 140           (let ((region (request-error-region condition)))
 141             (setf (redirection-data original-endpoint (bucket request))
 142                   (list (endpoint request)
 143                         region))
 144             (setf (region request) region)))
 145         (permanent-redirect (condition)
 146           ;; Remember the new endpoint long-term
 147           (let ((new-endpoint (request-error-endpoint condition))
 148                 (new-region (cdr (assoc :x-amz-bucket-region
 149                                         (http-headers (request-error-response condition))))))
 150             (setf (redirection-data (endpoint request)
 151                                     (bucket request))
 152                   (list new-endpoint (or new-region (region request))))
 153             (setf (endpoint request) new-endpoint)
 154             (when new-region
 155               (setf (region request) new-region))))
 156         (internal-error ()
 157           ;; Per the S3 docs, InternalErrors should simply be retried
 158           )))))