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