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 *s3-region* "us-east-1")
  34 (defvar *use-ssl* nil)
  35 (defvar *use-content-md5* t)
  36 (defvar *signed-payload* nil
  37   "When true, compute the SHA256 hash for the body of all requests
  38   when submitting to AWS.")
  39
  40 (defclass request ()
  41   ((credentials
  42     :initarg :credentials
  43     :accessor credentials
  44     :documentation "An object that has methods for ACCESS-KEY and
  45     SECRET-KEY. A list of two strings (the keys) suffices.")
  46    (endpoint
  47     :initarg :endpoint
  48     :accessor endpoint)
  49    (region
  50     :initarg :region
  51     :accessor region)
  52    (ssl
  53     :initarg :ssl
  54     :accessor ssl)
  55    (method
  56     :initarg :method
  57     :accessor method
  58     :documentation "e.g. :GET, :PUT, :DELETE")
  59    (bucket
  60     :initarg :bucket
  61     :accessor bucket
  62     :documentation
  63     "A string naming the bucket to address in the request. If NIL,
  64     request is not directed at a specific bucket.")
  65    (key
  66     :initarg :key
  67     :accessor key
  68     :documentation
  69     "A string naming the key to address in the request. If NIL,
  70     request is not directed at a specific key.")
  71    (sub-resource
  72     :initarg :sub-resource
  73     :accessor sub-resource
  74     :documentation "A sub-resource to address as part of the request,
  75     without a leading \"?\", e.g. \"acl\", \"torrent\". If PARAMETERS
  76     is set, this must be NIL.")
  77    (parameters
  78     :initarg :parameters
  79     :accessor parameters
  80     :documentation
  81     "An alist of string key/value pairs to send as CGI-style GET
  82     parameters with the request. If SUB-RESOURCE is set, these must be
  83     NIL.")
  84    (content-type
  85     :initarg :content-type
  86     :accessor content-type)
  87    (content-md5
  88     :initarg :content-md5
  89     :accessor content-md5)
  90    (content-length
  91     :initarg :content-length
  92     :accessor content-length)
  93    (content
  94     :initarg :content
  95     :accessor content)
  96    (metadata
  97     :initarg :metadata
  98     :accessor metadata
  99     :documentation
 100     "An alist of Amazon metadata to attach to a request. These should
 101     be straight string key/value pairs, WITHOUT any \"x-amz-meta-\"
 102     prefix.")
 103    (amz-headers
 104     :initarg :amz-headers
 105     :accessor amz-headers
 106     :documentation
 107     "An alist of extra Amazon request headers. These should be
 108     straight string key/value pairs, WITHOUT any \"x-amz-\" prefix.")
 109    (date
 110     :initarg :date
 111     :accessor date)
 112    (signed-string
 113     :initarg :signed-string
 114     :accessor signed-string)
 115    (extra-http-headers
 116     :initarg :extra-http-headers
 117     :accessor extra-http-headers
 118     :documentation "An alist of extra HTTP headers to include in the request."))
 119   (:default-initargs
 120    ;; :date and :content-md5 are specially treated, should not be nil
 121    :credentials *credentials*
 122    :method :get
 123    :endpoint *s3-endpoint*
 124    :region *s3-region*
 125    :ssl *use-ssl*
 126    :bucket nil
 127    :key nil
 128    :sub-resource nil
 129    :parameters nil
 130    :content-type nil
 131    :content-length t
 132    :content nil
 133    :metadata nil
 134    :amz-headers nil
 135    :extra-http-headers nil))
 136
 137 (defmethod slot-unbound ((class t) (request request) (slot (eql 'date)))
 138   (setf (date request) (get-universal-time)))
 139
 140 (defmethod slot-unbound ((class t) (request request) (slot (eql 'content-md5)))
 141   (setf (content-md5 request)
 142         (and *use-content-md5*
 143              (pathnamep (content request))
 144              (file-md5/b64 (content request)))))
 145
 146 (defmethod slot-unbound ((class t) (request request) (slot (eql 'signed-string)))
 147   (setf (signed-string request)
 148         (format nil "~{~A~^~%~}" (string-to-sign-lines request))))
 149
 150 (defgeneric amz-header-value (request name)
 151   (:method (request name)
 152     (cdr (assoc name (amz-headers request) :test 'string=))))
 153
 154 (defgeneric ensure-amz-header (request name value)
 155   (:method (request name value)
 156     (unless (amz-header-value request name)
 157       (push (cons name value) (amz-headers request)))))
 158
 159 (defmethod initialize-instance :after ((request request)
 160                                        &rest initargs &key
 161                                        &allow-other-keys)
 162   (declare (ignore initargs))
 163   (when (eql (method request) :head)
 164     ;; https://forums.aws.amazon.com/thread.jspa?messageID=340398 -
 165     ;; when using the bare endpoint, the 301 redirect for a HEAD
 166     ;; request does not include enough info to actually redirect. Use
 167     ;; the bucket endpoint pre-emptively instead
 168     (setf (endpoint request) (format nil "~A.~A"
 169                                      (bucket request)
 170                                      *s3-endpoint*)))
 171   (ensure-amz-header request "date"
 172                      (iso8601-basic-timestamp-string (date request)))
 173   (ensure-amz-header request "content-sha256"
 174                      (payload-sha256 request))
 175   (let ((target-region (redirected-region (endpoint request)
 176                                           (bucket request))))
 177     (when target-region
 178       (setf (region request) target-region)))
 179   (when (content-md5 request)
 180     (push (cons "Content-MD5" (content-md5 request)) (extra-http-headers request)))
 181   (unless (integerp (content-length request))
 182     (let ((content (content request)))
 183       (setf (content-length request)
 184             (etypecase content
 185               (null 0)
 186               (pathname (file-size content))
 187               (vector (length content)))))))
 188
 189 (defgeneric host (request)
 190   (:method ((request request))
 191     (or (redirected-endpoint (endpoint request) (bucket request))
 192         (endpoint request))))
 193
 194 (defgeneric http-method (request)
 195   (:method (request)
 196     (string-upcase (method request))))
 197
 198 (defun puri-canonicalized-path (path)
 199   (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path))))
 200     (with-output-to-string (stream)
 201       (if (puri:uri-path parsed)
 202           (write-string (puri:uri-path parsed) stream)
 203           (write-string "/" stream))
 204       (when (puri:uri-query parsed)
 205         (write-string "?" stream)
 206         (write-string (puri:uri-query parsed) stream)))))
 207
 208 (defgeneric signed-path (request)
 209   (:method (request)
 210     (let ((*print-pretty* nil))
 211       (puri-canonicalized-path
 212        (with-output-to-string (stream)
 213          (write-char #\/ stream)
 214          (when (bucket request)
 215            (write-string (url-encode (name (bucket request))) stream)
 216            (write-char #\/ stream))
 217          (when (key request)
 218            (write-string (url-encode (name (key request)) :encode-slash nil)
 219                          stream))
 220          (when (sub-resource request)
 221            (write-string "?" stream)
 222            (write-string (url-encode (sub-resource request)) stream)))))))
 223
 224 (defgeneric request-path (request)
 225   (:method (request)
 226     (let ((*print-pretty* nil))
 227       (with-output-to-string (stream)
 228         (write-char #\/ stream)
 229         (when (and (bucket request)
 230                    (string= (endpoint request)
 231                             (region-endpoint (region request))))
 232           (write-string (url-encode (name (bucket request))) stream)
 233           (write-char #\/ stream))
 234         (when (key request)
 235           (write-string (url-encode (name (key request))
 236                                     :encode-slash nil) stream))
 237         (when (sub-resource request)
 238           (write-string "?" stream)
 239           (write-string (url-encode (sub-resource request)) stream))))))
 240
 241 (defgeneric all-amazon-headers (request)
 242   (:method (request)
 243     (nconc
 244      (loop for ((key . value)) on (amz-headers request)
 245            collect (cons (format nil "x-amz-~(~A~)" key)
 246                          value))
 247      (loop for ((key . value)) on (metadata request)
 248            collect (cons (format nil "x-amz-meta-~(~A~)" key)
 249                          value)))))
 250
 251 (defgeneric date-string (request)
 252   (:method (request)
 253     (http-date-string (date request))))
 254
 255 ;;; AWS 4 authorization
 256
 257 (defun headers-for-signing (request)
 258   (append (all-amazon-headers request)
 259           (extra-http-headers request)
 260           (parameters-alist "host" (host request)
 261                             "content-type" (content-type request))))
 262
 263 (defun canonical-headers (headers)
 264   (flet ((trim (string)
 265            (string-trim " " string)))
 266     (let ((encoded
 267            (loop for (name . value) in headers
 268                  collect (cons (string-downcase name)
 269                                (trim value)))))
 270       (sort encoded #'string< :key 'car))))
 271
 272 (defun signed-headers (request)
 273   (mapcar 'first (canonical-headers (headers-for-signing request))))
 274
 275 (defun parameters-for-signing (request)
 276   (cond ((sub-resource request)
 277          (list (cons (sub-resource request) "")))
 278         (t
 279          (parameters request))))
 280
 281 (defun canonical-parameters (parameters)
 282   (let ((encoded
 283          (loop for (name . value) in parameters
 284                collect (cons
 285                         (url-encode name)
 286                         (url-encode value)))))
 287     (sort encoded #'string< :key 'car)))
 288
 289 (defun canonical-parameters-string (request)
 290   (format nil "~{~A=~A~^&~}"
 291                 (alist-plist (canonical-parameters
 292                               (parameters-for-signing request)))))
 293
 294 (defun path-to-sign (request)
 295   "Everything in the PATH of the request, up to the first ?"
 296   (let ((path (request-path request)))
 297     (subseq path 0 (position #\? path))))
 298
 299 (defun canonicalized-request-lines (request)
 300   "Return a list of lines canonicalizing the request according to
 301 http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html."
 302   (let* ((headers (headers-for-signing request))
 303          (canonical-headers (canonical-headers headers)))
 304     (alexandria:flatten
 305      (list (http-method request)
 306            (path-to-sign request)
 307            (canonical-parameters-string request)
 308            (loop for (name . value) in canonical-headers
 309                  collect (format nil "~A:~A" name value))
 310            ""
 311            (format nil "~{~A~^;~}" (signed-headers request))
 312            (or (amz-header-value request "content-sha256")
 313                "UNSIGNED-PAYLOAD")))))
 314
 315 (defun string-to-sign-lines (request)
 316   "Return a list of strings to sign to construct the Authorization header."
 317   (list "AWS4-HMAC-SHA256"
 318         (iso8601-basic-timestamp-string (date request))
 319         (with-output-to-string (s)
 320           (format s "~A/~A/s3/aws4_request"
 321                   (iso8601-basic-date-string (date request))
 322                   (region request)))
 323         (strings-sha256/hex (canonicalized-request-lines request))))
 324
 325 (defun make-signing-key (credentials &key region service)
 326   "The signing key is derived from the credentials, region, date, and
 327 service. A signing key could be saved, shared, and reused, but ZS3 just recomputes it all the time instead."
 328   (let* ((k1 (format nil "AWS4~A" (secret-key credentials)))
 329          (date-key (hmac-sha256 k1 (iso8601-basic-date-string)))
 330          (region-key (hmac-sha256 date-key region))
 331          (service-key (hmac-sha256 region-key service)))
 332     (hmac-sha256 service-key "aws4_request")))
 333
 334 (defun payload-sha256 (request)
 335   (if *signed-payload*
 336       (let ((payload (content request)))
 337         (etypecase payload
 338           ((or null empty-vector)
 339            *empty-string-sha256*)
 340           (vector
 341            (vector-sha256/hex payload))
 342           (pathname
 343            (file-sha256/hex payload))))
 344       "UNSIGNED-PAYLOAD"))
 345
 346 (defun request-signature (request)
 347   (let ((key (make-signing-key *credentials*
 348                                :region (region request)
 349                                :service "s3")))
 350     (strings-hmac-sha256/hex key (string-to-sign-lines request) )))
 351
 352 (defmethod authorization-header-value ((request request))
 353   (let ((key (make-signing-key *credentials*
 354                                :region (region request)
 355                                :service "s3"))
 356         (lines (string-to-sign-lines request)))
 357     (with-output-to-string (s)
 358       (write-string "AWS4-HMAC-SHA256" s)
 359       (format s " Credential=~A/~A/~A/s3/aws4_request"
 360               (access-key *credentials*)
 361               (iso8601-basic-date-string (date request))
 362               (region request))
 363       (format s ",SignedHeaders=~{~A~^;~}" (signed-headers request))
 364       (format s ",Signature=~A"
 365               (strings-hmac-sha256/hex key lines)))))
 366
 367 (defgeneric drakma-headers (request)
 368   (:method (request)
 369     (let ((base
 370            (list* (cons "Date" (http-date-string (date request)))
 371                   (cons "Authorization"
 372                         (authorization-header-value request))
 373                   (all-amazon-headers request))))
 374       (append (extra-http-headers request) base))))
 375
 376 (defgeneric url (request)
 377   (:method (request)
 378     (format nil "http~@[s~*~]://~A~A"
 379             (ssl request)
 380             (endpoint request)
 381             (request-path request))))
 382
 383 (defun send-file-content (fun request)
 384   (with-open-file (stream (content request)
 385                           :element-type '(unsigned-byte 8))
 386     (let* ((buffer-size 8000)
 387            (buffer (make-octet-vector buffer-size)))
 388       (flet ((read-exactly (size)
 389                (assert (= size (read-sequence buffer stream)))))
 390         (multiple-value-bind (loops rest)
 391             (truncate (content-length request) buffer-size)
 392           (dotimes (i loops)
 393             (read-exactly buffer-size)
 394             (funcall fun buffer t))
 395           (read-exactly rest)
 396           (funcall fun (subseq buffer 0 rest) nil))))))
 397
 398 (defgeneric send (request &key want-stream)
 399   (:method (request &key want-stream)
 400     (let ((continuation
 401            (drakma:http-request (url request)
 402                                 :close t
 403                                 :redirect nil
 404                                 :want-stream want-stream
 405                                 :content-type (content-type request)
 406                                 :additional-headers (drakma-headers request)
 407                                 :method (method request)
 408                                 :force-binary t
 409                                 :content-length (content-length request)
 410                                 :parameters (parameters request)
 411                                 :content :continuation)))
 412       (let ((content (content request)))
 413         (if (pathnamep content)
 414             (send-file-content continuation request)
 415             (funcall continuation content nil))))))
 416
 417 (defmethod access-key ((request request))
 418   (access-key (credentials request)))
 419
 420 (defmethod secret-key ((request request))
 421   (secret-key (credentials request)))
 422