S3 vhost customisation

WORKSPACE

@@ -14,7 +14,7 @@ exports_files(glob(["**/*.json"]))
 """,
     strip_prefix = "botocore-{version}/botocore/data",
     url = "https://github.com/boto/botocore/archive/{version}.tar.gz",
-    version = "3d570196b202407e61ff3125c57ba6d94f968cf2",
+    version = "d60c2e45b8e36f9c90faa1666fa7258fdc8c76a7",
 )
 
 #

gen/src/Gen/AST/Data.hs

@@ -220,11 +220,11 @@ prodData m s st = (,fields) <$> mk
       -- Instance declarations which are generated from the Inst data type
       let insts =
             concat
-              [ shapeInsts (m ^. protocol) (s ^. relMode) []
-              -- Handle the two oddballs that switch from Derive to
-              -- Inst halfway through generation.
-              , [ IsNFData [] | DNFData <- derives ]
-              , [ IsHashable [] | DHashable <- derives]
+              [ shapeInsts (m ^. protocol) (s ^. relMode) [],
+                -- Handle the two oddballs that switch from Derive to
+                -- Inst halfway through generation.
+                [IsNFData [] | DNFData <- derives],
+                [IsHashable [] | DHashable <- derives]
               ]
       instInsts <- for insts $ \inst ->
         pp None $ instD (instToQualifiedText inst) n Nothing

gen/src/Gen/AST/Data/Syntax.hs

@@ -216,6 +216,7 @@ serviceD m r = Exts.patBindWhere (pvar n) rhs bs
           field (unqual "Core._serviceEndpointPrefix") (m ^. endpointPrefix . Lens.to str),
           field (unqual "Core._serviceSigningName") (m ^. signingName . Lens.to str),
           field (unqual "Core._serviceVersion") (m ^. apiVersion . Lens.to str),
+          field (unqual "Core._serviceS3AddressingStyle") (var "Core.S3AddressingStyleAuto"),
           field (unqual "Core._serviceEndpoint") (Exts.app (var "Core.defaultEndpoint") (var n)),
           field (unqual "Core._serviceTimeout") (Exts.app justE (Exts.intE 70)),
           field (unqual "Core._serviceCheck") (var "Core.statusSuccess"),
@@ -374,7 +375,8 @@ requestD c m h (a, as) (b, bs) =
     (identifier a)
     $ Just
       [ assocD (identifier a) "AWSResponse" (typeId (identifier b)),
-        funD "request" (requestF c m h a as),
+        funArgsD "service" ["_"] (var (m ^. serviceConfig)),
+        funArgsD "request" ["srv"] (requestF c m h a as),
         funD "response" (responseE (m ^. protocol) b bs)
       ]
 
@@ -813,7 +815,7 @@ requestF c meta h r is =
       HashMap.lookup (identifier r) (c ^. operationPlugins)
         <|> HashMap.lookup (mkId "*") (c ^. operationPlugins)
 
-    e = Exts.app v (var n)
+    e = Exts.app v (var "srv")
 
     v =
       var
@@ -838,7 +840,6 @@ requestF c meta h r is =
 
     m = h ^. method
     p = meta ^. protocol
-    n = meta ^. serviceConfig
 
 -- FIXME: take method into account for responses, such as HEAD etc, particuarly
 -- when the body might be totally empty.

lib/amazonka-core/amazonka-core.cabal

@@ -1,16 +1,16 @@
-cabal-version:      2.2
-name:               amazonka-core
-version:            2.0
-synopsis:           Core data types and functionality for Amazonka libraries.
-homepage:           https://github.com/brendanhay/amazonka
-bug-reports:        https://github.com/brendanhay/amazonka/issues
-license:            MPL-2.0
-license-file:       LICENSE
-author:             Brendan Hay
-maintainer:         Brendan Hay <brendan.g.hay+amazonka@gmail.com>
-copyright:          Copyright (c) 2013-2021 Brendan Hay
-category:           AWS
-build-type:         Simple
+cabal-version: 2.2
+name:          amazonka-core
+version:       2.0
+synopsis:      Core data types and functionality for Amazonka libraries.
+homepage:      https://github.com/brendanhay/amazonka
+bug-reports:   https://github.com/brendanhay/amazonka/issues
+license:       MPL-2.0
+license-file:  LICENSE
+author:        Brendan Hay
+maintainer:    Brendan Hay <brendan.g.hay+amazonka@gmail.com>
+copyright:     Copyright (c) 2013-2021 Brendan Hay
+category:      AWS
+build-type:    Simple
 description:
   Core data types and serialisation primitives for Amazonka related Amazon Web Service SDKs.
   .
@@ -99,22 +99,22 @@ library
     Amazonka.Waiter
 
   build-depends:
-    , aeson                 ^>=1.5.0.0 || >=2.0 && <2.2
+    , aeson                 ^>=1.5.0.0 || >=2.0 && <2.1 || ^>=2.1
     , attoparsec            >=0.11.3
     , bytestring            >=0.10.8
     , case-insensitive      >=1.2
     , conduit               >=1.3
     , conduit-extra         >=1.3
-    , containers            >=0.5     && < 0.7
+    , containers            >=0.5      && <0.7
     , cryptonite            >=0.25
     , deepseq               >=1.4
     , hashable              >=1.2
-    , http-client           >=0.5     && <0.8
-    , http-conduit          >=2.3     && <3
+    , http-client           >=0.5      && <0.8
+    , http-conduit          >=2.3      && <3
     , http-types            >=0.12
     , lens                  >=4.14
     , memory                >=0.6
-    , mtl                   >=2.2     && <2.4
+    , mtl                   >=2.2      && <2.4
     , regex-posix           >=0.96
     , resourcet             >=1.1
     , scientific            >=0.3

lib/amazonka-core/src/Amazonka/Request.hs

@@ -42,7 +42,7 @@ module Amazonka.Request
 where
 
 import Amazonka.Core
-import Amazonka.Lens ((%~), (.~))
+import Amazonka.Lens ((%~), (.~), (^.))
 import Amazonka.Prelude
 import qualified Data.ByteString.Char8 as B8
 import qualified Network.HTTP.Client as Client
@@ -167,10 +167,19 @@ glacierVersionHeader version rq =
   rq {_requestHeaders = hdr "x-amz-glacier-version" version (_requestHeaders rq)}
 
 -- Rewrite a request to use virtual-hosted-style buckets where
--- possible.  A request to endpoint "s3.region.amazonaws.com" with
--- path "/foo/bar" means "object bar in bucket foo". Rewrite it to
--- endpoint "foo.s3.region.amazonaws.com" and path "/bar".
+-- possible and requested.
 --
+-- Example: A request to endpoint "s3.region.amazonaws.com" with path
+-- "/foo/bar" means "object bar in bucket foo". Rewrite it to endpoint
+-- "foo.s3.region.amazonaws.com" and path "/bar".
+--
+-- This is basically the logic in
+-- https://github.com/boto/botocore/blob/04d1fae43b657952e49b21d16daa86378ddb4253/botocore/utils.py#L1922-L1941
+-- except that we can't tell if an endpoint has been overridden, as a
+-- 'Request' contains a 'Service' after all overrides have been
+-- applied.
+--
+-- See: https://boto3.amazonaws.com/v1/documentation/api/1.9.42/guide/s3.html#changing-the-addressing-style
 -- See: https://docs.aws.amazon.com/AmazonS3/latest/userguide/VirtualHosting.html
 s3vhost :: Request a -> Request a
 s3vhost rq = case _requestPath rq of
@@ -186,7 +195,12 @@ s3vhost rq = case _requestPath rq of
           | bucketNameLen < 3 || bucketNameLen > 63 = False
           | not $ bucketName =~ ("^[a-z0-9][a-z0-9\\-]*[a-z0-9]$" :: ByteString) = False
           | otherwise = True
-     in if rewritePossible
+
+        doRewrite = case rq ^. requestService . serviceS3AddressingStyle of
+          S3AddressingStyleAuto -> rewritePossible
+          S3AddressingStylePath -> False
+          S3AddressingStyleVirtual -> True
+     in if doRewrite
           then
             rq
               & requestService . serviceEndpoint . endpointHost %~ ((bucketName <> ".") <>)

lib/amazonka-core/src/Amazonka/Types.hs

@@ -36,10 +36,12 @@ module Amazonka.Types
     Abbrev,
     Service (..),
     serviceSigner,
+    serviceS3AddressingStyle,
     serviceEndpoint,
     serviceTimeout,
     serviceCheck,
     serviceRetry,
+    S3AddressingStyle (..),
 
     -- * Requests
     AWSRequest (..),
@@ -147,10 +149,10 @@ import Control.Monad.Trans.Resource (ResourceT)
 import Data.Conduit (ConduitM)
 import Data.IORef (IORef, readIORef)
 import qualified Data.Text as Text
+import Data.Time (defaultTimeLocale, formatTime, parseTimeM)
 import qualified Network.HTTP.Client as Client
 import Network.HTTP.Types.Method (StdMethod)
 import Network.HTTP.Types.Status (Status)
-import Data.Time (defaultTimeLocale, parseTimeM, formatTime)
 
 -- | A convenience alias to avoid type ambiguity.
 type ClientRequest = Client.Request
@@ -447,6 +449,10 @@ data Service = Service
     _serviceSigner :: Signer,
     _serviceSigningName :: ByteString,
     _serviceVersion :: ByteString,
+    -- | Only service bindings using the s3vhost request plugin
+    -- (configured in the generator) will care about this field. It is
+    -- ignored otherwise.
+    _serviceS3AddressingStyle :: S3AddressingStyle,
     _serviceEndpointPrefix :: ByteString,
     _serviceEndpoint :: (Region -> Endpoint),
     _serviceTimeout :: (Maybe Seconds),
@@ -456,9 +462,37 @@ data Service = Service
   }
   deriving stock (Generic)
 
+-- | When to rewrite S3 requests into /virtual-hosted style/.
+--
+-- Requests to S3 can be rewritten to access buckets by setting the
+-- @Host:@ header, which allows you to point a @CNAME@ record at an
+-- Amazon S3 Bucket.
+--
+-- Non-S3 object stores usually do not support this, which is usually
+-- the only time you'll need to change this.
+--
+-- /See:/ [Virtual hosting of buckets](https://docs.aws.amazon.com/AmazonS3/latest/userguide/VirtualHosting.html)
+-- in the Amazon S3 User Guide.
+--
+-- /See:/ [Changing the Addressing Style](https://boto3.amazonaws.com/v1/documentation/api/1.9.42/guide/s3.html#changing-the-addressing-style)
+-- for the corresponding option in Boto 3.
+data S3AddressingStyle
+  = -- | Rewrite S3 request paths only if they can be expressed
+    -- as a DNS label. This is the default.
+    S3AddressingStyleAuto
+  | -- | Do not ever rewrite S3 request paths.
+    S3AddressingStylePath
+  | -- | Force virtual hosted style rewrites without checking the
+    -- bucket name.
+    S3AddressingStyleVirtual
+  deriving stock (Eq, Show, Generic)
+
 serviceSigner :: Lens' Service Signer
 serviceSigner = Lens.lens _serviceSigner (\s a -> s {_serviceSigner = a})
 
+serviceS3AddressingStyle :: Lens' Service S3AddressingStyle
+serviceS3AddressingStyle = Lens.lens _serviceS3AddressingStyle (\s a -> s {_serviceS3AddressingStyle = a})
+
 serviceEndpoint :: Setter' Service Endpoint
 serviceEndpoint = Lens.sets (\f s -> s {_serviceEndpoint = \r -> f (_serviceEndpoint s r)})
 
@@ -525,7 +559,12 @@ class AWSRequest a where
   -- | The successful, expected response associated with a request.
   type AWSResponse a :: *
 
-  request :: a -> Request a
+  -- | The AWS service where requests of this type are sent. Overrides
+  -- in an Amazonka @Env@ are applied during before assembly into a
+  -- 'Request'.
+  service :: Proxy a -> Service
+
+  request :: Service -> a -> Request a
   response ::
     MonadResource m =>
     Logger ->
@@ -825,15 +864,16 @@ instance Hashable Seconds where
   hashWithSalt salt = hashWithSalt salt . toRational . toSeconds
 
 instance FromText Seconds where
-  fromText t = maybe (Left err) (Right . Seconds)
-    $ parseTimeM False defaultTimeLocale diffTimeFormatString str
-   where
-    str = Text.unpack t
-    err =
-      "Seconds value failed to parse as expected format ("
-        <> diffTimeFormatString
-        <> "): "
-        <> str
+  fromText t =
+    maybe (Left err) (Right . Seconds) $
+      parseTimeM False defaultTimeLocale diffTimeFormatString str
+    where
+      str = Text.unpack t
+      err =
+        "Seconds value failed to parse as expected format ("
+          <> diffTimeFormatString
+          <> "): "
+          <> str
 
 instance ToText Seconds where
   toText =
@@ -846,7 +886,6 @@ instance ToText Seconds where
 -- number of seconds, %Es omits the decimal point unless padding is specified."
 --
 -- We also use 'defaultTimeLocale', which means @0.1@ and not @0,1@.
---
 diffTimeFormatString :: String
 diffTimeFormatString = "%Es"
 

lib/amazonka-core/test/Test/Amazonka/Arbitrary.hs

@@ -35,6 +35,7 @@ instance Arbitrary Service where
             _serviceSigner = v4,
             _serviceSigningName = Text.encodeUtf8 . Text.toLower $ toText abbrev,
             _serviceVersion = "2012-01-01",
+            _serviceS3AddressingStyle = S3AddressingStyleAuto,
             _serviceEndpointPrefix = Text.encodeUtf8 . Text.toLower $ toText abbrev,
             _serviceEndpoint = defaultEndpoint (svc abbrev),
             _serviceTimeout = Nothing,

lib/amazonka-s3-encryption/amazonka-s3-encryption.cabal

@@ -91,7 +91,7 @@ library
     Amazonka.S3.Encryption.Types
 
   build-depends:
-    , aeson                 ^>=1.5.0.0 || >=2.0 && <2.2
+    , aeson                 ^>=1.5.0.0 || >=2.0 && <2.1 || ^>=2.1
     , amazonka              ^>=2.0
     , amazonka-core         ^>=2.0
     , amazonka-kms          ^>=2.0
@@ -100,7 +100,7 @@ library
     , case-insensitive      >=1.2
     , conduit               >=1.3
     , cryptonite            >=0.25
-    , http-client           >=0.5     && <0.8
+    , http-client           >=0.5      && <0.8
     , lens                  >=4.14
     , memory                >=0.6
     , mtl                   >=2.1.3.1

lib/amazonka-s3-encryption/src/Amazonka/S3/Encryption/Decrypt.hs

@@ -31,7 +31,9 @@ newtype Decrypted a = Decrypted
 instance AWSRequest (Decrypt S3.GetObject) where
   type AWSResponse (Decrypt S3.GetObject) = Decrypted S3.GetObjectResponse
 
-  request (Decrypt x) = coerce (request x)
+  service _ = service (Proxy :: Proxy S3.GetObject)
+
+  request srv (Decrypt x) = coerce (request srv x)
 
   response l s p r =
     Except.runExceptT $ do

lib/amazonka-s3-encryption/src/Amazonka/S3/Encryption/Encrypt.hs

@@ -58,8 +58,10 @@ envelope = _encEnvelope
 instance AWSRequest a => AWSRequest (Encrypted a) where
   type AWSResponse (Encrypted a) = AWSResponse a
 
-  request (Encrypted x xs l e) =
-    coerce (request x)
+  service _ = service (Proxy :: Proxy a)
+
+  request srv (Encrypted x xs l e) =
+    coerce (request srv x)
       & requestBody %~ f
       & requestHeaders <>~ hs
     where

lib/amazonka-s3-encryption/src/Amazonka/S3/Encryption/Instructions.hs

@@ -64,8 +64,10 @@ piExtension = Lens.lens _piExt (\s a -> s {_piExt = a})
 instance AWSRequest PutInstructions where
   type AWSResponse PutInstructions = S3.PutObjectResponse
 
-  request x =
-    coerce . request $
+  service _ = service (Proxy :: Proxy S3.PutObject)
+
+  request srv x =
+    coerce . request srv $
       _piPut x & S3.putObject_key %~ appendExtension (_piExt x)
 
   response s l _ = response s l (Proxy :: Proxy S3.PutObject)
@@ -88,8 +90,10 @@ giExtension = Lens.lens _giExt (\s a -> s {_giExt = a})
 instance AWSRequest GetInstructions where
   type AWSResponse GetInstructions = Instructions
 
-  request x =
-    coerce . request $
+  service _ = service (Proxy :: Proxy S3.GetObject)
+
+  request srv x =
+    coerce . request srv $
       _giGet x & S3.getObject_key %~ appendExtension (_giExt x)
 
   response =
@@ -129,8 +133,10 @@ diExtension = Lens.lens _diExt (\s a -> s {_diExt = a})
 instance AWSRequest DeleteInstructions where
   type AWSResponse DeleteInstructions = S3.DeleteObjectResponse
 
-  request x =
-    coerce . request $
+  service _ = service (Proxy :: Proxy S3.DeleteObject)
+
+  request srv x =
+    coerce . request srv $
       _diDelete x & S3.deleteObject_key %~ appendExtension (_diExt x)
 
   response s l _ = response s l (Proxy :: Proxy S3.DeleteObject)

lib/amazonka-test/src/Test/Amazonka/Fixture.hs

@@ -52,6 +52,7 @@ res n f s p e =
       >>= assertDiff f e
 
 req ::
+  forall a.
   (AWSRequest a, Eq a, Show a) =>
   TestName ->
   FilePath ->
@@ -63,7 +64,8 @@ req n f e = testCase n $ do
   assertDiff f e' (first show a)
   where
     expected = do
-      let x = signedRequest (requestSign (request e) auth NorthVirginia time)
+      let srv = service (Proxy :: Proxy a)
+          x = signedRequest (requestSign (request srv e) auth NorthVirginia time)
       b <- sink (Client.requestBody x)
       return
         $! mkReq