amazonka-core 1.1.0 → 1.2.0

raw patch · 16 files changed

+471/−403 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• amazonka-core.cabal +1/−1
• src/Network/AWS/Data/Headers.hs +4/−0
• src/Network/AWS/Data/Log.hs +16/−13
• src/Network/AWS/Data/Path.hs +6/−2
• src/Network/AWS/Data/Text.hs +5/−5
• src/Network/AWS/Endpoint.hs +34/−7
• src/Network/AWS/Error.hs +6/−14
• src/Network/AWS/Prelude.hs +5/−3
• src/Network/AWS/Request.hs +47/−42
• src/Network/AWS/Response.hs +20/−19
• src/Network/AWS/Sign/V2.hs +42/−42
• src/Network/AWS/Sign/V4.hs +73/−61
• src/Network/AWS/Types.hs +188/−133
• test/Main.hs +5/−0
• test/Test/AWS/Arbitrary.hs +18/−0
• test/Test/AWS/Sign/V4.hs +1/−61

@@ -1,5 +1,5 @@ name:                  amazonka-core-version:               1.1.0+version:               1.2.0 synopsis:              Core data types and functionality for Amazonka libraries. homepage:              https://github.com/brendanhay/amazonka license:               OtherLicense

@@ -16,6 +16,7 @@     ( module Network.AWS.Data.Headers     , HeaderName     , Header+    , hContentType     ) where  import qualified Data.ByteString.Char8       as BS8@@ -110,3 +111,6 @@  hAMZNAuth :: HeaderName hAMZNAuth = "X-Amzn-Authorization"++hFormEncoded :: ByteString+hFormEncoded = "application/x-www-form-urlencoded; charset=utf-8"

@@ -23,6 +23,7 @@ import qualified Data.CaseInsensitive         as CI import           Data.Int import           Data.List                    (intersperse)+import           Data.Maybe import           Data.Monoid import qualified Data.Text                    as Text import qualified Data.Text.Encoding           as Text@@ -32,6 +33,7 @@ import           Data.Word import           GHC.Float import           Network.AWS.Data.ByteString+import           Network.AWS.Data.Headers import           Network.AWS.Data.Path import           Network.AWS.Data.Query import           Network.AWS.Data.Text@@ -123,25 +125,26 @@  instance ToLog Request where     build x = buildLines-        [ "[Client Request] {"-        , "  host    = " <> build (host            x)-        , "  port    = " <> build (port            x)-        , "  secure  = " <> build (secure          x)-        , "  headers = " <> build (requestHeaders  x)-        , "  path    = " <> build (path            x)-        , "  query   = " <> build (queryString     x)-        , "  method  = " <> build (method          x)-        , "  timeout = " <> build (responseTimeout x)-        , "  body    = " <> build (requestBody     x)-        , "}"+        [  "[Client Request] {"+        ,  "  host      = " <> build (host x) <> ":" <> build (port x)+        ,  "  secure    = " <> build (secure x)+        ,  "  method    = " <> build (method x)+        ,  "  target    = " <> build target+        ,  "  timeout   = " <> build (responseTimeout x)+        ,  "  redirects = " <> build (redirectCount x)+        ,  "  path      = " <> build (path            x)+        ,  "  query     = " <> build (queryString     x)+        ,  "  headers   = " <> build (requestHeaders  x)+        ,  "  body      = " <> build (requestBody     x)+        ,  "}"         ]+      where+        target = hAMZTarget `lookup` requestHeaders x  instance ToLog (Response a) where     build x = buildLines         [ "[Client Response] {"         , "  status  = " <> build (responseStatus  x)-        , "  version = " <> build (responseVersion x)         , "  headers = " <> build (responseHeaders x)-        , "  cookies = " <> build (show (responseCookieJar x))         , "}"         ]

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds          #-}-{-# LANGUAGE DefaultSignatures  #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE GADTs              #-} {-# LANGUAGE KindSignatures     #-}@@ -30,6 +29,7 @@     , collapsePath     ) where +import qualified Data.ByteString             as BS import qualified Data.ByteString.Char8       as BS8 import           Data.Monoid import           Network.AWS.Data.ByteString@@ -48,7 +48,11 @@     toPath = toBS  rawPath :: ToPath a => a -> Path 'NoEncoding-rawPath = Raw . filter (not . BS8.null) . BS8.split sep . toPath+rawPath = Raw . strip . BS8.split sep . toPath+  where+    strip (x:xs)+        | BS.null x = xs+    strip xs        = xs  data Encoding = NoEncoding | Percent     deriving (Eq, Show)

@@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports    #-} @@ -20,7 +21,6 @@     , fromTextError     , takeLowerText     , takeText-    , matchCI      -- * Serialisation     , ToText   (..)@@ -67,9 +67,6 @@ takeText :: Parser Text takeText = A.takeText -matchCI :: Text -> a -> Parser a-matchCI x y = A.asciiCI x <* A.endOfInput >> return y- class FromText a where     parser :: Parser a @@ -98,7 +95,10 @@     parser = A.signed A.rational <* A.endOfInput  instance FromText Bool where-    parser = matchCI "false" False <|> matchCI "true" True+    parser = takeLowerText >>= \case+        "true"  -> pure True+        "false" -> pure False+        e       -> fromTextError $ "Failure parsing Bool from '" <> e <> "'."  instance FromText StdMethod where     parser = do

@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}  -- | -- Module      : Network.AWS.Types@@ -12,6 +13,7 @@ -- module Network.AWS.Endpoint where +import           Control.Lens import qualified Data.CaseInsensitive        as CI import qualified Data.HashSet                as Set import           Data.Monoid@@ -20,10 +22,24 @@  import           Prelude --- | Determine the full host address and credential scope for a 'Service'+-- | A convenience function for overriding the 'Service' 'Endpoint'.+--+-- /See:/ 'serviceEndpoint'.+setEndpoint :: Bool       -- ^ Whether to use HTTPS (ie. SSL).+            -> ByteString -- ^ The hostname to connect to.+            -> Int        -- ^ The port number to connect to.+            -> Service    -- ^ The service configuration to override.+            -> Service+setEndpoint s h p = serviceEndpoint %~ addr+  where+    addr = (endpointSecure .~ s)+         . (endpointHost   .~ h)+         . (endpointPort   .~ p)++-- | Determine the full host address and credential scope -- within the specified 'Region'.-defaultEndpoint :: Service s -> Region -> Endpoint-defaultEndpoint Service{..} r = go (CI.mk _svcPrefix)+defaultEndpoint :: Service -> Region -> Endpoint+defaultEndpoint (_svcPrefix -> p) r = go (CI.mk p)   where     go = \case         "iam"@@ -66,8 +82,8 @@         "cloudfront"             | not china -> global "cloudfront.amazonaws.com" -        _   | china     -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com.cn")-            | otherwise -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com")+        _   | china     -> region (p <> "." <> reg <> ".amazonaws.com.cn")+            | otherwise -> region (p <> "." <> reg <> ".amazonaws.com")      virginia  = r == NorthVirginia     frankfurt = r == Frankfurt@@ -76,8 +92,19 @@      s3 = r `Set.member` except -    region h = Endpoint { _endpointHost = h, _endpointScope = reg }-    global h = Endpoint { _endpointHost = h, _endpointScope = "us-east-1" }+    region h = Endpoint+         { _endpointHost   = h+         , _endpointSecure = True+         , _endpointPort   = 443+         , _endpointScope  = reg+         }++    global h = Endpoint+         { _endpointHost   = h+         , _endpointSecure = True+         , _endpointPort   = 443+         , _endpointScope  = "us-east-1"+         }      reg = toBS r 

@@ -20,10 +20,9 @@ import qualified Data.ByteString.Lazy        as LBS import           Data.Maybe import           Data.Monoid-import qualified Data.Text                   as Text-import qualified Data.Text.Encoding          as Text import           Network.AWS.Data.ByteString import           Network.AWS.Data.Headers+import           Network.AWS.Data.Text import           Network.AWS.Data.XML import           Network.AWS.Types import           Network.HTTP.Client@@ -71,10 +70,9 @@  getErrorCode :: Status -> [Header] -> ErrorCode getErrorCode s h =-    fromMaybe (ErrorCode . Text.decodeUtf8 $ statusMessage s) $-        case h .# hAMZNErrorType of-            Left  _ -> Nothing-            Right t -> fmap ErrorCode . lastOf traverse $ Text.split (== '#') t+    case h .# hAMZNErrorType of+        Left  _ -> errorCode (toText (statusMessage s))+        Right x -> errorCode x  parseJSONError :: Abbrev                -> Status@@ -86,16 +84,10 @@     parse = eitherDecode' >=> parseEither (withObject "JSONError" go)      go o = do-        c <- (Just <$> o .: "__type") <|> o .:? "code"-        let e = strip <$> c+        e <- (Just <$> o .: "__type") <|> o .:? "code"         m <- msg e o         return $! serviceError a s h e m Nothing -    strip (ErrorCode x) = ErrorCode $-        case Text.break (== '#') x of-            (ns, e) | Text.null e -> ns-                    | otherwise   -> Text.drop 1 e-     msg c o =         if c == Just "RequestEntityTooLarge"             then pure (Just "Request body must be less than 1 MB")@@ -117,7 +109,7 @@     code x = Just <$> (firstElement "Code" x >>= parseXML)          <|> return root -    root = ErrorCode <$> rootElementName bs+    root = errorCode <$> rootElementName bs      may (Left  _) = pure Nothing     may (Right x) = Just <$> parseXML x

@@ -40,12 +40,14 @@ import           Network.AWS.Data.XML        as Export import           Network.AWS.Endpoint        as Export import           Network.AWS.Error           as Export-import           Network.AWS.Types           as Export hiding (AccessKey,-                                                        Endpoint, Seconds,-                                                        SecretKey) import           Network.HTTP.Types.Status   as Export (Status (..)) import           Network.HTTP.Types.URI      as Export (urlDecode, urlEncode) import           Numeric.Natural             as Export (Natural)++import           Network.AWS.Types           as Export hiding (AccessKey,+                                                        Algorithm, Endpoint,+                                                        Seconds, SecretKey,+                                                        Signer, serviceEndpoint)  infixl 7 .!@ 

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds   #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} @@ -59,62 +60,64 @@ import           Network.HTTP.Types           (StdMethod (..)) import qualified Network.HTTP.Types           as HTTP -head' :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a-head' x = get x & rqMethod .~ HEAD+type ToRequest a = (ToPath a, ToQuery a, ToHeaders a) -delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a-delete x = get x & rqMethod .~ DELETE+head' :: ToRequest a => Service -> a -> Request a+head' s x = get s x & rqMethod .~ HEAD -get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a-get = contentSHA256 . defaultRequest+delete :: ToRequest a => Service -> a -> Request a+delete s x = get s x & rqMethod .~ DELETE -post :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a-post x = get x & rqMethod .~ POST+get :: ToRequest a => Service -> a -> Request a+get s = contentSHA256 . defaultRequest s -put :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a-put x = get x & rqMethod .~ PUT+post :: ToRequest a => Service -> a -> Request a+post s x = get s x & rqMethod .~ POST -postXML :: (ToQuery a, ToPath a, ToHeaders a, ToElement a) => a -> Request a-postXML x = putXML x & rqMethod .~ POST+put :: ToRequest a => Service -> a -> Request a+put s x = get s x & rqMethod .~ PUT -postJSON :: (ToQuery a, ToPath a, ToHeaders a, ToJSON a) => a -> Request a-postJSON x = putJSON x & rqMethod .~ POST+postXML :: (ToRequest a, ToElement a) => Service -> a -> Request a+postXML s x = putXML s x & rqMethod .~ POST -postQuery :: (ToQuery a, ToPath a, ToHeaders a) => a -> Request a-postQuery x = Request-    { _rqMethod  = POST+postJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a+postJSON s x = putJSON s x & rqMethod .~ POST++postQuery :: ToRequest a => Service -> a -> Request a+postQuery s x = Request+    { _rqService = s+    , _rqMethod  = POST     , _rqPath    = rawPath x     , _rqQuery   = mempty     , _rqBody    = toBody (toQuery x)-    , _rqHeaders =-        hdr HTTP.hContentType "application/x-www-form-urlencoded; charset=utf-8"-            (toHeaders x)+    , _rqHeaders = hdr hContentType hFormEncoded (toHeaders x)     } & contentSHA256 -postBody :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) => a -> Request a-postBody x = putBody x & rqMethod .~ POST+postBody :: (ToRequest a, ToBody a) => Service -> a -> Request a+postBody s x = putBody s x & rqMethod .~ POST -putXML :: (ToPath a, ToQuery a, ToHeaders a, ToElement a) => a -> Request a-putXML x = defaultRequest x+putXML :: (ToRequest a, ToElement a) => Service -> a -> Request a+putXML s x = defaultRequest s x     & rqMethod .~ PUT     & rqBody   .~ toBody (toElement x)     & contentSHA256 -putJSON :: (ToQuery a, ToPath a, ToHeaders a, ToJSON a) => a -> Request a-putJSON x = defaultRequest x+putJSON :: (ToRequest a, ToJSON a) => Service -> a -> Request a+putJSON s x = defaultRequest s x     & rqMethod .~ PUT     & rqBody   .~ toBody (toJSON x)     & contentSHA256 -putBody :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) => a -> Request a-putBody x = defaultRequest x+putBody :: (ToRequest a, ToBody a) => Service -> a -> Request a+putBody s x = defaultRequest s x     & rqMethod .~ PUT     & rqBody   .~ toBody x     & contentSHA256 -defaultRequest :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a-defaultRequest x = Request-    { _rqMethod  = GET+defaultRequest :: ToRequest a => Service -> a -> Request a+defaultRequest s x = Request+    { _rqService = s+    , _rqMethod  = GET     , _rqPath    = rawPath x     , _rqQuery   = toQuery x     , _rqHeaders = toHeaders x@@ -142,17 +145,19 @@     f (Client.requestHeaders x) <&> \y -> x { Client.requestHeaders = y }  requestURL :: ClientRequest -> ByteString-requestURL x =-       scheme (Client.secure      x)-    <> toBS   (Client.host        x)-    <> port   (Client.port        x)-    <> toBS   (Client.path        x)-    <> toBS   (Client.queryString x)+requestURL x = scheme+    <> toBS (Client.host        x)+    <> port (Client.port        x)+    <> toBS (Client.path        x)+    <> toBS (Client.queryString x)   where-    scheme True = "https://"-    scheme _    = "http://"+    scheme+        | secure    = "https://"+        | otherwise = "http://"      port = \case-        80  -> ""-        443 -> ""-        n   -> ":" <> toBS n+        80           -> ""+        443 | secure -> ""+        n            -> ":" <> toBS n++    secure = Client.secure x

@@ -21,13 +21,14 @@ import           Data.Conduit import qualified Data.Conduit.Binary          as Conduit import           Data.Monoid+import           Data.Proxy import           Data.Text                    (Text) import           Network.AWS.Data.Body import           Network.AWS.Data.ByteString import           Network.AWS.Data.Log import           Network.AWS.Data.XML import           Network.AWS.Types-import           Network.HTTP.Client          hiding (Request, Response)+import           Network.HTTP.Client          hiding (Proxy, Request, Response) import           Network.HTTP.Types import           Text.XML                     (Node) @@ -36,8 +37,8 @@ receiveNull :: MonadResource m             => Rs a             -> Logger-            -> Service s-            -> Request a+            -> Service+            -> Proxy a             -> ClientResponse             -> m (Response a) receiveNull rs _ = receive $ \_ _ x ->@@ -46,8 +47,8 @@ receiveEmpty :: MonadResource m              => (Int -> ResponseHeaders -> () -> Either String (Rs a))              -> Logger-             -> Service s-             -> Request a+             -> Service+             -> Proxy a              -> ClientResponse              -> m (Response a) receiveEmpty f _ = receive $ \s h x ->@@ -57,8 +58,8 @@                   => Text                   -> (Int -> ResponseHeaders -> [Node] -> Either String (Rs a))                   -> Logger-                  -> Service s-                  -> Request a+                  -> Service+                  -> Proxy a                   -> ClientResponse                   -> m (Response a) receiveXMLWrapper n f = receiveXML (\s h x -> x .@ n >>= f s h)@@ -66,8 +67,8 @@ receiveXML :: MonadResource m            => (Int -> ResponseHeaders -> [Node] -> Either String (Rs a))            -> Logger-           -> Service s-           -> Request a+           -> Service+           -> Proxy a            -> ClientResponse            -> m (Response a) receiveXML = deserialise decodeXML@@ -75,8 +76,8 @@ receiveJSON :: MonadResource m             => (Int -> ResponseHeaders -> Object -> Either String (Rs a))             -> Logger-            -> Service s-            -> Request a+            -> Service+            -> Proxy a             -> ClientResponse             -> m (Response a) receiveJSON = deserialise eitherDecode'@@ -84,8 +85,8 @@ receiveBody :: MonadResource m             => (Int -> ResponseHeaders -> RsBody -> Either String (Rs a))             -> Logger-            -> Service s-            -> Request a+            -> Service+            -> Proxy a             -> ClientResponse             -> m (Response a) receiveBody f _ = receive $ \s h x -> return (f s h (RsBody x))@@ -94,8 +95,8 @@             => (LazyByteString -> Either String b)             -> (Int -> ResponseHeaders -> b -> Either String (Rs a))             -> Logger-            -> Service s-            -> Request a+            -> Service+            -> Proxy a             -> ClientResponse             -> m (Response a) deserialise g f l = receive $ \s h x -> do@@ -105,12 +106,12 @@  receive :: MonadResource m         => (Int -> ResponseHeaders -> ResponseBody -> m (Either String (Rs a)))-        -> Service s-        -> Request a+        -> Service+        -> Proxy a         -> ClientResponse         -> m (Response a)-receive f Service{..} _ rs-    | not (_svcStatus s) = sinkLBS x >>= serviceErr+receive f  Service{..} _ rs+    | not (_svcCheck s) = sinkLBS x >>= serviceErr     | otherwise          = do         p <- f (fromEnum s) h x         either serializeErr

@@ -13,13 +13,11 @@ -- Portability : non-portable (GHC extensions) -- module Network.AWS.Sign.V2-    ( V2-    , Meta (..)+    ( v2     ) where  import           Control.Applicative import qualified Data.ByteString.Char8        as BS8-import           Data.List                    (intersperse) import           Data.Monoid import           Data.Time import           Network.AWS.Data.Body@@ -36,16 +34,14 @@  import           Prelude -data V2--data instance Meta V2 = Meta+data V2 = V2     { metaTime      :: !UTCTime     , metaEndpoint  :: !Endpoint     , metaSignature :: !ByteString     } -instance ToLog (Meta V2) where-    build Meta{..} = mconcat $ intersperse "\n"+instance ToLog V2 where+    build V2{..} = buildLines         [ "[Version 2 Metadata] {"         , "  time      = " <> build metaTime         , "  endpoint  = " <> build (_endpointHost metaEndpoint)@@ -53,46 +49,50 @@         , "}"         ] -instance AWSSigner V2 where-    signed AuthEnv{..} r t Service{..} Request{..} = Signed meta rq-      where-        meta = Meta t end signature+v2 :: Signer+v2 = Signer sign' (const sign') -- FIXME: revisit v2 presigning. -        rq = clientRequest-            { Client.method         = meth-            , Client.host           = _endpointHost-            , Client.path           = path'-            , Client.queryString    = toBS authorised-            , Client.requestHeaders = headers-            , Client.requestBody    = bodyRequest _rqBody-            }+sign' :: Algorithm a+sign' Request{..} AuthEnv{..} r t = Signed meta rq+  where+    meta = Meta (V2 t end signature) -        meth  = toBS _rqMethod-        path' = toBS (escapePath _rqPath)+    rq = (clientRequest end _svcTimeout)+        { Client.method         = meth+        , Client.path           = path'+        , Client.queryString    = toBS authorised+        , Client.requestHeaders = headers+        , Client.requestBody    = bodyRequest _rqBody+        } -        end@Endpoint{..} = _svcEndpoint r+    meth  = toBS _rqMethod+    path' = toBS (escapePath _rqPath) -        authorised = pair "Signature" (urlEncode True signature) query+    end@Endpoint{..} = _svcEndpoint r -        signature = digestToBase Base64-            . hmacSHA256 (toBS _authSecret)-            $ BS8.intercalate "\n"-                [ meth-                , _endpointHost-                , path'-                , toBS query-                ]+    Service{..} = _rqService -        query =-             pair "Version"          _svcVersion-           . pair "SignatureVersion" ("2"          :: ByteString)-           . pair "SignatureMethod"  ("HmacSHA256" :: ByteString)-           . pair "Timestamp"        time-           . pair "AWSAccessKeyId"   (toBS _authAccess)-           $ _rqQuery <> maybe mempty toQuery token+    authorised = pair "Signature" (urlEncode True signature) query -        token = ("SecurityToken" :: ByteString,) . toBS <$> _authToken+    signature = digestToBase Base64+        . hmacSHA256 (toBS _authSecret)+        $ BS8.intercalate "\n"+            [ meth+            , _endpointHost+            , path'+            , toBS query+            ] -        headers = hdr hDate time _rqHeaders+    query =+         pair "Version"          _svcVersion+       . pair "SignatureVersion" ("2"          :: ByteString)+       . pair "SignatureMethod"  ("HmacSHA256" :: ByteString)+       . pair "Timestamp"        time+       . pair "AWSAccessKeyId"   (toBS _authAccess)+       $ _rqQuery <> maybe mempty toQuery token -        time = toBS (Time t :: ISO8601)+    token = ("SecurityToken" :: ByteString,) . toBS <$> _authToken++    headers = hdr hDate time _rqHeaders++    time = toBS (Time t :: ISO8601)

@@ -16,13 +16,15 @@ -- Portability : non-portable (GHC extensions) -- module Network.AWS.Sign.V4-    ( V4-    , Meta (..)+    ( V4 (..)+    , v4+    , metadata     ) where  import           Control.Applicative import           Control.Lens import           Data.Bifunctor+import qualified Data.ByteString              as BS import qualified Data.ByteString.Char8        as BS8 import qualified Data.CaseInsensitive         as CI import qualified Data.Foldable                as Fold@@ -45,9 +47,7 @@  import           Prelude -data V4--data instance Meta V4 = Meta+data V4 = V4     { metaTime             :: !UTCTime     , metaMethod           :: !Method     , metaPath             :: !Path@@ -61,10 +61,11 @@     , metaSignature        :: !Signature     , metaHeaders          :: ![Header]     , metaBody             :: Client.RequestBody+    , metaTimeout          :: !(Maybe Seconds)     } -instance ToLog (Meta V4) where-    build Meta{..} = buildLines+instance ToLog V4 where+    build V4{..} = buildLines         [ "[Version 4 Metadata] {"         , "  time              = " <> build metaTime         , "  endpoint          = " <> build (_endpointHost metaEndpoint)@@ -80,44 +81,49 @@         , "}"         ] -instance AWSPresigner V4 where-    presigned auth reg ts ex svc rq = finalise meta authorise-      where-        authorise = queryString-            <>~ ("&X-Amz-Signature=" <> toBS (metaSignature meta))+v4 :: Signer+v4 = Signer sign' presign' -        meta = sign auth reg ts svc presign digest (prepare rq)+presign' :: Seconds -> Algorithm a+presign' ex rq auth reg ts = finalise meta authorise+  where+    authorise = queryString+        <>~ ("&X-Amz-Signature=" <> toBS (metaSignature meta)) -        presign c shs =-              pair (CI.original hAMZAlgorithm)     algorithm-            . pair (CI.original hAMZCredential)    (toBS c)-            . pair (CI.original hAMZDate)          (Time ts :: AWSTime)-            . pair (CI.original hAMZExpires)       ex-            . pair (CI.original hAMZSignedHeaders) (toBS shs)-            . pair (CI.original hAMZToken)         (toBS <$> _authToken auth)+    meta = metadata auth reg ts presign digest (prepare rq) -        digest = Tag "UNSIGNED-PAYLOAD"+    presign c shs =+          pair (CI.original hAMZAlgorithm)     algorithm+        . pair (CI.original hAMZCredential)    (toBS c)+        . pair (CI.original hAMZDate)          (Time ts :: AWSTime)+        . pair (CI.original hAMZExpires)       ex+        . pair (CI.original hAMZSignedHeaders) (toBS shs)+        . pair (CI.original hAMZToken)         (toBS <$> _authToken auth) -        prepare = rqHeaders .~ []+    digest = Tag "UNSIGNED-PAYLOAD" -instance AWSSigner V4 where-    signed auth reg ts svc rq = finalise meta authorise-      where-        authorise = requestHeaders-            <>~ [(hAuthorization, authorisation meta)]+    prepare = rqHeaders .~ [] -        meta = sign auth reg ts svc presign digest (prepare rq)+sign' :: Algorithm a+sign' rq auth reg ts = finalise meta authorise+  where+    authorise = requestHeaders+        <>~ [(hAuthorization, authorisation meta)] -        presign _ _ = id+    meta = metadata auth reg ts presign digest (prepare rq) -        digest = Tag . digestToBase Base16 . bodySHA256 $ _rqBody rq+    presign _ _ = id -        prepare = rqHeaders %~-            ( hdr hHost    (_endpointHost (_svcEndpoint svc reg))-            . hdr hAMZDate (toBS (Time ts :: AWSTime))-            . maybe id (hdr hAMZToken . toBS) (_authToken auth)-            )+    digest = Tag . digestToBase Base16 . bodySHA256 $ _rqBody rq +    prepare = rqHeaders %~+        ( hdr hHost    (_endpointHost end)+        . hdr hAMZDate (toBS (Time ts :: AWSTime))+        . maybe id (hdr hAMZToken . toBS) (_authToken auth)+        )++    end = _svcEndpoint (_rqService rq) reg+ -- | Used to tag provenance. This allows keeping the same layout as -- the signing documentation, passing 'ByteString's everywhere, with -- some type guarantees.@@ -145,33 +151,36 @@ type Path              = Tag "path"               ByteString type Signature         = Tag "signature"          ByteString -authorisation :: Meta V4 -> ByteString-authorisation Meta{..} = algorithm+authorisation :: V4 -> ByteString+authorisation V4{..} = algorithm     <> " Credential="     <> toBS metaCredential     <> ", SignedHeaders=" <> toBS metaSignedHeaders     <> ", Signature="     <> toBS metaSignature -finalise :: Meta V4 -> (ClientRequest -> ClientRequest) -> Signed V4 a-finalise meta authorise = Signed meta . authorise $ clientRequest-    { Client.method         = toBS (metaMethod meta)-    , Client.host           = _endpointHost (metaEndpoint meta)-    , Client.path           = toBS (metaPath meta)-    , Client.queryString    = if BS8.null qbs then qbs else '?' `BS8.cons` qbs-    , Client.requestHeaders = metaHeaders meta-    , Client.requestBody    = metaBody meta-    }+finalise :: V4 -> (ClientRequest -> ClientRequest) -> Signed a+finalise m@V4{..} authorise = Signed (Meta m) (authorise rq)   where-    qbs = toBS (metaCanonicalQuery meta)+    rq = (clientRequest metaEndpoint metaTimeout)+        { Client.method         = toBS metaMethod+        , Client.path           = toBS metaPath+        , Client.queryString    = qry+        , Client.requestHeaders = metaHeaders+        , Client.requestBody    = metaBody+        } -sign :: AuthEnv-     -> Region-     -> UTCTime-     -> Service s-     -> (Credential -> SignedHeaders -> QueryString -> QueryString)-     -> Hash-     -> Request a-     -> Meta V4-sign auth reg ts svc presign digest rq = Meta+    qry | BS.null x = x+        | otherwise = '?' `BS8.cons` x+      where+        x = toBS metaCanonicalQuery++metadata :: AuthEnv+         -> Region+         -> UTCTime+         -> (Credential -> SignedHeaders -> QueryString -> QueryString)+         -> Hash+         -> Request a+         -> V4+metadata auth reg ts presign digest rq = V4     { metaTime             = ts     , metaMethod           = method     , metaPath             = path@@ -185,6 +194,7 @@     , metaSignature        = signature (_authSecret auth) scope sts     , metaHeaders          = _rqHeaders rq     , metaBody             = bodyRequest (_rqBody rq)+    , metaTimeout          = _svcTimeout svc     }   where     query = canonicalQuery . presign cred shs $ _rqQuery rq@@ -200,8 +210,10 @@      end    = _svcEndpoint svc reg     method = Tag . toBS $ _rqMethod rq-    path   = escapedPath svc rq+    path   = escapedPath rq +    svc    = _rqService rq+ algorithm :: ByteString algorithm = "AWS4-HMAC-SHA256" @@ -223,7 +235,7 @@ credential :: AccessKey -> CredentialScope -> Credential credential k c = Tag (toBS k <> "/" <> toBS c) -credentialScope :: Service s -> Endpoint -> UTCTime -> CredentialScope+credentialScope :: Service -> Endpoint -> UTCTime -> CredentialScope credentialScope s e t = Tag     [ toBS (Time t :: BasicTime)     , toBS (_endpointScope e)@@ -248,9 +260,9 @@        , toBS digest        ] -escapedPath :: Service s -> Request a -> Path-escapedPath s r = Tag . toBS . escapePath $-    case _svcAbbrev s of+escapedPath :: Request a -> Path+escapedPath r = Tag . toBS . escapePath $+    case _svcAbbrev (_rqService r) of         "S3" -> _rqPath r         _    -> collapsePath (_rqPath r) 

@@ -5,13 +5,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE PackageImports             #-} {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ViewPatterns               #-}  -- | -- Module      : Network.AWS.Types@@ -37,35 +33,43 @@     , LogLevel       (..)     , Logger -    -- * Services-    , Abbrev-    , AWSService     (..)-    , Service        (..)-    , serviceOf--    -- * Retries-    , Retry          (..)-     -- * Signing-    , AWSSigner      (..)-    , AWSPresigner   (..)-    , Meta+    , Algorithm+    , Meta           (..)+    , Signer         (..)     , Signed         (..)-    , sgMeta-    , sgRequest +    -- * Service+    , Abbrev+    , Service        (..)+    , serviceSigner+    , serviceEndpoint+    , serviceTimeout+    , serviceCheck+    , serviceRetry+     -- * Requests     , AWSRequest     (..)     , Request        (..)+    , rqService     , rqMethod     , rqHeaders     , rqPath     , rqQuery     , rqBody+    , rqSign+    , rqPresign      -- * Responses     , Response +    -- * Retries+    , Retry          (..)+    , exponentBase+    , exponentGrowth+    , retryAttempts+    , retryCheck+     -- * Errors     , AsError        (..)     , Error          (..)@@ -85,14 +89,21 @@     , serviceMessage     , serviceRequestId     -- ** Error Types-    , ErrorCode      (..)+    , ErrorCode+    , errorCode     , ErrorMessage   (..)     , RequestId      (..)      -- * Regions-    , Endpoint       (..)     , Region         (..) +    -- * Endpoints+    , Endpoint       (..)+    , endpointHost+    , endpointPort+    , endpointSecure+    , endpointScope+     -- * HTTP     , ClientRequest     , ClientResponse@@ -101,7 +112,6 @@      -- ** Seconds     , Seconds         (..)-    , _Seconds     , seconds     , microseconds @@ -110,38 +120,38 @@     , _Default     ) where -import           Control.Exception-import           Control.Exception.Lens       (exception) import           Control.Applicative import           Control.Concurrent           (ThreadId)+import           Control.Exception+import           Control.Exception.Lens       (exception) import           Control.Lens                 hiding (coerce) import           Control.Monad.IO.Class import           Control.Monad.Trans.Resource import           Data.Aeson                   hiding (Error) import qualified Data.ByteString              as BS import           Data.ByteString.Builder      (Builder)-import qualified Data.ByteString.Builder      as Build-import qualified Data.ByteString.Lazy.Char8   as LBS8 import           Data.Coerce import           Data.Conduit import           Data.Data                    (Data, Typeable) import           Data.Hashable import           Data.IORef+import           Data.Maybe import           Data.Monoid import           Data.Proxy import           Data.String+import qualified Data.Text                    as Text import qualified Data.Text.Encoding           as Text import           Data.Time import           GHC.Generics                 (Generic) import           Network.AWS.Data.Body-import           Network.AWS.Data.Crypto-import           Network.AWS.Data.Log import           Network.AWS.Data.ByteString+import           Network.AWS.Data.JSON+import           Network.AWS.Data.Log import           Network.AWS.Data.Path import           Network.AWS.Data.Query import           Network.AWS.Data.Text import           Network.AWS.Data.XML-import           Network.HTTP.Client          hiding (Request, Response, Proxy)+import           Network.HTTP.Client          hiding (Proxy, Request, Response) import qualified Network.HTTP.Client          as Client import           Network.HTTP.Types.Header import           Network.HTTP.Types.Method@@ -159,23 +169,36 @@ -- | A convenience alias encapsulating the common 'Response' body. type ResponseBody = ResumableSource (ResourceT IO) ByteString --- | Construct a 'ClientRequest' using common parameters such as TLS and prevent--- throwing errors when receiving erroneous status codes in respones.-clientRequest :: ClientRequest-clientRequest = def-    { Client.secure        = True-    , Client.port          = 443-    , Client.redirectCount = 0-    , Client.checkStatus   = \_ _ _ -> Nothing-    }- -- | Abbreviated service name. newtype Abbrev = Abbrev Text     deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog)  newtype ErrorCode = ErrorCode Text-    deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog)+    deriving (Eq, Ord, Show, ToText, ToLog) +instance IsString ErrorCode where fromString = errorCode . fromString+instance FromJSON ErrorCode where parseJSON  = parseJSONText "ErrorCode"+instance FromXML  ErrorCode where parseXML   = parseXMLText  "ErrorCode"++instance FromText ErrorCode where+    parser = errorCode <$> parser++-- | Construct an 'ErrorCode'.+errorCode :: Text -> ErrorCode+errorCode = ErrorCode . strip . unnamespace+  where+    -- Common suffixes are stripped since the service definitions are ambigiuous+    -- as to whether the error shape's name, or the error code is present+    -- in the response.+    strip x = fromMaybe x $+        Text.stripSuffix "Exception" x <|> Text.stripSuffix "Fault" x++    -- Removing the (potential) leading ...# namespace.+    unnamespace x =+        case Text.break (== '#') x of+            (ns, e) | Text.null e -> ns+                    | otherwise   -> Text.drop 1 e+ newtype ErrorMessage = ErrorMessage Text     deriving (Eq, Ord, Show, IsString, FromXML, FromJSON, FromText, ToText, ToLog) @@ -296,17 +319,48 @@         x              -> Left  x  data Endpoint = Endpoint-    { _endpointHost  :: ByteString-    , _endpointScope :: ByteString+    { _endpointHost   :: ByteString+    , _endpointSecure :: !Bool+    , _endpointPort   :: !Int+    , _endpointScope  :: ByteString     } deriving (Eq, Show, Data, Typeable) +endpointHost :: Lens' Endpoint ByteString+endpointHost = lens _endpointHost (\s a -> s { _endpointHost = a })++endpointSecure :: Lens' Endpoint Bool+endpointSecure = lens _endpointSecure (\s a -> s { _endpointSecure = a })++endpointPort :: Lens' Endpoint Int+endpointPort = lens _endpointPort (\s a -> s { _endpointPort = a })++endpointScope :: Lens' Endpoint ByteString+endpointScope = lens _endpointScope (\s a -> s { _endpointScope = a })+ data LogLevel-    = Error -- ^ Error messages only.-    | Info  -- ^ Info messages supplied by the user - this level is not emitted by the library.+    = Info  -- ^ Info messages supplied by the user - this level is not emitted by the library.+    | Error -- ^ Error messages only.     | Debug -- ^ Useful debug information + info + error levels.     | Trace -- ^ Includes potentially sensitive signing metadata, and non-streaming response bodies.       deriving (Eq, Ord, Enum, Show, Data, Typeable) +instance FromText LogLevel where+    parser = takeLowerText >>= \case+        "info"  -> pure Info+        "error" -> pure Error+        "debug" -> pure Debug+        "trace" -> pure Trace+        e       -> fromTextError $ "Failure parsing LogLevel from " <> e++instance ToText LogLevel where+    toText = \case+        Info  -> "info"+        Error -> "error"+        Debug -> "debug"+        Trace -> "trace"++instance ToByteString LogLevel+ -- | A function threaded through various request and serialisation routines -- to log informational and debug messages. type Logger = LogLevel -> Builder -> IO ()@@ -321,43 +375,92 @@       -- if the request should be retried.     } +exponentBase :: Lens' Retry Double+exponentBase = lens _retryBase (\s a -> s { _retryBase = a })++exponentGrowth :: Lens' Retry Int+exponentGrowth = lens _retryGrowth (\s a -> s { _retryGrowth = a })++retryAttempts :: Lens' Retry Int+retryAttempts = lens _retryAttempts (\s a -> s { _retryAttempts = a })++retryCheck :: Lens' Retry (ServiceError -> Maybe Text)+retryCheck = lens _retryCheck (\s a -> s { _retryCheck = a })++-- | Signing algorithm specific metadata.+data Meta where+    Meta :: ToLog a => a -> Meta++instance ToLog Meta where+   build (Meta m) = build m++-- | A signed 'ClientRequest' and associated metadata specific+-- to the signing algorithm, tagged with the initial request type+-- to be able to obtain the associated response, 'Rs a'.+data Signed a = Signed+    { sgMeta    :: !Meta+    , sgRequest :: !ClientRequest+    }++type Algorithm a = Request a -> AuthEnv -> Region -> UTCTime -> Signed a++data Signer = Signer+    { sgSign    :: forall a. Algorithm a+    , sgPresign :: forall a. Seconds -> Algorithm a+    }+ -- | Attributes and functions specific to an AWS service.-data Service s = Service+data Service = Service     { _svcAbbrev   :: !Abbrev-    , _svcPrefix   :: ByteString-    , _svcVersion  :: ByteString-    , _svcEndpoint :: Region -> Endpoint-    , _svcTimeout  :: Maybe Seconds-    , _svcStatus   :: Status -> Bool-    , _svcError    :: Abbrev -> Status -> [Header] -> LazyByteString -> Error-    , _svcRetry    :: Retry+    , _svcSigner   :: !Signer+    , _svcPrefix   :: !ByteString+    , _svcVersion  :: !ByteString+    , _svcEndpoint :: !(Region -> Endpoint)+    , _svcTimeout  :: !(Maybe Seconds)+    , _svcCheck    :: !(Status -> Bool)+    , _svcError    :: !(Abbrev -> Status -> [Header] -> LazyByteString -> Error)+    , _svcRetry    :: !Retry     } +serviceSigner :: Lens' Service Signer+serviceSigner = lens _svcSigner (\s a -> s { _svcSigner = a })++serviceEndpoint :: Setter' Service Endpoint+serviceEndpoint = sets (\f s -> s { _svcEndpoint = \r -> f (_svcEndpoint s r) })++serviceTimeout :: Lens' Service (Maybe Seconds)+serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a })++serviceCheck :: Lens' Service (Status -> Bool)+serviceCheck = lens _svcCheck (\s a -> s { _svcCheck = a })++serviceRetry :: Lens' Service Retry+serviceRetry = lens _svcRetry (\s a -> s { _svcRetry = a })++-- | Construct a 'ClientRequest' using common parameters such as TLS and prevent+-- throwing errors when receiving erroneous status codes in respones.+clientRequest :: Endpoint -> Maybe Seconds -> ClientRequest+clientRequest e t = def+    { Client.secure          = _endpointSecure e+    , Client.host            = _endpointHost   e+    , Client.port            = _endpointPort   e+    , Client.redirectCount   = 0+    , Client.checkStatus     = \_ _ _ -> Nothing+    , Client.responseTimeout = microseconds <$> t+    }+ -- | An unsigned request. data Request a = Request-    { _rqMethod    :: !StdMethod-    , _rqPath      :: !RawPath-    , _rqQuery     :: !QueryString-    , _rqHeaders   :: ![Header]-    , _rqBody      :: !RqBody+    { _rqService :: !Service+    , _rqMethod  :: !StdMethod+    , _rqPath    :: !RawPath+    , _rqQuery   :: !QueryString+    , _rqHeaders :: ![Header]+    , _rqBody    :: !RqBody     } -instance Show (Request a) where-    show = LBS8.unpack . Build.toLazyByteString . build--instance ToLog (Request a) where-    build Request{..} = buildLines-        [ "[Raw Request] {"-        , "  method    = "  <> build _rqMethod-        , "  path      = "  <> build (escapePath _rqPath)-        , "  query     = "  <> build _rqQuery-        , "  headers   = "  <> build _rqHeaders-        , "  body      = {"-        , "    hash    = "  <> build (digestToBase Base16 (bodySHA256 _rqBody))-        , "    payload =\n" <> build (bodyRequest _rqBody)-        , "  }"-        , "}"-        ]+rqService :: Lens' (Request a) Service+rqService = lens _rqService (\s a -> s { _rqService = a })  rqBody :: Lens' (Request a) RqBody rqBody = lens _rqBody (\s a -> s { _rqBody = a })@@ -374,70 +477,24 @@ rqQuery :: Lens' (Request a) QueryString rqQuery = lens _rqQuery (\s a -> s { _rqQuery = a }) -class AWSSigner v where-    signed :: v ~ Sg s-           => AuthEnv-           -> Region-           -> UTCTime-           -> Service s-           -> Request a-           -> Signed  v a--class AWSPresigner v where-    presigned :: v ~ Sg s-              => AuthEnv-              -> Region-              -> UTCTime-              -> Seconds-              -> Service s-              -> Request a-              -> Signed  v a---- | Signing metadata data specific to a signing algorithm.------ /Note:/ this is used for logging purposes, and is otherwise ignored.-data family Meta v :: *---- | A signed 'ClientRequest' and associated metadata specific to the signing--- algorithm that was used.-data Signed v a where-    Signed :: ToLog (Meta v)-           => { _sgMeta    :: Meta v-              , _sgRequest :: ClientRequest-              }-           -> Signed v a--sgMeta :: ToLog (Meta v) => Lens' (Signed v a) (Meta v)-sgMeta f (Signed m rq) = f m <&> \y -> Signed y rq---- Lens' specifically since 'a' cannot be substituted.-sgRequest :: Lens' (Signed v a) ClientRequest-sgRequest f (Signed m rq) = f rq <&> \y -> Signed m y--class AWSSigner (Sg a) => AWSService a where-    -- | The default signing algorithm for the service.-    type Sg a :: *--    service :: Sv p ~ a => Proxy p -> Service a+rqSign :: Algorithm a+rqSign x = sgSign (_svcSigner (_rqService x)) x -serviceOf :: forall a. AWSService (Sv a) => a -> Service (Sv a)-serviceOf = const $ service (Proxy :: Proxy a)+rqPresign :: Seconds -> Algorithm a+rqPresign ex x = sgPresign (_svcSigner (_rqService x)) ex x  type Response a = (Status, Rs a)  -- | Specify how a request can be de/serialised.-class AWSService (Sv a) => AWSRequest a where+class AWSRequest a where     -- | The successful, expected response associated with a request.     type Rs a :: * -    -- | The default sevice configuration for the request.-    type Sv a :: *-     request  :: a -> Request a     response :: MonadResource m              => Logger-             -> Service s-             -> Request a+             -> Service+             -> Proxy a              -> ClientResponse              -> m (Response a) @@ -531,8 +588,7 @@         "us-gov-west-1"      -> pure GovCloud         "fips-us-gov-west-1" -> pure GovCloudFIPS         "sa-east-1"          -> pure SaoPaulo-        e                    -> fail $-            "Failure parsing Region from " ++ show e+        e                    -> fromTextError $ "Failure parsing Region from " <> e  instance ToText Region where     toText = \case@@ -577,17 +633,16 @@         , ToText         ) -_Seconds :: Iso' Seconds Int-_Seconds = iso seconds Seconds- instance ToLog Seconds where-    build (Seconds n) = build n <> "s"+    build s = build (seconds s) <> "s"  seconds :: Seconds -> Int-seconds (Seconds n) = n+seconds (Seconds n)+    | n < 0     = 0+    | otherwise = n  microseconds :: Seconds -> Int-microseconds (Seconds n) = n * 1000000+microseconds =  (1000000 *) . seconds  _Coerce :: (Coercible a b, Coercible b a) => Iso' a b _Coerce = iso coerce coerce

@@ -14,6 +14,7 @@ import qualified Test.AWS.Data.List    as List import qualified Test.AWS.Data.Maybe   as Maybe import qualified Test.AWS.Data.Numeric as Numeric+import qualified Test.AWS.Data.Path    as Path import qualified Test.AWS.Data.Time    as Time import qualified Test.AWS.Error        as Error import qualified Test.AWS.Sign.V4      as V4@@ -27,6 +28,10 @@             , Time.tests             , Base64.tests             , Maybe.tests+            ]++        , testGroup "paths"+            [ Path.tests             ]          , testGroup "collections"

@@ -18,17 +18,35 @@ import qualified Data.CaseInsensitive    as CI import           Data.String import qualified Data.Text               as Text+import qualified Data.Text.Encoding      as Text import           Data.Time import           Network.AWS.Data.Query import           Network.AWS.Prelude+import           Network.AWS.Sign.V4 import           Network.HTTP.Types import           Test.QuickCheck.Gen     as QC import qualified Test.QuickCheck.Unicode as Unicode import           Test.Tasty.QuickCheck +instance Arbitrary Service where+  arbitrary = svc <$> arbitrary+    where+      svc a = Service+        { _svcAbbrev   = a+        , _svcSigner   = v4+        , _svcPrefix   = Text.encodeUtf8 . Text.toLower $ toText a+        , _svcVersion  = "2012-01-01"+        , _svcEndpoint = defaultEndpoint (svc a)+        , _svcTimeout  = Nothing+        , _svcCheck    = const False+        , _svcError    = error "_svcError not defined."+        , _svcRetry    = error "_svcRetry not defined."+        }+ instance Arbitrary (Request ()) where     arbitrary = Request         <$> arbitrary+        <*> arbitrary         <*> arbitrary         <*> arbitrary         <*> arbitrary

@@ -37,64 +37,4 @@ --  test empty query  tests :: TestTree-tests = testGroup "v4"-    [ testGroup "canonical query"-        [ testProperty "empty" $ queryEmpty-        , testProperty "empty key values" $ queryEmptyKeyValues-        ]-    ]--queryEmpty :: Request () -> Signer -> Property-queryEmpty rq sg = property $-    mempty == toBS (metaCanonicalQuery . sign sg $ rq & rqQuery .~ mempty)--queryEmptyKeyValues :: [NonEmptyList Char] -> Property-queryEmptyKeyValues xs = property $ do-    rq <- arbitrary-    sg <- arbitrary--    let v4 = sign sg $ rq & rqQuery .~ Fold.foldMap (fromString . getNonEmpty) xs--        e  = sort $ map ((<> "=") . urlEncode True . BS8.pack . getNonEmpty) xs-        a  = BS8.split '&' . toBS $ metaCanonicalQuery v4--        m  = "Expected: " ++ show e ++ "\n" ++-              "Actual: "  ++ show a--    return . counterexample m $ e == a--newtype Signer = Signer { sign :: Request () -> Meta V4 }--instance Show Signer where-    show = const "V4"--instance Arbitrary Signer where-    arbitrary = do-        a   <- arbitrary-        reg <- arbitrary-        ts  <- arbitrary-        return $ Signer (_sgMeta . signed auth reg ts (testV4 a))--auth :: AuthEnv-auth = AuthEnv "access-key" "super-secret-key" Nothing Nothing--data TestV4--instance AWSService TestV4 where-    type Sg TestV4 = V4--    service = error "service not defined for TestV4."--testV4 :: Abbrev -> Service TestV4-testV4 a = svc-  where-    svc = Service-        { _svcAbbrev   = a-        , _svcPrefix   = Text.encodeUtf8 . Text.toLower $ toText a-        , _svcVersion  = "2012-01-01"-        , _svcEndpoint = defaultEndpoint svc-        , _svcTimeout  = Nothing-        , _svcStatus   = const False-        , _svcError    = error "_svcError not defined."-        , _svcRetry    = error "_svcRetry not defined."-        }+tests = testGroup "v4" []