From 2ced92149872bccc436e2b8ffb82c82fb05e93ac Mon Sep 17 00:00:00 2001
From: Zach Beane <xach@xach.com>
Date: Wed, 27 Apr 2016 15:45:56 -0400
Subject: [PATCH] Make authorized-url construction work with aws4 auth.

---
 interface.lisp | 37 ++++++++++++++++++++++++++++---------
 request.lisp   |  3 ++-
 2 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/interface.lisp b/interface.lisp
index 9272202..28156ba 100644
--- a/interface.lisp
+++ b/interface.lisp
@@ -89,6 +89,16 @@ constraint."
     (when (plusp (length location))
       location)))
 
+(defun bucket-region (bucket
+                      &key ((:credentials *credentials*) *credentials*))
+  (or (bucket-location bucket)
+      "us-east-1"))
+
+(defun region-endpoint (region)
+  (if (string= region "us-east-1")
+      "s3.amazonaws.com"
+      (format nil "s3-~A.amazonaws.com" region)))
+
 (defun query-bucket (bucket &key prefix marker max-keys delimiter
                      ((:credentials *credentials*) *credentials*))
   (submit-request (make-instance 'request
@@ -801,12 +811,20 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX."
                          ((: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))))
+  (let* ((region (bucket-region bucket))
+         (region-endpoint (region-endpoint region))
+         (endpoint (case vhost
+                     (:cname bucket)
+                     (:amazon (format nil "~A.~A" bucket region-endpoint))
+                     ((nil) region-endpoint)))
+         (request (make-instance 'url-based-request
+                                 :method :get
+                                 :bucket bucket
+                                 :region region
+                                 :endpoint endpoint
+                                 :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"
@@ -831,15 +849,16 @@ TARGET-BUCKET with a key prefix of TARGET-PREFIX."
                  sub-resource
                  parameters))
         (:amazon
-         (format nil "http~@[s~*~]://~A.s3.amazonaws.com/~@[~A~]?~@[~A&~]~A"
+         (format nil "http~@[s~*~]://~A/~@[~A~]?~@[~A&~]~A"
                  ssl
-                 bucket
+                 endpoint
                  (url-encode key :encode-slash nil)
                  sub-resource
                  parameters))
         ((nil)
-         (format nil "http~@[s~*~]://s3.amazonaws.com/~@[~A/~]~@[~A~]?~@[~A&~]~A"
+         (format nil "http~@[s~*~]://~A/~@[~A/~]~@[~A~]?~@[~A&~]~A"
                  ssl
+                 endpoint
                  (url-encode bucket)
                  (url-encode key :encode-slash nil)
                  sub-resource
diff --git a/request.lisp b/request.lisp
index c4f5017..db3a0aa 100644
--- a/request.lisp
+++ b/request.lisp
@@ -225,7 +225,8 @@
       (with-output-to-string (stream)
         (write-char #\/ stream)
         (when (and (bucket request)
-                   (string= (endpoint request) *s3-endpoint*))
+                   (string= (endpoint request)
+                            (region-endpoint (region request))))
           (write-string (url-encode (name (bucket request))) stream)
           (write-char #\/ stream))
         (when (key request)
-- 
2.11.4.GIT