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         (when *use-content-md5*
 169           (let ((content (content request)))
 170             (cond ((pathnamep content) (file-md5/b64 content))
 171                   ((stringp content)
 172                    (vector-md5/b64
 173                     (flexi-streams:string-to-octets content)))
 174                   ((vectorp content) (vector-md5/b64 content)))))))
 175
 176 (defmethod slot-unbound ((class t) (request request) (slot (eql 'signed-string)))
 177   (setf (signed-string request)
 178         (format nil "~{~A~^~%~}" (string-to-sign-lines request))))
 179
 180 (defgeneric amz-header-value (request name)
 181   (:method (request name)
 182     (cdr (assoc name (amz-headers request) :test 'string=))))
 183
 184 (defgeneric ensure-amz-header (request name value)
 185   (:method (request name value)
 186     (unless (amz-header-value request name)
 187       (push (cons name value) (amz-headers request)))))
 188
 189 (defmethod initialize-instance :after ((request request)
 190                                        &rest initargs &key
 191                                        &allow-other-keys)
 192   (declare (ignore initargs))
 193   (when (eql (method request) :head)
 194     ;; https://forums.aws.amazon.com/thread.jspa?messageID=340398 -
 195     ;; when using the bare endpoint, the 301 redirect for a HEAD
 196     ;; request does not include enough info to actually redirect. Use
 197     ;; the bucket endpoint pre-emptively instead
 198     (setf (endpoint request) (format nil "~A.~A"
 199                                      (bucket request)
 200                                      *s3-endpoint*)))
 201   (ensure-amz-header request "date"
 202                      (iso8601-basic-timestamp-string (date request)))
 203   (ensure-amz-header request "content-sha256"
 204                      (payload-sha256 request))
 205   (let ((target-region (redirected-region (endpoint request)
 206                                           (bucket request))))
 207     (when target-region
 208       (setf (region request) target-region)))
 209   (when (content-md5 request)
 210     (push (cons "Content-MD5" (content-md5 request)) (extra-http-headers request)))
 211   (unless (integerp (content-length request))
 212     (let ((content (content request)))
 213       (setf (content-length request)
 214             (etypecase content
 215               (null 0)
 216               (pathname (file-size content))
 217               (vector (length content)))))))
 218
 219 (defgeneric host (request)
 220   (:method ((request request))
 221     (or (redirected-endpoint (endpoint request) (bucket request))
 222         (endpoint request))))
 223
 224 (defgeneric http-method (request)
 225   (:method (request)
 226     (string-upcase (method request))))
 227
 228 (defun puri-canonicalized-path (path)
 229   (let ((parsed (puri:parse-uri (format nil "http://dummy~A" path))))
 230     (with-output-to-string (stream)
 231       (if (puri:uri-path parsed)
 232           (write-string (puri:uri-path parsed) stream)
 233           (write-string "/" stream))
 234       (when (puri:uri-query parsed)
 235         (write-string "?" stream)
 236         (write-string (puri:uri-query parsed) stream)))))
 237
 238 (defgeneric signed-path (request)
 239   (:method (request)
 240     (let ((*print-pretty* nil))
 241       (puri-canonicalized-path
 242        (with-output-to-string (stream)
 243          (write-char #\/ stream)
 244          (when (bucket request)
 245            (write-string (url-encode (name (bucket request))) stream)
 246            (write-char #\/ stream))
 247          (when (key request)
 248            (write-string (url-encode (name (key request)) :encode-slash nil)
 249                          stream))
 250          (when (sub-resource request)
 251            (write-string "?" stream)
 252            (write-string (url-encode (sub-resource request)) stream)))))))
 253
 254 (defgeneric request-path (request)
 255   (:method (request)
 256     (let ((*print-pretty* nil))
 257       (with-output-to-string (stream)
 258         (write-char #\/ stream)
 259         (when (and (bucket request)
 260                    (string= (endpoint request)
 261                             (region-endpoint (region request))))
 262           (write-string (url-encode (name (bucket request))) stream)
 263           (write-char #\/ stream))
 264         (when (key request)
 265           (write-string (url-encode (name (key request))
 266                                     :encode-slash nil) stream))
 267         (when (sub-resource request)
 268           (write-string "?" stream)
 269           (write-string (url-encode (sub-resource request)) stream))))))
 270
 271 (defgeneric all-amazon-headers (request)
 272   (:method (request)
 273     (nconc
 274      (loop for ((key . value)) on (amz-headers request)
 275            collect (cons (format nil "x-amz-~(~A~)" key)
 276                          value))
 277      (loop for ((key . value)) on (metadata request)
 278            collect (cons (format nil "x-amz-meta-~(~A~)" key)
 279                          value)))))
 280
 281 (defgeneric date-string (request)
 282   (:method (request)
 283     (http-date-string (date request))))
 284
 285 ;;; AWS 4 authorization
 286
 287 (defun headers-for-signing (request)
 288   (append (all-amazon-headers request)
 289           (extra-http-headers request)
 290           (parameters-alist "host" (host request)
 291                             "content-type" (content-type request))))
 292
 293 (defun canonical-headers (headers)
 294   (flet ((trim (string)
 295            (string-trim " " string)))
 296     (let ((encoded
 297            (loop for (name . value) in headers
 298                  collect (cons (string-downcase name)
 299                                (trim value)))))
 300       (sort encoded #'string< :key 'car))))
 301
 302 (defun signed-headers (request)
 303   (mapcar 'first (canonical-headers (headers-for-signing request))))
 304
 305 (defun parameters-for-signing (request)
 306   (cond ((sub-resource request)
 307          (list (cons (sub-resource request) "")))
 308         (t
 309          (parameters request))))
 310
 311 (defun canonical-parameters (parameters)
 312   (let ((encoded
 313          (loop for (name . value) in parameters
 314                collect (cons
 315                         (url-encode name)
 316                         (url-encode value)))))
 317     (sort encoded #'string< :key 'car)))
 318
 319 (defun canonical-parameters-string (request)
 320   (format nil "~{~A=~A~^&~}"
 321                 (alist-plist (canonical-parameters
 322                               (parameters-for-signing request)))))
 323
 324 (defun path-to-sign (request)
 325   "Everything in the PATH of the request, up to the first ?"
 326   (let ((path (request-path request)))
 327     (subseq path 0 (position #\? path))))
 328
 329 (defun canonicalized-request-lines (request)
 330   "Return a list of lines canonicalizing the request according to
 331 http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html."
 332   (let* ((headers (headers-for-signing request))
 333          (canonical-headers (canonical-headers headers)))
 334     (alexandria:flatten
 335      (list (http-method request)
 336            (path-to-sign request)
 337            (canonical-parameters-string request)
 338            (loop for (name . value) in canonical-headers
 339                  collect (format nil "~A:~A" name value))
 340            ""
 341            (format nil "~{~A~^;~}" (signed-headers request))
 342            (or (amz-header-value request "content-sha256")
 343                "UNSIGNED-PAYLOAD")))))
 344
 345 (defun string-to-sign-lines (request)
 346   "Return a list of strings to sign to construct the Authorization header."
 347   (list "AWS4-HMAC-SHA256"
 348         (iso8601-basic-timestamp-string (date request))
 349         (with-output-to-string (s)
 350           (format s "~A/~A/s3/aws4_request"
 351                   (iso8601-basic-date-string (date request))
 352                   (region request)))
 353         (strings-sha256/hex (canonicalized-request-lines request))))
 354
 355 (defun make-signing-key (credentials &key region service)
 356   "The signing key is derived from the credentials, region, date, and
 357 service. A signing key could be saved, shared, and reused, but ZS3 just recomputes it all the time instead."
 358   (let* ((k1 (format nil "AWS4~A" (secret-key credentials)))
 359          (date-key (hmac-sha256 k1 (iso8601-basic-date-string)))
 360          (region-key (hmac-sha256 date-key region))
 361          (service-key (hmac-sha256 region-key service)))
 362     (hmac-sha256 service-key "aws4_request")))
 363
 364 (defun payload-sha256 (request)
 365   (if *signed-payload*
 366       (let ((payload (content request)))
 367         (etypecase payload
 368           ((or null empty-vector)
 369            *empty-string-sha256*)
 370           (vector
 371            (vector-sha256/hex payload))
 372           (pathname
 373            (file-sha256/hex payload))))
 374       "UNSIGNED-PAYLOAD"))
 375
 376 (defun request-signature (request)
 377   (let ((key (make-signing-key *credentials*
 378                                :region (region request)
 379                                :service "s3")))
 380     (strings-hmac-sha256/hex key (string-to-sign-lines request) )))
 381
 382 (defmethod authorization-header-value ((request request))
 383   (let ((key (make-signing-key *credentials*
 384                                :region (region request)
 385                                :service "s3"))
 386         (lines (string-to-sign-lines request)))
 387     (with-output-to-string (s)
 388       (write-string "AWS4-HMAC-SHA256" s)
 389       (format s " Credential=~A/~A/~A/s3/aws4_request"
 390               (access-key *credentials*)
 391               (iso8601-basic-date-string (date request))
 392               (region request))
 393       (format s ",SignedHeaders=~{~A~^;~}" (signed-headers request))
 394       (format s ",Signature=~A"
 395               (strings-hmac-sha256/hex key lines)))))
 396
 397 (defgeneric drakma-headers (request)
 398   (:method (request)
 399     (let ((base
 400            (list* (cons "Date" (http-date-string (date request)))
 401                   (cons "Authorization"
 402                         (authorization-header-value request))
 403                   (all-amazon-headers request))))
 404       (append (extra-http-headers request) base))))
 405
 406 (defgeneric url (request)
 407   (:method (request)
 408     (format nil "http~@[s~*~]://~A~A"
 409             (ssl request)
 410             (endpoint request)
 411             (request-path request))))
 412
 413 (defun send-file-content (fun request)
 414   (with-open-file (stream (content request)
 415                           :element-type '(unsigned-byte 8))
 416     (let* ((buffer-size 8000)
 417            (buffer (make-octet-vector buffer-size)))
 418       (flet ((read-exactly (size)
 419                (assert (= size (read-sequence buffer stream)))))
 420         (multiple-value-bind (loops rest)
 421             (truncate (content-length request) buffer-size)
 422           (dotimes (i loops)
 423             (read-exactly buffer-size)
 424             (funcall fun buffer t))
 425           (read-exactly rest)
 426           (funcall fun (subseq buffer 0 rest) nil))))))
 427
 428 (defgeneric send (request &key want-stream stream)
 429   (:method (request &key want-stream stream)
 430     (let ((continuation
 431            (drakma:http-request (url request)
 432                                 :redirect nil
 433                                 :want-stream want-stream
 434                                 :stream stream
 435                                 :keep-alive *use-keep-alive*
 436                                 :close (not *use-keep-alive*)
 437                                 :content-type (content-type request)
 438                                 :additional-headers (drakma-headers request)
 439                                 :method (method request)
 440                                 :force-binary t
 441                                 :content-length (content-length request)
 442                                 :parameters (parameters request)
 443                                 :content :continuation)))
 444       (let ((content (content request)))
 445         (if (pathnamep content)
 446             (send-file-content continuation request)
 447             (funcall continuation content nil))))))
 448
 449 (defmethod access-key ((request request))
 450   (access-key (credentials request)))
 451
 452 (defmethod secret-key ((request request))
 453   (secret-key (credentials request)))
 454
 455 (defmethod security-token ((request request))
 456   (security-token (credentials request)))