Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
Checking mergeability… Don’t worry, you can still create the pull request.
  • 1 commit
  • 1 file changed
  • 0 commit comments
  • 1 contributor
Showing with 37 additions and 36 deletions.
  1. +37 −36 Aws/S3/Response.hs
View
73 Aws/S3/Response.hs
@@ -10,15 +10,18 @@ import Aws.Util
import Control.Applicative
import Control.Monad.Compose.Class
import Data.Char
+import Data.Enumerator ((=$))
import Data.Maybe
import Data.Word
import Text.XML.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.Enumerator as En
+import qualified Data.Map as M
+import qualified Data.Text as T
import qualified Network.HTTP.Enumerator as HTTPE
import qualified Network.HTTP.Types as HTTP
-import qualified Text.XML.Light as XL
+import qualified Text.XML.Enumerator.Parse as XML
data S3Response a
= S3Response {
@@ -34,10 +37,10 @@ instance (S3ResponseIteratee a) => ResponseIteratee (S3Response a) where
let amzId2 = headerString "x-amz-id-2"
let requestId = headerString "x-amz-request-id"
- specific <- tryError $ if status >= HTTP.status400
- then s3ErrorResponseIteratee status headers
- else s3ResponseIteratee status headers
-
+ specific <- if status >= HTTP.status400
+ then fmap Left $ s3ErrorResponseIteratee status headers
+ else tryError $ s3ResponseIteratee status headers
+
case specific of
Left (err :: S3Error) -> En.throwError (setMetadata m err)
where m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId }
@@ -47,46 +50,44 @@ instance (S3ResponseIteratee a) => ResponseIteratee (S3Response a) where
, s3RequestId = requestId
}
-s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a
-s3ErrorResponseIteratee status headers = xmlResponseIteratee (e <<< parseXmlResponse) status headers
- where
- e :: Xml S3Error XL.Element a
- e = do
- err <- e' <<< findElementNameUI "Error"
- raise err
-
- e' = do
- code <- strContent <<< findElementNameUI "Code"
- message <- strContent <<< findElementNameUI "Message"
- resource <- tryMaybe $ strContent <<< findElementNameUI "Resource"
- hostId <- tryMaybe $ strContent <<< findElementNameUI "HostId"
- accessKeyId <- tryMaybe $ strContent <<< findElementNameUI "AWSAccessKeyId"
- stringToSignUnprocessed <- tryMaybe $ strContent <<< findElementNameUI "StringToSignBytes"
- let stringToSign = B.pack <$> (sequence . map readHex2 . words =<< stringToSignUnprocessed)
-
- return S3Error {
- s3StatusCode = status
- , s3ErrorCode = code
- , s3ErrorMessage = message
- , s3ErrorResource = resource
- , s3ErrorHostId = hostId
- , s3ErrorAccessKeyId = accessKeyId
- , s3ErrorStringToSign = stringToSign
- , s3ErrorMetadata = Nothing
- }
-
- readHex2 :: [Char] -> Maybe Word8
+s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO S3Error
+s3ErrorResponseIteratee status headers = XML.parseBytes XML.decodeEntities =$ error
+ where
+ error = XML.force "Missing / invalid Error tag" $ XML.tagNoAttr "Error" errorContents
+ errorContents = combine <$> XML.force "Invalid error tag contents" (XML.tagsPermuteRepetition id m ignoreTag)
+ ignoreTag = XML.tagPredicate (const True) XML.ignoreAttrs (\_ -> XML.ignoreSiblings >> return Nothing)
+ combine m = S3Error {
+ s3StatusCode = status
+ , s3ErrorMetadata = Nothing
+ , s3ErrorCode = fromJust $ lookup "Code" m
+ , s3ErrorMessage = fromJust $ lookup "Message" m
+ , s3ErrorResource = lookup "Resource" m
+ , s3ErrorHostId = lookup "HostId" m
+ , s3ErrorAccessKeyId = lookup "AWSAccessKeyId" m
+ , s3ErrorStringToSign = B.pack <$> (sequence . map readHex2 . words =<< lookup "StringToSignBytes" m)
+ }
+ stringTag r = (r, XML.ignoreAttrs, \_ -> Just . T.unpack <$> XML.content)
+ m = M.fromList $ map (\(c, r) -> (c, stringTag r))
+ [
+ ("Code", XML.repeatOnce)
+ , ("Message", XML.repeatOnce)
+ , ("Resource", XML.repeatOptional)
+ , ("HostId", XML.repeatOptional)
+ , ("AWSAccessKeyId", XML.repeatOptional)
+ , ("StringToSignBytes", XML.repeatOptional)
+ ]
readHex2 [c1,c2] = do
n1 <- readHex1 c1
n2 <- readHex1 c2
return . fromIntegral $ n1 * 16 + n2
- readHex2 _ = Nothing
-
+ readHex2 _ = Nothing
readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0'
| c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10
| c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10
readHex1 _ = Nothing
+
+
class S3ResponseIteratee a where
s3ResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a

No commit comments for this range

Something went wrong with that request. Please try again.