request.lisp

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