From 6e93a925b3c11ab88c63bb2f41ecbec3a6cd9f66 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Wed, 27 Apr 2016 15:17:49 -0400 Subject: [PATCH] Many AWS4 auth updates. --- interface.lisp | 69 +++++++++++++------- redirects.lisp | 19 ++++-- request.lisp | 172 ++++++++++++++++++++++++++++++++++++++++--------- response.lisp | 61 +++++++++++------- tests.lisp | 71 +++++++++++--------- zs3.asd | 6 +- 6 files changed, 280 insertions(+), 118 deletions(-) diff --git a/interface.lisp b/interface.lisp index 7e386ec..9272202 100644 --- a/interface.lisp +++ b/interface.lisp @@ -225,7 +225,6 @@ constraint." :key key :extra-http-headers (parameters-alist - :connection "close" :if-modified-since (maybe-date when-modified-since) :if-unmodified-since @@ -799,32 +798,52 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX." sub-resource)))) (defun authorized-url (&key bucket key vhost expires ssl sub-resource - ((:credentials *credentials*) *credentials*)) + ((:credentials *credentials*) *credentials*)) (unless (and expires (integerp expires) (plusp expires)) (error "~S option must be a positive integer" :expires)) - (let* ((request (make-instance 'url-based-request - :method :get - :bucket bucket - :sub-resource sub-resource - :key key - :expires (unix-time expires))) - (parameters - (alist-to-url-encoded-string - (list (cons "AWSAccessKeyId" (access-key *credentials*)) - (cons "Expires" (format nil "~D" (expires request))) - (cons "Signature" - (signature request)))))) - (case vhost - (:cname - (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A" - ssl bucket (url-encode key) sub-resource parameters)) - (:amazon - (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A" - ssl bucket (url-encode key) sub-resource parameters)) - ((nil) - (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A" - ssl (url-encode bucket) (url-encode key) sub-resource - parameters))))) + (let ((request (make-instance 'url-based-request + :method :get + :bucket bucket + :sub-resource sub-resource + :key key + :expires (unix-time expires)))) + (setf (amz-headers request) nil) + (setf (parameters request) + (parameters-alist "X-Amz-Algorithm" "AWS4-HMAC-SHA256" + "X-Amz-Credential" + (format nil "~A/~A/~A/s3/aws4_request" + (access-key *credentials*) + (iso8601-basic-date-string (date request)) + (region request)) + "X-Amz-Date" (iso8601-basic-timestamp-string (date request)) + "X-Amz-Expires" expires + "X-Amz-SignedHeaders" + (format nil "~{~A~^;~}" (signed-headers request)))) + (push (cons "X-Amz-Signature" (request-signature request)) + (parameters request)) + (let ((parameters (alist-to-url-encoded-string (parameters request)))) + (case vhost + (:cname + (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A" + ssl + bucket + (url-encode key :encode-slash nil) + sub-resource + parameters)) + (:amazon + (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A" + ssl + bucket + (url-encode key :encode-slash nil) + sub-resource + parameters)) + ((nil) + (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A" + ssl + (url-encode bucket) + (url-encode key :encode-slash nil) + sub-resource + parameters)))))) ;;; Miscellaneous operations diff --git a/redirects.lisp b/redirects.lisp index af975be..d5098ba 100644 --- a/redirects.lisp +++ b/redirects.lisp @@ -40,12 +40,21 @@ creating requests.") (list endpoint bucket (access-key *credentials*))) -(defun redirected-endpoint (endpoint bucket &key - ((:credentials *credentials*) *credentials*)) - (gethash (redirect-key endpoint bucket) *permanent-redirects* endpoint)) +(defun redirection-data (endpoint bucket + &key ((:credentials *credentials*) *credentials*)) + (gethash (redirect-key endpoint bucket) *permanent-redirects*)) -(defun (setf redirected-endpoint) (new-value endpoint bucket &key - ((:credentials *credentials*) *credentials*)) +(defun redirected-endpoint (endpoint bucket + &key ((:credentials *credentials*) *credentials*)) + (or (first (redirection-data endpoint bucket)) endpoint)) + +(defun redirected-region (endpoint bucket &key + ((:credentials *credentials*) *credentials*)) + (second (redirection-data endpoint bucket))) + +(defun (setf redirection-data) (new-value endpoint bucket + &key ((:credentials *credentials*) *credentials*)) + (check-type new-value list) (let ((key (redirect-key endpoint bucket))) (if (not new-value) (progn (remhash key *permanent-redirects*) new-value) diff --git a/request.lisp b/request.lisp index 75f7ac4..c4f5017 100644 --- a/request.lisp +++ b/request.lisp @@ -30,8 +30,12 @@ (in-package #:zs3) (defvar *s3-endpoint* "s3.amazonaws.com") +(defvar *s3-region* "us-east-1") (defvar *use-ssl* nil) (defvar *use-content-md5* t) +(defvar *signed-payload* nil + "When true, compute the SHA256 hash for the body of all requests + when submitting to AWS.") (defclass request () ((credentials @@ -42,6 +46,9 @@ (endpoint :initarg :endpoint :accessor endpoint) + (region + :initarg :region + :accessor region) (ssl :initarg :ssl :accessor ssl) @@ -114,6 +121,7 @@ :credentials *credentials* :method :get :endpoint *s3-endpoint* + :region *s3-region* :ssl *use-ssl* :bucket nil :key nil @@ -135,6 +143,19 @@ (pathnamep (content request)) (file-md5/b64 (content request))))) +(defmethod slot-unbound ((class t) (request request) (slot (eql 'signed-string))) + (setf (signed-string request) + (format nil "~{~A~^~%~}" (string-to-sign-lines request)))) + +(defgeneric amz-header-value (request name) + (:method (request name) + (cdr (assoc name (amz-headers request) :test 'string=)))) + +(defgeneric ensure-amz-header (request name value) + (:method (request name value) + (unless (amz-header-value request name) + (push (cons name value) (amz-headers request))))) + (defmethod initialize-instance :after ((request request) &rest initargs &key &allow-other-keys) @@ -147,6 +168,14 @@ (setf (endpoint request) (format nil "~A.~A" (bucket request) *s3-endpoint*))) + (ensure-amz-header request "date" + (iso8601-basic-timestamp-string (date request))) + (ensure-amz-header request "content-sha256" + (payload-sha256 request)) + (let ((target-region (redirected-region (endpoint request) + (bucket request)))) + (when target-region + (setf (region request) target-region))) (unless (integerp (content-length request)) (let ((content (content request))) (setf (content-length request) @@ -216,41 +245,121 @@ collect (cons (format nil "x-amz-meta-~(~A~)" key) value))))) -(defgeneric amazon-header-signing-lines (request) - (:method (request) - ;; FIXME: handle values with commas, and repeated headers - (let* ((headers (all-amazon-headers request)) - (sorted (sort headers #'string< :key #'car))) - (loop for ((key . value)) on sorted - collect (format nil "~A:~A" key value))))) - (defgeneric date-string (request) (:method (request) (http-date-string (date request)))) -(defgeneric signature (request) - (:method (request) - (let ((digester (make-digester (secret-key request)))) - (flet ((maybe-add-line (string digester) - (if string - (add-line string digester) - (add-newline digester)))) - (add-line (http-method request) digester) - (maybe-add-line (content-md5 request) digester) - (maybe-add-line (content-type request) digester) - (add-line (date-string request) digester) - (dolist (line (amazon-header-signing-lines request)) - (add-line line digester)) - (add-string (signed-path request) digester) - (setf (signed-string request) - (get-output-stream-string (signed-stream digester))) - (digest64 digester))))) - -(defgeneric authorization-header-value (request) - (:method (request) - (format nil "AWS ~A:~A" - (access-key request) - (signature request)))) +;;; AWS 4 authorization + +(defun headers-for-signing (request) + (append (all-amazon-headers request) + (extra-http-headers request) + (parameters-alist "host" (host request) + "content-type" (content-type request)))) + +(defun canonical-headers (headers) + (flet ((trim (string) + (string-trim " " string))) + (let ((encoded + (loop for (name . value) in headers + collect (cons (string-downcase name) + (trim value))))) + (sort encoded #'string< :key 'car)))) + +(defun signed-headers (request) + (mapcar 'first (canonical-headers (headers-for-signing request)))) + +(defun parameters-for-signing (request) + (cond ((sub-resource request) + (list (cons (sub-resource request) ""))) + (t + (parameters request)))) + +(defun canonical-parameters (parameters) + (let ((encoded + (loop for (name . value) in parameters + collect (cons + (url-encode name) + (url-encode value))))) + (sort encoded #'string< :key 'car))) + +(defun canonical-parameters-string (request) + (format nil "~{~A=~A~^&~}" + (alist-plist (canonical-parameters + (parameters-for-signing request))))) + +(defun path-to-sign (request) + "Everything in the PATH of the request, up to the first ?" + (let ((path (request-path request))) + (subseq path 0 (position #\? path)))) + +(defun canonicalized-request-lines (request) + "Return a list of lines canonicalizing the request according to +http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html." + (let* ((headers (headers-for-signing request)) + (canonical-headers (canonical-headers headers))) + (alexandria:flatten + (list (http-method request) + (path-to-sign request) + (canonical-parameters-string request) + (loop for (name . value) in canonical-headers + collect (format nil "~A:~A" name value)) + "" + (format nil "~{~A~^;~}" (signed-headers request)) + (or (amz-header-value request "content-sha256") + "UNSIGNED-PAYLOAD"))))) + +(defun string-to-sign-lines (request) + "Return a list of strings to sign to construct the Authorization header." + (list "AWS4-HMAC-SHA256" + (iso8601-basic-timestamp-string (date request)) + (with-output-to-string (s) + (format s "~A/~A/s3/aws4_request" + (iso8601-basic-date-string (date request)) + (region request))) + (strings-sha256/hex (canonicalized-request-lines request)))) + +(defun make-signing-key (credentials &key region service) + "The signing key is derived from the credentials, region, date, and +service. A signing key could be saved, shared, and reused, but ZS3 just recomputes it all the time instead." + (let* ((k1 (format nil "AWS4~A" (secret-key credentials))) + (date-key (hmac-sha256 k1 (iso8601-basic-date-string))) + (region-key (hmac-sha256 date-key region)) + (service-key (hmac-sha256 region-key service))) + (hmac-sha256 service-key "aws4_request"))) + +(defun payload-sha256 (request) + (if *signed-payload* + (let ((payload (content request))) + (etypecase payload + ((or null empty-vector) + *empty-string-sha256*) + (vector + (vector-sha256/hex payload)) + (pathname + (file-sha256/hex payload)))) + "UNSIGNED-PAYLOAD")) + +(defun request-signature (request) + (let ((key (make-signing-key *credentials* + :region (region request) + :service "s3"))) + (strings-hmac-sha256/hex key (string-to-sign-lines request) ))) + +(defmethod authorization-header-value ((request request)) + (let ((key (make-signing-key *credentials* + :region (region request) + :service "s3")) + (lines (string-to-sign-lines request))) + (with-output-to-string (s) + (write-string "AWS4-HMAC-SHA256" s) + (format s " Credential=~A/~A/~A/s3/aws4_request" + (access-key *credentials*) + (iso8601-basic-date-string (date request)) + (region request)) + (format s ",SignedHeaders=~{~A~^;~}" (signed-headers request)) + (format s ",Signature=~A" + (strings-hmac-sha256/hex key lines))))) (defgeneric drakma-headers (request) (:method (request) @@ -289,6 +398,7 @@ (:method (request &key want-stream) (let ((continuation (drakma:http-request (url request) + :close t :redirect nil :want-stream want-stream :content-type (content-type request) diff --git a/response.lisp b/response.lisp index 39fb8ab..c24b816 100644 --- a/response.lisp +++ b/response.lisp @@ -100,6 +100,8 @@ (handler 'specialize-response)) (setf (endpoint request) (redirected-endpoint (endpoint request) (bucket request))) + (ensure-amz-header request "date" + (iso8601-basic-timestamp-string (date request))) (multiple-value-bind (body code headers uri stream must-close phrase) (send request :want-stream body-stream) (declare (ignore uri must-close)) @@ -113,31 +115,44 @@ (if keep-stream (funcall handler response) (with-open-stream (stream stream) - (declare (ignore stream)) (funcall handler response)))))) (defun submit-request (request &key body-stream keep-stream - (handler 'specialize-response)) - (loop - (handler-case - (let ((response (request-response request - :keep-stream keep-stream - :body-stream body-stream - :handler handler))) - (maybe-signal-error response) - (setf (request response) request) - (return response)) - (temporary-redirect (condition) - (setf (endpoint request) - (request-error-endpoint condition))) - (permanent-redirect (condition) - ;; Remember the new endpoint long-term - (let ((new-endpoint (request-error-endpoint condition))) - (setf (redirected-endpoint (endpoint request) + (handler 'specialize-response)) + ;; The original endpoint has to be stashed so it can be updated as + ;; needed by AuthorizationHeaderMalformed responses after being + ;; clobbered in the request by TemporaryRedirect responses. + (let ((original-endpoint (endpoint request))) + (loop + (handler-case + (let ((response (request-response request + :keep-stream keep-stream + :body-stream body-stream + :handler handler))) + (maybe-signal-error response) + (setf (request response) request) + (return response)) + (temporary-redirect (condition) + (setf (endpoint request) + (request-error-endpoint condition))) + (authorization-header-malformed (condition) + (let ((region (request-error-region condition))) + (setf (redirection-data original-endpoint (bucket request)) + (list (endpoint request) + region)) + (setf (region request) region))) + (permanent-redirect (condition) + ;; Remember the new endpoint long-term + (let ((new-endpoint (request-error-endpoint condition)) + (new-region (cdr (assoc :x-amz-bucket-region + (http-headers (request-error-response condition)))))) + (setf (redirection-data (endpoint request) (bucket request)) - new-endpoint) - (setf (endpoint request) new-endpoint))) - (internal-error () - ;; Per the S3 docs, InternalErrors should simply be retried - )))) + (list new-endpoint (or new-region (region request)))) + (setf (endpoint request) new-endpoint) + (when new-region + (setf (region request) new-region)))) + (internal-error () + ;; Per the S3 docs, InternalErrors should simply be retried + ))))) diff --git a/tests.lisp b/tests.lisp index 68f8c78..f6094b0 100644 --- a/tests.lisp +++ b/tests.lisp @@ -10,63 +10,72 @@ (setf *credentials* (file-credentials "~/.aws")) -(when (bucket-exists-p "zs3-tests") - (delete-bucket "zs3-tests")) +(defparameter *test-bucket* "zs3-tests33") -(create-bucket "zs3-tests") +(when (bucket-exists-p *test-bucket*) + (delete-bucket *test-bucket*)) -(put-file "/etc/issue" "zs3-tests" "printcap") -(put-string "Hello, world" "zs3-tests" "hello") -(put-vector (octet-vector 8 6 7 5 3 0 9) "zs3-tests" "jenny") +(create-bucket *test-bucket*) + +(put-file "/etc/issue" *test-bucket* "printcap") +(put-string "Hello, world" *test-bucket* "hello") +(put-vector (octet-vector 8 6 7 5 3 0 9) *test-bucket* "jenny") (all-buckets) -(all-keys "zs3-tests") +(all-keys *test-bucket*) -(delete-object "zs3-tests" "printcap") -(delete-object "zs3-tests" "hello") -(delete-object "zs3-tests" "jenny") +(delete-object *test-bucket* "printcap") +(delete-object *test-bucket* "hello") +(delete-object *test-bucket* "jenny") -(put-string "Hello, world" "zs3-tests" "hello" :start 1 :end 5) -(string= (get-string "zs3-tests" "hello") +(put-string "Hello, world" *test-bucket* "hello" :start 1 :end 5) +(string= (get-string *test-bucket* "hello") (subseq "Hello, world" 1 5)) -(put-file "tests.lisp" "zs3-tests" "self" :start 1 :end 5) -(string= (get-string "zs3-tests" "self") +(put-file "tests.lisp" *test-bucket* "self" :start 1 :end 5) +(string= (get-string *test-bucket* "self") ";;; ") (defparameter *jenny* (octet-vector 8 6 7 5 3 0 9)) -(put-vector *jenny* "zs3-tests" "jenny" :start 1 :end 6) +(put-vector *jenny* *test-bucket* "jenny" :start 1 :end 6) -(equalp (get-vector "zs3-tests" "jenny") +(equalp (get-vector *test-bucket* "jenny") (subseq *jenny* 1 6)) -(delete-object "zs3-tests" "hello") -(delete-object "zs3-tests" "self") -(delete-object "zs3-tests" "jenny") +(delete-object *test-bucket* "hello") +(delete-object *test-bucket* "self") +(delete-object *test-bucket* "jenny") ;;; Testing signing issues -(put-string "Slashdot" "zs3-tests" "slash/dot") -(put-string "Tildedot" "zs3-tests" "slash~dot") -(put-string "Spacedot" "zs3-tests" "slash dot") +(put-string "Slashdot" *test-bucket* "slash/dot") +(put-string "Tildedot" *test-bucket* "slash~dot") +(put-string "Spacedot" *test-bucket* "slash dot") -(delete-object "zs3-tests" "slash/dot") -(delete-object "zs3-tests" "slash~dot") -(delete-object "zs3-tests" "slash dot") +(delete-object *test-bucket* "slash/dot") +(delete-object *test-bucket* "slash~dot") +(delete-object *test-bucket* "slash dot") ;;; Subresources -(put-string "Fiddle dee dee" "zs3-tests" "fiddle") -(make-public :bucket "zs3-tests" :key "fiddle") -(make-private :bucket "zs3-tests" :key "fiddle") -(delete-object "zs3-tests" "fiddle") +(put-string "Fiddle dee dee" *test-bucket* "fiddle") +(make-public :bucket *test-bucket* :key "fiddle") +(make-private :bucket *test-bucket* :key "fiddle") +(delete-object *test-bucket* "fiddle") + +;;; Different regions + +(delete-bucket *test-bucket*) + +(create-bucket *test-bucket* :location "eu-central-1") +(put-string "Hello, world" *test-bucket* "hello") ;;; CloudFront distributions (defparameter *distro* - (create-distribution "zs3-tests" + (create-distribution *test-bucket* :cnames "zs3-tests.cdn.wigflip.com" :enabled nil :comment "Testing, 1 2 3")) @@ -75,4 +84,4 @@ (sleep 240) (delete-distribution *distro*)) -(delete-bucket "zs3-tests") +(delete-bucket *test-bucket*) diff --git a/zs3.asd b/zs3.asd index 6ac7d66..c86c6fa 100644 --- a/zs3.asd +++ b/zs3.asd @@ -29,6 +29,7 @@ (asdf:defsystem #:zs3 :depends-on (#:drakma + #:alexandria #:cxml #:ironclad #:puri @@ -45,7 +46,6 @@ (:file "xml-binding") (:file "xml-output") (:file "credentials") - (:file "aws4-auth") (:file "post") (:file "redirects") (:file "request") @@ -57,5 +57,5 @@ (:file "logging") (:file "location") (:file "interface") - (:file "lifecycle") - (:file "cloudfront"))) + (:file "cloudfront") + (:file "lifecycle")))