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.0.1 +version: 1.1.0 synopsis: Core data types and functionality for Amazonka libraries. homepage: https://github.com/brendanhay/amazonka license: OtherLicense @@ -119,6 +119,7 @@ , Test.AWS.Data.Maybe , Test.AWS.Data.Numeric , Test.AWS.Data.Time + , Test.AWS.Error , Test.AWS.Sign.V4 , Test.AWS.Util 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 @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fsimpl-tick-factor=110 #-} + -- | -- Module : Network.AWS.Data.Log -- Copyright : (c) 2013-2015 Brendan Hay @@ -130,6 +132,7 @@ , " query = " <> build (queryString x) , " method = " <> build (method x) , " timeout = " <> build (responseTimeout x) + , " body = " <> build (requestBody x) , "}" ] diff --git a/src/Network/AWS/Data/XML.hs b/src/Network/AWS/Data/XML.hs --- a/src/Network/AWS/Data/XML.hs +++ b/src/Network/AWS/Data/XML.hs @@ -57,10 +57,7 @@ xs -> XOne . NodeElement $ mkElement n xs decodeXML :: FromXML a => LazyByteString -> Either String a -decodeXML = either failure success . parseLBS def - where - failure = Left . show - success = parseXML . elementNodes . documentRoot +decodeXML = first show . parseLBS def >=> parseXML . elementNodes . documentRoot -- The following is taken from xml-conduit.Text.XML which uses -- unsafePerformIO anyway, with the following caveat: @@ -191,23 +188,52 @@ withElement :: Text -> ([Node] -> Either String a) -> [Node] -> Either String a withElement n f = findElement n >=> f +-- | Find a specific named NodeElement, at the current depth in the node tree. +-- +-- Fails if absent. findElement :: Text -> [Node] -> Either String [Node] -findElement n ns = - maybe (Left missing) Right . listToMaybe $ mapMaybe (childNodesOf n) ns +findElement n ns = missingElement n ns + . listToMaybe + $ mapMaybe (childNodesOf n) ns + +-- | Find the first specific named NodeElement, at any depth in the node tree. +-- +-- Fails if absent. +firstElement :: Text -> [Node] -> Either String [Node] +firstElement n ns = missingElement n ns + . listToMaybe + $ mapMaybe go ns where - missing = "unable to find element " - ++ show n - ++ " in nodes " - ++ show (mapMaybe localName ns) + go (NodeElement e) + | n == nameLocalName (elementName e) + = Just (elementNodes e) + | otherwise = listToMaybe $ mapMaybe go (elementNodes e) + go _ = Nothing childNodesOf :: Text -> Node -> Maybe [Node] childNodesOf n x = case x of NodeElement e - | Just n' <- localName x - , n == n' -> Just (elementNodes e) - _ -> Nothing + | Just n == localName x + -> Just (elementNodes e) + _ -> Nothing localName :: Node -> Maybe Text localName = \case NodeElement e -> Just (nameLocalName (elementName e)) _ -> Nothing + +-- | An inefficient mechanism for retreiving the root +-- element name of an XML document. +rootElementName :: LazyByteString -> Maybe Text +rootElementName bs = + either (const Nothing) + (Just . nameLocalName . elementName . documentRoot) + (parseLBS def bs) + +missingElement :: Text -> [Node] -> Maybe a -> Either String a +missingElement n ns = maybe (Left err) Right + where + err = "unable to find element " + ++ show n + ++ " in nodes " + ++ show (mapMaybe localName ns) 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 @@ -109,17 +109,18 @@ -> Error parseXMLError a s h bs = decodeError a s h bs (decodeXML bs >>= go) where - go x = do - (c, m, r) <- xml x <|> ec2 x - return $! serviceError a s h c m r + go x = serviceError a s h + <$> code x + <*> may (firstElement "Message" x) + <*> may (firstElement "RequestId" x <|> firstElement "RequestID" x) - xml x = withElement "Error" (gen x) x <|> gen x x - ec2 x = withElement "Errors" (gen x) x + code x = Just <$> (firstElement "Code" x >>= parseXML) + <|> return root - gen x y = (,,) - <$> y .@? "Code" - <*> y .@? "Message" - <*> x .@? "RequestId" + root = ErrorCode <$> rootElementName bs + + may (Left _) = pure Nothing + may (Right x) = Just <$> parseXML x parseRESTError :: Abbrev -> Status 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 @@ -156,10 +156,12 @@ { Client.method = toBS (metaMethod meta) , Client.host = _endpointHost (metaEndpoint meta) , Client.path = toBS (metaPath meta) - , Client.queryString = '?' `BS8.cons` toBS (metaCanonicalQuery meta) + , Client.queryString = if BS8.null qbs then qbs else '?' `BS8.cons` qbs , Client.requestHeaders = metaHeaders meta , Client.requestBody = metaBody meta } + where + qbs = toBS (metaCanonicalQuery meta) sign :: AuthEnv -> Region 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 @@ -25,38 +25,38 @@ ( -- * Authentication -- ** Credentials - AccessKey (..) - , SecretKey (..) - , SessionToken (..) + AccessKey (..) + , SecretKey (..) + , SessionToken (..) -- ** Environment - , AuthEnv (..) - , Auth (..) + , AuthEnv (..) + , Auth (..) , withAuth -- * Logging - , LogLevel (..) + , LogLevel (..) , Logger -- * Services , Abbrev - , AWSService (..) - , Service (..) + , AWSService (..) + , Service (..) , serviceOf -- * Retries - , Retry (..) + , Retry (..) -- * Signing - , AWSSigner (..) - , AWSPresigner (..) + , AWSSigner (..) + , AWSPresigner (..) , Meta - , Signed (..) + , Signed (..) , sgMeta , sgRequest -- * Requests - , AWSRequest (..) - , Request (..) + , AWSRequest (..) + , Request (..) , rqMethod , rqHeaders , rqPath @@ -67,17 +67,17 @@ , Response -- * Errors - , AsError (..) - , Error (..) + , AsError (..) + , Error (..) -- ** HTTP Errors , HttpException -- ** Serialize Errors - , SerializeError (..) + , SerializeError (..) , serializeAbbrev , serializeStatus , serializeMessage -- ** Service Errors - , ServiceError (..) + , ServiceError (..) , serviceAbbrev , serviceStatus , serviceHeaders @@ -85,13 +85,13 @@ , serviceMessage , serviceRequestId -- ** Error Types - , ErrorCode (..) - , ErrorMessage (..) - , RequestId (..) + , ErrorCode (..) + , ErrorMessage (..) + , RequestId (..) -- * Regions - , Endpoint (..) - , Region (..) + , Endpoint (..) + , Region (..) -- * HTTP , ClientRequest @@ -208,7 +208,7 @@ [ "[SerializeError] {" , " service = " <> build _serializeAbbrev , " status = " <> build _serializeStatus - , " build = " <> build _serializeMessage + , " message = " <> build _serializeMessage , "}" ] @@ -236,7 +236,7 @@ , " service = " <> build _serviceAbbrev , " status = " <> build _serviceStatus , " code = " <> build _serviceCode - , " build = " <> build _serviceMessage + , " message = " <> build _serviceMessage , " request-id = " <> build _serviceRequestId , "}" ] @@ -305,7 +305,7 @@ | Info -- ^ Info messages supplied by the user - this level is not emitted by the library. | Debug -- ^ Useful debug information + info + error levels. | Trace -- ^ Includes potentially sensitive signing metadata, and non-streaming response bodies. - deriving (Eq, Ord, Enum, Show) + deriving (Eq, Ord, Enum, Show, Data, Typeable) -- | A function threaded through various request and serialisation routines -- to log informational and debug messages. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -15,6 +15,7 @@ import qualified Test.AWS.Data.Maybe as Maybe import qualified Test.AWS.Data.Numeric as Numeric import qualified Test.AWS.Data.Time as Time +import qualified Test.AWS.Error as Error import qualified Test.AWS.Sign.V4 as V4 import Test.Tasty @@ -35,4 +36,6 @@ , testGroup "signing" [ V4.tests ] + + , Error.tests ] diff --git a/test/Test/AWS/Error.hs b/test/Test/AWS/Error.hs new file mode 100644 --- /dev/null +++ b/test/Test/AWS/Error.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Test.AWS.Error +-- Copyright : (c) 2013-2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +module Test.AWS.Error (tests) where + +import Control.Lens +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Foldable as Fold +import Data.List (sort) +import Data.Monoid +import Data.String +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Network.AWS.Error +import Network.AWS.Prelude +import Test.AWS.Arbitrary () +import Test.QuickCheck.Property +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "errors" + [ testGroup "xml" + [ testCase "ec2" $ xmlError ec2 + "VolumeInUse" + "vol-8c8cea98 is already attached to an instance" + "c0ca7700-c515-4653-87e3-f1a9ce6416e8" + + , testCase "route53" $ xmlError route53 + "InvalidChangeBatch" + "Tried to delete resource record set noexist.example.com. type A,but it was not found" + "default_rid" + + , testCase "sqs" $ xmlError sqs + "InvalidParameterValue" + "Value (quename_nonalpha) for parameter QueueName is invalid. Must be an alphanumeric String of 1 to 80 in length" + "42d59b56-7407-4c4a-be0f-4c88daeea257" + ] + ] + +xmlError :: LazyByteString + -> ErrorCode + -> ErrorMessage + -> RequestId + -> Assertion +xmlError bs c m r = actual @?= Right expect + where + expect = serviceError a s h (Just c) (Just m) (Just r) + actual = + case parseXMLError a s h bs of + ServiceError e -> Right e + e -> Left $ "unexpected error: " ++ show e + + a = "Test" + s = toEnum 400 + h = [(hAMZRequestId, "default_rid")] + +-- Samples representative of differing xml errors. + +ec2 :: LazyByteString +ec2 = "VolumeInUsevol-8c8cea98 is already attached to an instancec0ca7700-c515-4653-87e3-f1a9ce6416e8" + +route53 :: LazyByteString +route53 = "Tried to delete resource record set noexist.example.com. type A,but it was not found" + +sqs :: LazyByteString +sqs = "SenderInvalidParameterValueValue (quename_nonalpha) for parameter QueueName is invalid. Must be an alphanumeric String of 1 to 80 in length42d59b56-7407-4c4a-be0f-4c88daeea257"