diff --git a/amazonka-core.cabal b/amazonka-core.cabal --- a/amazonka-core.cabal +++ b/amazonka-core.cabal @@ -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 diff --git a/src/Network/AWS/Data/Headers.hs b/src/Network/AWS/Data/Headers.hs --- a/src/Network/AWS/Data/Headers.hs +++ b/src/Network/AWS/Data/Headers.hs @@ -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" diff --git a/src/Network/AWS/Data/Log.hs b/src/Network/AWS/Data/Log.hs --- a/src/Network/AWS/Data/Log.hs +++ b/src/Network/AWS/Data/Log.hs @@ -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)) , "}" ] diff --git a/src/Network/AWS/Data/Path.hs b/src/Network/AWS/Data/Path.hs --- a/src/Network/AWS/Data/Path.hs +++ b/src/Network/AWS/Data/Path.hs @@ -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) diff --git a/src/Network/AWS/Data/Text.hs b/src/Network/AWS/Data/Text.hs --- a/src/Network/AWS/Data/Text.hs +++ b/src/Network/AWS/Data/Text.hs @@ -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 diff --git a/src/Network/AWS/Endpoint.hs b/src/Network/AWS/Endpoint.hs --- a/src/Network/AWS/Endpoint.hs +++ b/src/Network/AWS/Endpoint.hs @@ -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 diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs --- a/src/Network/AWS/Error.hs +++ b/src/Network/AWS/Error.hs @@ -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 diff --git a/src/Network/AWS/Prelude.hs b/src/Network/AWS/Prelude.hs --- a/src/Network/AWS/Prelude.hs +++ b/src/Network/AWS/Prelude.hs @@ -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 .!@ diff --git a/src/Network/AWS/Request.hs b/src/Network/AWS/Request.hs --- a/src/Network/AWS/Request.hs +++ b/src/Network/AWS/Request.hs @@ -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 diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs --- a/src/Network/AWS/Response.hs +++ b/src/Network/AWS/Response.hs @@ -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 diff --git a/src/Network/AWS/Sign/V2.hs b/src/Network/AWS/Sign/V2.hs --- a/src/Network/AWS/Sign/V2.hs +++ b/src/Network/AWS/Sign/V2.hs @@ -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) diff --git a/src/Network/AWS/Sign/V4.hs b/src/Network/AWS/Sign/V4.hs --- a/src/Network/AWS/Sign/V4.hs +++ b/src/Network/AWS/Sign/V4.hs @@ -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) diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs --- a/src/Network/AWS/Types.hs +++ b/src/Network/AWS/Types.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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" diff --git a/test/Test/AWS/Arbitrary.hs b/test/Test/AWS/Arbitrary.hs --- a/test/Test/AWS/Arbitrary.hs +++ b/test/Test/AWS/Arbitrary.hs @@ -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 diff --git a/test/Test/AWS/Sign/V4.hs b/test/Test/AWS/Sign/V4.hs --- a/test/Test/AWS/Sign/V4.hs +++ b/test/Test/AWS/Sign/V4.hs @@ -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" []