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 host (request)
 159   (:method ((request request))
 160     (or (redirected-endpoint (endpoint request) (bucket request))
 161         (endpoint request))))
 162
 163 (defgeneric http-method (request)
 164   (:method (request)
 165     (string-upcase (method request))))
 166
 167 (defun puri-canonicalized-path (path)
 168   (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path))))
 169     (with-output-to-string (stream)
 170       (if (puri:uri-path parsed)
 171           (write-string (puri:uri-path parsed) stream)
 172           (write-string "/" stream))
 173       (when (puri:uri-query parsed)
 174         (write-string "?" stream)
 175         (write-string (puri:uri-query parsed) stream)))))
 176
 177 (defgeneric signed-path (request)
 178   (:method (request)
 179     (let ((*print-pretty* nil))
 180       (puri-canonicalized-path
 181        (with-output-to-string (stream)
 182          (write-char #\/ stream)
 183          (when (bucket request)
 184            (write-string (url-encode (name (bucket request))) stream)
 185            (write-char #\/ stream))
 186          (when (key request)
 187            (write-string (url-encode (name (key request)) :encode-slash nil)
 188                          stream))
 189          (when (sub-resource request)
 190            (write-string "?" stream)
 191            (write-string (url-encode (sub-resource request)) stream)))))))
 192
 193 (defgeneric request-path (request)
 194   (:method (request)
 195     (let ((*print-pretty* nil))
 196       (with-output-to-string (stream)
 197         (write-char #\/ stream)
 198         (when (and (bucket request)
 199                    (string= (endpoint request) *s3-endpoint*))
 200           (write-string (url-encode (name (bucket request))) stream)
 201           (write-char #\/ stream))
 202         (when (key request)
 203           (write-string (url-encode (name (key request))
 204                                     :encode-slash nil) stream))
 205         (when (sub-resource request)
 206           (write-string "?" stream)
 207           (write-string (url-encode (sub-resource request)) stream))))))
 208
 209 (defgeneric all-amazon-headers (request)
 210   (:method (request)
 211     (nconc
 212      (loop for ((key . value)) on (amz-headers request)
 213            collect (cons (format nil "x-amz-~(~A~)" key)
 214                          value))
 215      (loop for ((key . value)) on (metadata request)
 216            collect (cons (format nil "x-amz-meta-~(~A~)" key)
 217                          value)))))
 218
 219 (defgeneric amazon-header-signing-lines (request)
 220   (:method (request)
 221     ;; FIXME: handle values with commas, and repeated headers
 222     (let* ((headers (all-amazon-headers request))
 223            (sorted (sort headers #'string< :key #'car)))
 224       (loop for ((key . value)) on sorted
 225             collect (format nil "~A:~A" key value)))))
 226
 227 (defgeneric date-string (request)
 228   (:method (request)
 229     (http-date-string (date request))))
 230
 231 (defgeneric signature (request)
 232   (:method (request)
 233     (let ((digester (make-digester (secret-key request))))
 234       (flet ((maybe-add-line (string digester)
 235                (if string
 236                    (add-line string digester)
 237                    (add-newline digester))))
 238         (add-line (http-method request) digester)
 239         (maybe-add-line (content-md5 request) digester)
 240         (maybe-add-line (content-type request) digester)
 241         (add-line (date-string request) digester)
 242         (dolist (line (amazon-header-signing-lines request))
 243           (add-line line digester))
 244         (add-string (signed-path request) digester)
 245         (setf (signed-string request)
 246               (get-output-stream-string (signed-stream digester)))
 247         (digest64 digester)))))
 248
 249 (defgeneric authorization-header-value (request)
 250   (:method (request)
 251     (format nil "AWS ~A:~A"
 252             (access-key request)
 253             (signature request))))
 254
 255 (defgeneric drakma-headers (request)
 256   (:method (request)
 257     (let ((base
 258            (list* (cons "Date" (http-date-string (date request)))
 259                   (cons "Authorization"
 260                         (authorization-header-value request))
 261                   (all-amazon-headers request))))
 262       (when (content-md5 request)
 263         (push (cons "Content-MD5" (content-md5 request)) base))
 264       (append (extra-http-headers request) base))))
 265
 266 (defgeneric url (request)
 267   (:method (request)
 268     (format nil "http~@[s~*~]://~A~A"
 269             (ssl request)
 270             (endpoint request)
 271             (request-path request))))
 272
 273 (defun send-file-content (fun request)
 274   (with-open-file (stream (content request)
 275                           :element-type '(unsigned-byte 8))
 276     (let* ((buffer-size 8000)
 277            (buffer (make-octet-vector buffer-size)))
 278       (flet ((read-exactly (size)
 279                (assert (= size (read-sequence buffer stream)))))
 280         (multiple-value-bind (loops rest)
 281             (truncate (content-length request) buffer-size)
 282           (dotimes (i loops)
 283             (read-exactly buffer-size)
 284             (funcall fun buffer t))
 285           (read-exactly rest)
 286           (funcall fun (subseq buffer 0 rest) nil))))))
 287
 288 (defgeneric send (request &key want-stream)
 289   (:method (request &key want-stream)
 290     (let ((continuation
 291            (drakma:http-request (url request)
 292                                 :redirect nil
 293                                 :want-stream want-stream
 294                                 :content-type (content-type request)
 295                                 :additional-headers (drakma-headers request)
 296                                 :method (method request)
 297                                 :force-binary t
 298                                 :content-length (content-length request)
 299                                 :parameters (parameters request)
 300                                 :content :continuation)))
 301       (let ((content (content request)))
 302         (if (pathnamep content)
 303             (send-file-content continuation request)
 304             (funcall continuation content nil))))))
 305
 306 (defmethod access-key ((request request))
 307   (access-key (credentials request)))
 308
 309 (defmethod secret-key ((request request))
 310   (secret-key (credentials request)))
 311