request.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 ;;;; request.lisp
  29
  30 (in-package #:zs3)
  31
  32 (defvar *s3-endpoint* "s3.amazonaws.com")
  33 (defvar *use-ssl* nil)
  34 (defvar *use-content-md5* t)
  35
  36 (defclass request ()
  37   ((credentials
  38     :initarg :credentials
  39     :accessor credentials
  40     :documentation "An object that has methods for ACCESS-KEY and
  41     SECRET-KEY. A list of two strings (the keys) suffices.")
  42    (endpoint
  43     :initarg :endpoint
  44     :accessor endpoint)
  45    (ssl
  46     :initarg :ssl
  47     :accessor ssl)
  48    (method
  49     :initarg :method
  50     :accessor method
  51     :documentation "e.g. :GET, :PUT, :DELETE")
  52    (bucket
  53     :initarg :bucket
  54     :accessor bucket
  55     :documentation
  56     "A string naming the bucket to address in the request. If NIL,
  57     request is not directed at a specific bucket.")
  58    (key
  59     :initarg :key
  60     :accessor key
  61     :documentation
  62     "A string naming the key to address in the request. If NIL,
  63     request is not directed at a specific key.")
  64    (sub-resource
  65     :initarg :sub-resource
  66     :accessor sub-resource
  67     :documentation "A sub-resource to address as part of the request,
  68     without a leading \"?\", e.g. \"acl\", \"torrent\". If PARAMETERS
  69     is set, this must be NIL.")
  70    (parameters
  71     :initarg :parameters
  72     :accessor parameters
  73     :documentation
  74     "An alist of string key/value pairs to send as CGI-style GET
  75     parameters with the request. If SUB-RESOURCE is set, these must be
  76     NIL.")
  77    (content-type
  78     :initarg :content-type
  79     :accessor content-type)
  80    (content-md5
  81     :initarg :content-md5
  82     :accessor content-md5)
  83    (content-length
  84     :initarg :content-length
  85     :accessor content-length)
  86    (content
  87     :initarg :content
  88     :accessor content)
  89    (metadata
  90     :initarg :metadata
  91     :accessor metadata
  92     :documentation
  93     "An alist of Amazon metadata to attach to a request. These should
  94     be straight string key/value pairs, WITHOUT any \"x-amz-meta-\"
  95     prefix.")
  96    (amz-headers
  97     :initarg :amz-headers
  98     :accessor amz-headers
  99     :documentation
 100     "An alist of extra Amazon request headers. These should be
 101     straight string key/value pairs, WITHOUT any \"x-amz-\" prefix.")
 102    (date
 103     :initarg :date
 104     :accessor date)
 105    (signed-string
 106     :initarg :signed-string
 107     :accessor signed-string)
 108    (extra-http-headers
 109     :initarg :extra-http-headers
 110     :accessor extra-http-headers
 111     :documentation "An alist of extra HTTP headers to include in the request."))
 112   (:default-initargs
 113    ;; :date and :content-md5 are specially treated, should not be nil
 114    :credentials *credentials*
 115    :method :get
 116    :endpoint *s3-endpoint*
 117    :ssl *use-ssl*
 118    :bucket nil
 119    :key nil
 120    :sub-resource nil
 121    :parameters nil
 122    :content-type nil
 123    :content-length t
 124    :content nil
 125    :metadata nil
 126    :amz-headers nil
 127    :extra-http-headers nil))
 128
 129 (defmethod slot-unbound ((class t) (request request) (slot (eql 'date)))
 130   (setf (date request) (get-universal-time)))
 131
 132 (defmethod slot-unbound ((class t) (request request) (slot (eql 'content-md5)))
 133   (setf (content-md5 request)
 134         (and *use-content-md5*
 135              (pathnamep (content request))
 136              (file-md5/b64 (content request)))))
 137
 138 (defmethod initialize-instance :after ((request request)
 139                                        &rest initargs &key
 140                                        &allow-other-keys)
 141   (declare (ignore initargs))
 142   (when (eql (method request) :head)
 143     ;; https://forums.aws.amazon.com/thread.jspa?messageID=340398 -
 144     ;; when using the bare endpoint, the 301 redirect for a HEAD
 145     ;; request does not include enough info to actually redirect. Use
 146     ;; the bucket endpoint pre-emptively instead
 147     (setf (endpoint request) (format nil "~A.~A"
 148                                      (bucket request)
 149                                      *s3-endpoint*)))
 150   (unless (integerp (content-length request))
 151     (let ((content (content request)))
 152       (setf (content-length request)
 153             (etypecase content
 154               (null 0)
 155               (pathname (file-size content))
 156               (vector (length content)))))))
 157
 158 (defgeneric http-method (request)
 159   (:method (request)
 160     (string-upcase (method request))))
 161
 162 (defun puri-canonicalized-path (path)
 163   (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path))))
 164     (with-output-to-string (stream)
 165       (if (puri:uri-path parsed)
 166           (write-string (puri:uri-path parsed) stream)
 167           (write-string "/" stream))
 168       (when (puri:uri-query parsed)
 169         (write-string "?" stream)
 170         (write-string (puri:uri-query parsed) stream)))))
 171
 172 (defgeneric signed-path (request)
 173   (:method (request)
 174     (let ((*print-pretty* nil))
 175       (puri-canonicalized-path
 176        (with-output-to-string (stream)
 177          (write-char #\/ stream)
 178          (when (bucket request)
 179            (write-string (url-encode (name (bucket request))) stream)
 180            (write-char #\/ stream))
 181          (when (key request)
 182            (write-string (url-encode (name (key request)) :encode-slash nil)
 183                          stream))
 184          (when (sub-resource request)
 185            (write-string "?" stream)
 186            (write-string (url-encode (sub-resource request)) stream)))))))
 187
 188 (defgeneric request-path (request)
 189   (:method (request)
 190     (let ((*print-pretty* nil))
 191       (with-output-to-string (stream)
 192         (write-char #\/ stream)
 193         (when (and (bucket request)
 194                    (string= (endpoint request) *s3-endpoint*))
 195           (write-string (url-encode (name (bucket request))) stream)
 196           (write-char #\/ stream))
 197         (when (key request)
 198           (write-string (url-encode (name (key request))
 199                                     :encode-slash nil) stream))
 200         (when (sub-resource request)
 201           (write-string "?" stream)
 202           (write-string (url-encode (sub-resource request)) stream))))))
 203
 204 (defgeneric all-amazon-headers (request)
 205   (:method (request)
 206     (nconc
 207      (loop for ((key . value)) on (amz-headers request)
 208            collect (cons (format nil "x-amz-~(~A~)" key)
 209                          value))
 210      (loop for ((key . value)) on (metadata request)
 211            collect (cons (format nil "x-amz-meta-~(~A~)" key)
 212                          value)))))
 213
 214 (defgeneric amazon-header-signing-lines (request)
 215   (:method (request)
 216     ;; FIXME: handle values with commas, and repeated headers
 217     (let* ((headers (all-amazon-headers request))
 218            (sorted (sort headers #'string< :key #'car)))
 219       (loop for ((key . value)) on sorted
 220             collect (format nil "~A:~A" key value)))))
 221
 222 (defgeneric date-string (request)
 223   (:method (request)
 224     (http-date-string (date request))))
 225
 226 (defgeneric signature (request)
 227   (:method (request)
 228     (let ((digester (make-digester (secret-key request))))
 229       (flet ((maybe-add-line (string digester)
 230                (if string
 231                    (add-line string digester)
 232                    (add-newline digester))))
 233         (add-line (http-method request) digester)
 234         (maybe-add-line (content-md5 request) digester)
 235         (maybe-add-line (content-type request) digester)
 236         (add-line (date-string request) digester)
 237         (dolist (line (amazon-header-signing-lines request))
 238           (add-line line digester))
 239         (add-string (signed-path request) digester)
 240         (setf (signed-string request)
 241               (get-output-stream-string (signed-stream digester)))
 242         (digest64 digester)))))
 243
 244 (defgeneric drakma-headers (request)
 245   (:method (request)
 246     (let ((base
 247            (list* (cons "Date" (http-date-string (date request)))
 248                   (cons "Authorization"
 249                         (format nil "AWS ~A:~A"
 250                                 (access-key request)
 251                                 (signature request)))
 252                   (all-amazon-headers request))))
 253       (when (content-md5 request)
 254         (push (cons "Content-MD5" (content-md5 request)) base))
 255       (append (extra-http-headers request) base))))
 256
 257 (defgeneric url (request)
 258   (:method (request)
 259     (format nil "http~@[s~*~]://~A~A"
 260             (ssl request)
 261             (endpoint request)
 262             (request-path request))))
 263
 264 (defun send-file-content (fun request)
 265   (with-open-file (stream (content request)
 266                           :element-type '(unsigned-byte 8))
 267     (let* ((buffer-size 8000)
 268            (buffer (make-octet-vector buffer-size)))
 269       (flet ((read-exactly (size)
 270                (assert (= size (read-sequence buffer stream)))))
 271         (multiple-value-bind (loops rest)
 272             (truncate (content-length request) buffer-size)
 273           (dotimes (i loops)
 274             (read-exactly buffer-size)
 275             (funcall fun buffer t))
 276           (read-exactly rest)
 277           (funcall fun (subseq buffer 0 rest) nil))))))
 278
 279 (defgeneric send (request &key want-stream)
 280   (:method (request &key want-stream)
 281     (let ((continuation
 282            (drakma:http-request (url request)
 283                                 :redirect nil
 284                                 :want-stream want-stream
 285                                 :content-type (content-type request)
 286                                 :additional-headers (drakma-headers request)
 287                                 :method (method request)
 288                                 :force-binary t
 289                                 :content-length (content-length request)
 290                                 :parameters (parameters request)
 291                                 :content :continuation)))
 292       (let ((content (content request)))
 293         (if (pathnamep content)
 294             (send-file-content continuation request)
 295             (funcall continuation content nil))))))
 296
 297 (defmethod access-key ((request request))
 298   (access-key (credentials request)))
 299
 300 (defmethod secret-key ((request request))
 301   (secret-key (credentials request)))
 302