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   (multiple-value-bind (body code headers uri stream must-close phrase)
 104       (send request :want-stream body-stream)
 105     (declare (ignore uri must-close))
 106     (let ((response
 107            (make-instance 'response
 108                           :request request
 109                           :body body
 110                           :http-code code
 111                           :http-phrase phrase
 112                           :http-headers headers)))
 113       (if keep-stream
 114           (funcall handler response)
 115           (with-open-stream (stream stream)
 116             (declare (ignore stream))
 117             (funcall handler response))))))
 118
 119 (defun submit-request (request
 120                        &key body-stream keep-stream
 121                        (handler 'specialize-response))
 122   (loop
 123    (handler-case
 124        (let ((response (request-response request
 125                                          :keep-stream keep-stream
 126                                          :body-stream body-stream
 127                                          :handler handler)))
 128          (maybe-signal-error response)
 129          (setf (request response) request)
 130          (return response))
 131      (temporary-redirect (condition)
 132        (setf (endpoint request)
 133              (request-error-endpoint condition)))
 134      (permanent-redirect (condition)
 135        ;; Remember the new endpoint long-term
 136        (let ((new-endpoint (request-error-endpoint condition)))
 137          (setf (redirected-endpoint (endpoint request)
 138                                     (bucket request))
 139                new-endpoint)
 140          (setf (endpoint request) new-endpoint)))
 141      (internal-error ()
 142        ;; Per the S3 docs, InternalErrors should simply be retried
 143        ))))