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 (request request) (slot (eql 'date)))
 130   (setf (date request) (get-universal-time)))
 131
 132 (defmethod slot-unbound (class (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         (when (parameters request)
 194           (write-string "?" stream)
 195           (write-string (alist-to-url-encoded-string (parameters request))
 196                         stream))))))
 197
 198 (defgeneric all-amazon-headers (request)
 199   (:method (request)
 200     (nconc
 201      (loop for ((key . value)) on (amz-headers request)
 202            collect (cons (format nil "x-amz-~(~A~)" key)
 203                          value))
 204      (loop for ((key . value)) on (metadata request)
 205            collect (cons (format nil "x-amz-meta-~(~A~)" key)
 206                          value)))))
 207
 208 (defgeneric amazon-header-signing-lines (request)
 209   (:method (request)
 210     ;; FIXME: handle values with commas, and repeated headers
 211     (let* ((headers (all-amazon-headers request))
 212            (sorted (sort headers #'string< :key #'car)))
 213       (loop for ((key . value)) on sorted
 214             collect (format nil "~A:~A" key value)))))
 215
 216 (defgeneric date-string (request)
 217   (:method (request)
 218     (http-date-string (date request))))
 219
 220 (defgeneric signature (request)
 221   (:method (request)
 222     (let ((digester (make-digester (secret-key request))))
 223       (flet ((maybe-add-line (string digester)
 224                (if string
 225                    (add-line string digester)
 226                    (add-newline digester))))
 227         (add-line (http-method request) digester)
 228         (maybe-add-line (content-md5 request) digester)
 229         (maybe-add-line (content-type request) digester)
 230         (add-line (date-string request) digester)
 231         (dolist (line (amazon-header-signing-lines request))
 232           (add-line line digester))
 233         (add-string (signed-path request) digester)
 234         (setf (signed-string request)
 235               (get-output-stream-string (signed-stream digester)))
 236         (digest64 digester)))))
 237
 238 (defgeneric drakma-headers (request)
 239   (:method (request)
 240     (let ((base
 241            (list* (cons "Date" (http-date-string (date request)))
 242                   (cons "Authorization"
 243                         (format nil "AWS ~A:~A"
 244                                 (access-key request)
 245                                 (signature request)))
 246                   (all-amazon-headers request))))
 247       (when (content-md5 request)
 248         (push (cons "Content-MD5" (content-md5 request)) base))
 249       (append (extra-http-headers request) base))))
 250
 251 (defgeneric url (request)
 252   (:method (request)
 253     (format nil "http~@[s~*~]://~A~A"
 254             (ssl request)
 255             (endpoint request)
 256             (request-path request))))
 257
 258 (defun send-file-content (fun request)
 259   (with-open-file (stream (content request)
 260                           :element-type '(unsigned-byte 8))
 261     (let* ((buffer-size 8000)
 262            (buffer (make-octet-vector buffer-size)))
 263       (flet ((read-exactly (size)
 264                (assert (= size (read-sequence buffer stream)))))
 265         (multiple-value-bind (loops rest)
 266             (truncate (content-length request) buffer-size)
 267           (dotimes (i loops)
 268             (read-exactly buffer-size)
 269             (funcall fun buffer t))
 270           (read-exactly rest)
 271           (funcall fun (subseq buffer 0 rest) nil))))))
 272
 273 (defgeneric send (request &key want-stream)
 274   (:method (request &key want-stream)
 275     (let ((continuation
 276            (drakma:http-request (url request)
 277                                 :redirect nil
 278                                 :want-stream want-stream
 279                                 :content-type (content-type request)
 280                                 :additional-headers (drakma-headers request)
 281                                 :method (method request)
 282                                 :force-binary t
 283                                 :content-length (content-length request)
 284                                 :content :continuation)))
 285       (let ((content (content request)))
 286         (if (pathnamep content)
 287             (send-file-content continuation request)
 288             (funcall continuation content nil))))))
 289
 290 (defmethod access-key ((request request))
 291   (access-key (credentials request)))
 292
 293 (defmethod secret-key ((request request))
 294   (secret-key (credentials request)))
 295