diff --git a/Aws.hs b/Aws.hs --- a/Aws.hs +++ b/Aws.hs @@ -4,12 +4,12 @@ , module Aws.Credentials , module Aws.Debug , module Aws.Http -, module Aws.Metadata , module Aws.Query , module Aws.Response , module Aws.Signature , module Aws.Transaction , module Aws.Util +, module Aws.Xml ) where @@ -17,9 +17,9 @@ import Aws.Credentials import Aws.Debug import Aws.Http -import Aws.Metadata import Aws.Query import Aws.Response import Aws.Signature import Aws.Transaction import Aws.Util +import Aws.Xml diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -13,6 +13,10 @@ import Aws.Transaction import Control.Applicative import Control.Monad.Reader +import Data.Attempt (attemptIO) +import Data.IORef +import Data.Monoid +import qualified Control.Exception as E import qualified Data.ByteString as B import qualified Data.Enumerator as En import qualified Network.HTTP.Enumerator as HTTP @@ -87,18 +91,19 @@ instance MonadIO m => MonadAws (AwsT m) where configuration = AwsT ask -aws :: (Transaction request response - , ConfigurationFetch (Info request) +aws :: (Transaction r a + , ConfigurationFetch (Info r) , MonadAws aws) - => request -> aws response + => r -> aws (Response (ResponseMetadata a) a) aws = unsafeAws unsafeAws - :: (MonadAws m, - ResponseIteratee response, - SignQuery request, - ConfigurationFetch (Info request)) => - request -> m response + :: (MonadAws aws, + ResponseIteratee a, + Monoid (ResponseMetadata a), + SignQuery r, + ConfigurationFetch (Info r)) => + r -> aws (Response (ResponseMetadata a) a) unsafeAws request = do cfg <- configuration sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg @@ -106,7 +111,12 @@ let q = signQuery request info sd debugPrint "String to sign" $ sqStringToSign q let httpRequest = queryToHttpRequest q - liftIO $ HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest responseIteratee + liftIO $ do + metadataRef <- newIORef mempty + resp <- attemptIO (id :: E.SomeException -> E.SomeException) $ + HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest (responseIteratee metadataRef) + metadata <- readIORef metadataRef + return $ Response metadata resp awsUri :: (SignQuery request , ConfigurationFetch (Info request) diff --git a/Aws/Metadata.hs b/Aws/Metadata.hs deleted file mode 100644 --- a/Aws/Metadata.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -module Aws.Metadata -where - -class WithMetadata a m | a -> m where - getMetadata :: a -> Maybe m - setMetadata :: m -> a -> a diff --git a/Aws/Query.hs b/Aws/Query.hs --- a/Aws/Query.hs +++ b/Aws/Query.hs @@ -49,6 +49,8 @@ , HTTP.requestBody = HTTP.RequestBodyLBS $ case sqMethod of Get -> L.empty PostQuery -> Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery + , HTTP.proxy = Nothing + , HTTP.rawBody = False } where contentType = case sqMethod of PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8" diff --git a/Aws/Response.hs b/Aws/Response.hs --- a/Aws/Response.hs +++ b/Aws/Response.hs @@ -1,32 +1,40 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, DeriveFunctor, TypeFamilies #-} module Aws.Response where -import Control.Monad.Compose.Class -import Control.Monad.Error.Class -import Control.Monad.Reader.Class -import Text.XML.Monad -import qualified Control.Exception as C -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.UTF8 as BLU -import qualified Data.Enumerator as En -import qualified Network.HTTP.Enumerator as HTTP -import qualified Network.HTTP.Types as HTTP -import qualified Text.XML.Light as XL +import Data.IORef +import Data.Monoid +import Data.Attempt (Attempt(..)) +import qualified Control.Exception as E +import qualified Control.Failure as F +import qualified Data.ByteString as B +import qualified Data.Enumerator as En +import qualified Network.HTTP.Enumerator as HTTP +import qualified Network.HTTP.Types as HTTP + +data Response m a = Response m (Attempt a) + deriving (Show, Functor) +tellMetadata :: m -> Response m () +tellMetadata m = Response m (return ()) + +instance Monoid m => Monad (Response m) where + return x = Response mempty (Success x) + Response m1 (Failure e) >>= _ = Response m1 (Failure e) + Response m1 (Success x) >>= f = let Response m2 y = f x + in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too + +instance (Monoid m, E.Exception e) => F.Failure e (Response m) where + failure e = Response mempty (F.failure e) + +tellMetadataRef :: Monoid m => IORef m -> m -> IO () +tellMetadataRef r m = modifyIORef r (`mappend` m) + class ResponseIteratee a where - responseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a + type ResponseMetadata a + responseIteratee :: IORef (ResponseMetadata a) -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a instance ResponseIteratee HTTP.Response where - responseIteratee = HTTP.lbsIter - -xmlResponseIteratee :: C.Exception e => Xml e HTTP.Response a -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a -xmlResponseIteratee xml status headers = do - body <- HTTP.lbsIter status headers - case runXml xml body of - Left e -> En.throwError e - Right a -> return a - -parseXmlResponse :: (FromXmlError e, Error e) => Xml e HTTP.Response XL.Element -parseXmlResponse = parseXMLDoc <<< asks (BLU.toString . HTTP.responseBody) + type ResponseMetadata HTTP.Response = () + responseIteratee _ = HTTP.lbsIter diff --git a/Aws/S3/Commands/GetBucket.hs b/Aws/S3/Commands/GetBucket.hs --- a/Aws/S3/Commands/GetBucket.hs +++ b/Aws/S3/Commands/GetBucket.hs @@ -1,17 +1,26 @@ -{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings #-} +{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances #-} module Aws.S3.Commands.GetBucket where +import Aws.Response import Aws.S3.Info +import Aws.S3.Metadata import Aws.S3.Model import Aws.S3.Query +import Aws.S3.Response import Aws.Signature +import Aws.Transaction +import Aws.Xml import Control.Applicative -import Control.Arrow (second) -import Data.ByteString.Char8 ({- IsString -}) +import Control.Arrow (second) +import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe -import qualified Data.ByteString.UTF8 as BU -import qualified Network.HTTP.Types as HTTP +import Text.XML.Enumerator.Cursor (($/), (&|), (&//)) +import qualified Data.ByteString.UTF8 as BU +import qualified Data.Text as T +import qualified Data.Traversable +import qualified Network.HTTP.Types as HTTP +import qualified Text.XML.Enumerator.Cursor as Cu data GetBucket = GetBucket { @@ -33,8 +42,8 @@ , gbPrefix = Nothing } -data GetBucketResult - = GetBucketResult { +data GetBucketResponse + = GetBucketResponse { gbrName :: Bucket , gbrDelimiter :: Maybe String , gbrMarker :: Maybe String @@ -57,3 +66,27 @@ , ("prefix",) <$> gbPrefix ] } + +instance ResponseIteratee GetBucketResponse where + type ResponseMetadata GetBucketResponse = S3Metadata + + responseIteratee = s3XmlResponseIteratee parse + where parse cursor + = do name <- force "Missing Name" $ cursor $/ elCont "Name" + let delimiter = listToMaybe $ cursor $/ elCont "Delimiter" + let marker = listToMaybe $ cursor $/ elCont "Marker" + maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elCont "MaxKeys" &| readInt + let prefix = listToMaybe $ cursor $/ elCont "Prefix" + contents <- sequence $ cursor $/ Cu.laxElement "Contents" &| parseObjectInfo + let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content &| T.unpack + return GetBucketResponse{ + gbrName = name + , gbrDelimiter = delimiter + , gbrMarker = marker + , gbrMaxKeys = maxKeys + , gbrPrefix = prefix + , gbrContents = contents + , gbrCommonPrefixes = commonPrefixes + } + +instance Transaction GetBucket GetBucketResponse diff --git a/Aws/S3/Commands/GetService.hs b/Aws/S3/Commands/GetService.hs --- a/Aws/S3/Commands/GetService.hs +++ b/Aws/S3/Commands/GetService.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-} module Aws.S3.Commands.GetService where import Aws.Response -import Aws.S3.Error import Aws.S3.Info +import Aws.S3.Metadata import Aws.S3.Model import Aws.S3.Query import Aws.S3.Response import Aws.Signature import Aws.Transaction -import Control.Monad.Compose.Class +import Aws.Xml +import Data.Maybe import Data.Time.Format import System.Locale -import Text.XML.Monad -import qualified Text.XML.Light as XL +import Text.XML.Enumerator.Cursor (($/), ($//), (&|)) +import qualified Text.XML.Enumerator.Cursor as Cu data GetService = GetService @@ -25,25 +26,24 @@ } deriving (Show) -instance S3ResponseIteratee GetServiceResponse where - s3ResponseIteratee = xmlResponseIteratee $ parse <<< parseXmlResponse +instance ResponseIteratee GetServiceResponse where + type ResponseMetadata GetServiceResponse = S3Metadata + + responseIteratee = s3XmlResponseIteratee parse where - parse :: Xml S3Error XL.Element GetServiceResponse - parse = do - owner <- parseUserInfo <<< findElementNameUI "Owner" - buckets <- inList parseBucket <<< findElementsNameUI "Bucket" - + parse el = do + owner <- forceM "Missing Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo + buckets <- sequence $ el $// Cu.laxElement "Bucket" &| parseBucket return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets } - parseBucket = do - name <- strContent <<< findElementNameUI "Name" - creationDateString <- strContent <<< findElementNameUI "CreationDate" - creationDate <- maybeRaiseXml (EncodingError "Invalid date encoding") $ - parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString + parseBucket el = do + name <- force "Missing owner Name" $ el $/ elCont "Name" + creationDateString <- force "Missing owner CreationDate" $ el $/ elCont "CreationDate" + creationDate <- force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString return BucketInfo { bucketName = name, bucketCreationDate = creationDate } instance SignQuery GetService where type Info GetService = S3Info signQuery GetService = s3SignQuery S3Query { s3QBucket = Nothing, s3QSubresources = [], s3QQuery = [] } -instance Transaction GetService (S3Response GetServiceResponse) +instance Transaction GetService GetServiceResponse diff --git a/Aws/S3/Error.hs b/Aws/S3/Error.hs --- a/Aws/S3/Error.hs +++ b/Aws/S3/Error.hs @@ -1,15 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, RecordWildCards #-} module Aws.S3.Error where -import Aws.Metadata -import Aws.S3.Metadata -import Control.Monad.Error.Class import Data.Typeable -import Text.XML.Monad -import qualified Control.Exception as C -import qualified Data.ByteString as B -import qualified Network.HTTP.Types as HTTP +import qualified Control.Exception as C +import qualified Data.ByteString as B +import qualified Network.HTTP.Types as HTTP type ErrorCode = String @@ -22,26 +18,7 @@ , s3ErrorHostId :: Maybe String -- Error/HostId , s3ErrorAccessKeyId :: Maybe String -- Error/AWSAccessKeyId , s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding) - , s3ErrorMetadata :: Maybe S3Metadata } - | S3XmlError { - fromS3XmlError :: XmlError - , s3XmlErrorMetadata :: Maybe S3Metadata - } deriving (Show, Typeable) instance C.Exception S3Error - -instance FromXmlError S3Error where - fromXmlError = flip S3XmlError Nothing - -instance Error S3Error where - noMsg = fromXmlError noMsg - strMsg = fromXmlError . strMsg - -instance WithMetadata S3Error S3Metadata where - getMetadata S3Error { s3ErrorMetadata = m } = m - getMetadata S3XmlError { s3XmlErrorMetadata = m } = m - - setMetadata m a@S3Error{} = a { s3ErrorMetadata = Just m } - setMetadata m a@S3XmlError{} = a { s3XmlErrorMetadata = Just m } diff --git a/Aws/S3/Info.hs b/Aws/S3/Info.hs --- a/Aws/S3/Info.hs +++ b/Aws/S3/Info.hs @@ -3,7 +3,6 @@ where import Aws.Http -import Aws.S3.Model import Data.Time import qualified Data.ByteString as B @@ -12,74 +11,45 @@ | S3AuthorizationQuery deriving (Show) -data Endpoint - = Endpoint { - endpointHost :: B.ByteString - , endpointDefaultLocationConstraint :: LocationConstraint - , endpointAllowedLocationConstraints :: [LocationConstraint] - } +data RequestStyle + = PathStyle + | BucketStyle + | VHostStyle deriving (Show) data S3Info = S3Info { s3Protocol :: Protocol - , s3Endpoint :: Endpoint + , s3Endpoint :: B.ByteString + , s3RequestStyle :: RequestStyle , s3Port :: Int , s3UseUri :: Bool , s3DefaultExpiry :: NominalDiffTime } deriving (Show) -s3EndpointUsClassic :: Endpoint -s3EndpointUsClassic - = Endpoint { - endpointHost = "s3.amazonaws.com" - , endpointDefaultLocationConstraint = locationUsClassic - , endpointAllowedLocationConstraints = [locationUsClassic - , locationUsWest - , locationEu - , locationApSouthEast - , locationApNorthEast] - } +s3EndpointUsClassic :: B.ByteString +s3EndpointUsClassic = "s3.amazonaws.com" -s3EndpointUsWest :: Endpoint -s3EndpointUsWest - = Endpoint { - endpointHost = "s3-us-west-1.amazonaws.com" - , endpointDefaultLocationConstraint = locationUsWest - , endpointAllowedLocationConstraints = [locationUsWest] - } +s3EndpointUsWest :: B.ByteString +s3EndpointUsWest = "s3-us-west-1.amazonaws.com" -s3EndpointEu :: Endpoint -s3EndpointEu - = Endpoint { - endpointHost = "s3-eu-west-1.amazonaws.com" - , endpointDefaultLocationConstraint = locationEu - , endpointAllowedLocationConstraints = [locationEu] - } +s3EndpointEu :: B.ByteString +s3EndpointEu = "s3-eu-west-1.amazonaws.com" -s3EndpointApSouthEast :: Endpoint -s3EndpointApSouthEast - = Endpoint { - endpointHost = "s3-ap-southeast-1.amazonaws.com" - , endpointDefaultLocationConstraint = locationApSouthEast - , endpointAllowedLocationConstraints = [locationApSouthEast] - } +s3EndpointApSouthEast :: B.ByteString +s3EndpointApSouthEast = "s3-ap-southeast-1.amazonaws.com" -s3EndpointApNorthEast :: Endpoint -s3EndpointApNorthEast - = Endpoint { - endpointHost = "s3-ap-northeast-1.amazonaws.com" - , endpointDefaultLocationConstraint = locationApNorthEast - , endpointAllowedLocationConstraints = [locationApNorthEast] - } +s3EndpointApNorthEast :: B.ByteString +s3EndpointApNorthEast = "s3-ap-northeast-1.amazonaws.com" -s3 :: Protocol -> Endpoint -> Bool -> S3Info +s3 :: Protocol -> B.ByteString -> Bool -> S3Info s3 protocol endpoint uri = S3Info { - s3Protocol = protocol - , s3Endpoint = endpoint - , s3Port = defaultPort protocol - , s3UseUri = uri - , s3DefaultExpiry = 15*60 - } + s3Protocol = protocol + , s3Endpoint = endpoint + , s3RequestStyle = BucketStyle + , s3Port = defaultPort protocol + , s3UseUri = uri + , s3DefaultExpiry = 15*60 + } diff --git a/Aws/S3/Metadata.hs b/Aws/S3/Metadata.hs --- a/Aws/S3/Metadata.hs +++ b/Aws/S3/Metadata.hs @@ -1,9 +1,18 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Aws.S3.Metadata where + +import Control.Monad +import Data.Monoid +import Data.Typeable data S3Metadata = S3Metadata { - s3MAmzId2 :: String - , s3MRequestId :: String + s3MAmzId2 :: Maybe String + , s3MRequestId :: Maybe String } - deriving (Show) + deriving (Show, Typeable) + +instance Monoid S3Metadata where + mempty = S3Metadata Nothing Nothing + S3Metadata a1 r1 `mappend` S3Metadata a2 r2 = S3Metadata (a1 `mplus` a2) (r1 `mplus` r2) diff --git a/Aws/S3/Model.hs b/Aws/S3/Model.hs --- a/Aws/S3/Model.hs +++ b/Aws/S3/Model.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Aws.S3.Model where -import Aws.S3.Error -import Control.Monad.Compose.Class +import Aws.Xml import Data.Time -import Text.XML.Monad -import qualified Text.XML.Light as XL +import System.Locale +import Text.XML.Enumerator.Cursor (($/), (&|)) +import qualified Control.Failure as F +import qualified Text.XML.Enumerator.Cursor as Cu type CanonicalUserId = String @@ -16,11 +18,10 @@ } deriving (Show) -parseUserInfo :: Xml S3Error XL.Element UserInfo -parseUserInfo = do - id_ <- strContent <<< findElementNameUI "ID" - displayName <- strContent <<< findElementNameUI "DisplayName" - return UserInfo { userId = id_, userDisplayName = displayName } +parseUserInfo :: F.Failure XmlException m => Cu.Cursor -> m UserInfo +parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elCont "ID" + displayName <- force "Missing user DisplayName" $ el $/ elCont "DisplayName" + return UserInfo { userId = id_, userDisplayName = displayName } type Bucket = String @@ -37,14 +38,30 @@ , objectLastModified :: UTCTime , objectETag :: String , objectSize :: Integer - , objectStorageClass :: StorageClass + , objectStorageClass :: String , objectOwner :: UserInfo } deriving (Show) -data StorageClass - = StorageClassStandard - deriving (Show) +parseObjectInfo :: F.Failure XmlException m => Cu.Cursor -> m ObjectInfo +parseObjectInfo el + = do key <- force "Missing object Key" $ el $/ elCont "Key" + let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" s of + Nothing -> F.failure $ XmlException "Invalid time" + Just v -> return v + lastModified <- forceM "Missing object LastModified" $ el $/ elCont "LastModified" &| time + eTag <- force "Missing object ETag" $ el $/ elCont "ETag" + size <- forceM "Missing object Size" $ el $/ elCont "Size" &| readInt + storageClass <- force "Missing object StorageClass" $ el $/ elCont "StorageClass" + owner <- forceM "Missing object Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo + return ObjectInfo{ + objectKey = key + , objectLastModified = lastModified + , objectETag = eTag + , objectSize = size + , objectStorageClass = storageClass + , objectOwner = owner + } type LocationConstraint = String diff --git a/Aws/S3/Query.hs b/Aws/S3/Query.hs --- a/Aws/S3/Query.hs +++ b/Aws/S3/Query.hs @@ -32,9 +32,9 @@ = SignedQuery { sqMethod = method , sqProtocol = s3Protocol - , sqHost = endpointHost s3Endpoint + , sqHost = B.intercalate "." $ catMaybes host , sqPort = s3Port - , sqPath = path + , sqPath = mconcat $ catMaybes path , sqQuery = sortedSubresources ++ s3QQuery ++ authQuery , sqDate = Just signatureTime , sqAuthorization = authorization @@ -47,11 +47,15 @@ method = Get contentMd5 = Nothing contentType = Nothing - path = mconcat . catMaybes $ [Just "/", s3QBucket] + (host, path) = case s3RequestStyle of + PathStyle -> ([Just s3Endpoint], [Just "/", s3QBucket, Just "/"]) + BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/"]) + VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/"]) sortedSubresources = sort s3QSubresources canonicalizedResource = Blaze.copyByteString "/" `mappend` maybe mempty Blaze.copyByteString s3QBucket `mappend` - HTTP.renderQueryBuilder True sortedSubresources + HTTP.renderQueryBuilder True sortedSubresources `mappend` + Blaze.copyByteString "/" ti = case (s3UseUri, signatureTimeInfo) of (False, ti') -> ti' (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time diff --git a/Aws/S3/Response.hs b/Aws/S3/Response.hs --- a/Aws/S3/Response.hs +++ b/Aws/S3/Response.hs @@ -1,94 +1,82 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, RecordWildCards, TypeFamilies #-} module Aws.S3.Response where -import Aws.Metadata import Aws.Response import Aws.S3.Error import Aws.S3.Metadata -import Aws.Util -import Control.Applicative -import Control.Monad.Compose.Class +import Aws.Xml +import Control.Monad.IO.Class +import Data.Attempt (Attempt(..)) import Data.Char +import Data.Enumerator ((=$)) +import Data.IORef 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 Network.HTTP.Enumerator as HTTPE -import qualified Network.HTTP.Types as HTTP -import qualified Text.XML.Light as XL - -data S3Response a - = S3Response { - fromS3Response :: a - , s3AmzId2 :: String - , s3RequestId :: String - } - deriving (Show) +import Text.XML.Enumerator.Cursor (($/)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Enumerator as En +import qualified Network.HTTP.Types as HTTP +import qualified Text.XML.Enumerator.Cursor as Cu +import qualified Text.XML.Enumerator.Parse as XML +import qualified Text.XML.Enumerator.Resolved as XML -instance (S3ResponseIteratee a) => ResponseIteratee (S3Response a) where - responseIteratee status headers = do - let headerString = fromMaybe "" . fmap B8.unpack . flip lookup headers +s3ResponseIteratee :: + (HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a) + -> IORef S3Metadata + -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a +s3ResponseIteratee inner metadata status headers = do + let headerString = fmap B8.unpack . flip lookup headers 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 + let m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId } + liftIO $ tellMetadataRef metadata m - case specific of - Left (err :: S3Error) -> En.throwError (setMetadata m err) - where m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId } - Right resp -> return S3Response { - fromS3Response = resp - , s3AmzId2 = amzId2 - , s3RequestId = requestId - } + if status >= HTTP.status400 + then s3ErrorResponseIteratee status headers + else inner status headers -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 - } +s3XmlResponseIteratee :: + (Cu.Cursor -> Response S3Metadata a) + -> IORef S3Metadata + -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a +s3XmlResponseIteratee parse metadataRef = s3ResponseIteratee (xmlCursorIteratee parse metadataRef) metadataRef - readHex2 :: [Char] -> Maybe Word8 - readHex2 [c1,c2] = do - n1 <- readHex1 c1 - n2 <- readHex1 c2 - return . fromIntegral $ n1 * 16 + n2 - readHex2 _ = Nothing +s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a +s3ErrorResponseIteratee status _headers + = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents + let cursor = Cu.fromDocument doc + case parseError cursor of + Success err -> En.throwError err + Failure otherErr -> En.throwError otherErr + where + parseError :: Cu.Cursor -> Attempt S3Error + parseError root = do code <- force "Missing error Code" $ root $/ elCont "Code" + message <- force "Missing error Message" $ root $/ elCont "Message" + let resource = listToMaybe $ root $/ elCont "Resource" + hostId = listToMaybe $ root $/ elCont "HostId" + accessKeyId = listToMaybe $ root $/ elCont "AWSAccessKeyId" + stringToSign = do unprocessed <- listToMaybe $ root $/ elCont "StringToSignBytes" + bytes <- mapM readHex2 $ words unprocessed + return $ B.pack bytes + return S3Error { + s3StatusCode = status + , s3ErrorCode = code + , s3ErrorMessage = message + , s3ErrorResource = resource + , s3ErrorHostId = hostId + , s3ErrorAccessKeyId = accessKeyId + , s3ErrorStringToSign = stringToSign + } + where readHex2 :: [Char] -> Maybe Word8 + readHex2 [c1,c2] = do n1 <- readHex1 c1 + n2 <- readHex1 c2 + return . fromIntegral $ n1 * 16 + n2 + 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 - -instance S3ResponseIteratee HTTPE.Response where - s3ResponseIteratee = HTTPE.lbsIter + 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 diff --git a/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs b/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs --- a/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs +++ b/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs @@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.BatchDeleteAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util -import Control.Applicative -import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data BatchDeleteAttributes @@ -35,7 +35,8 @@ , ("DomainName", BU.fromString bdaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems -instance SdbFromResponse BatchDeleteAttributesResponse where - sdbFromResponse = BatchDeleteAttributesResponse <$ testElementNameUI "BatchDeleteAttributesResponse" +instance ResponseIteratee BatchDeleteAttributesResponse where + type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata + responseIteratee = sdbResponseIteratee $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" -instance Transaction BatchDeleteAttributes (SdbResponse BatchDeleteAttributesResponse) +instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse diff --git a/Aws/SimpleDb/Commands/BatchPutAttributes.hs b/Aws/SimpleDb/Commands/BatchPutAttributes.hs --- a/Aws/SimpleDb/Commands/BatchPutAttributes.hs +++ b/Aws/SimpleDb/Commands/BatchPutAttributes.hs @@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.BatchPutAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util -import Control.Applicative -import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data BatchPutAttributes @@ -35,7 +35,8 @@ , ("DomainName", BU.fromString bpaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems -instance SdbFromResponse BatchPutAttributesResponse where - sdbFromResponse = BatchPutAttributesResponse <$ testElementNameUI "BatchPutAttributesResponse" +instance ResponseIteratee BatchPutAttributesResponse where + type ResponseMetadata BatchPutAttributesResponse = SdbMetadata + responseIteratee = sdbResponseIteratee $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" -instance Transaction BatchPutAttributes (SdbResponse BatchPutAttributesResponse) +instance Transaction BatchPutAttributes BatchPutAttributesResponse diff --git a/Aws/SimpleDb/Commands/CreateDomain.hs b/Aws/SimpleDb/Commands/CreateDomain.hs --- a/Aws/SimpleDb/Commands/CreateDomain.hs +++ b/Aws/SimpleDb/Commands/CreateDomain.hs @@ -2,13 +2,13 @@ module Aws.SimpleDb.Commands.CreateDomain where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction -import Control.Applicative -import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data CreateDomain @@ -28,7 +28,8 @@ type Info CreateDomain = SdbInfo signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", BU.fromString cdDomainName)] -instance SdbFromResponse CreateDomainResponse where - sdbFromResponse = CreateDomainResponse <$ testElementNameUI "CreateDomainResponse" +instance ResponseIteratee CreateDomainResponse where + type ResponseMetadata CreateDomainResponse = SdbMetadata + responseIteratee = sdbResponseIteratee $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" -instance Transaction CreateDomain (SdbResponse CreateDomainResponse) +instance Transaction CreateDomain CreateDomainResponse diff --git a/Aws/SimpleDb/Commands/DeleteAttributes.hs b/Aws/SimpleDb/Commands/DeleteAttributes.hs --- a/Aws/SimpleDb/Commands/DeleteAttributes.hs +++ b/Aws/SimpleDb/Commands/DeleteAttributes.hs @@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.DeleteAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util -import Control.Applicative -import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data DeleteAttributes @@ -42,7 +42,8 @@ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected -instance SdbFromResponse DeleteAttributesResponse where - sdbFromResponse = DeleteAttributesResponse <$ testElementNameUI "DeleteAttributesResponse" +instance ResponseIteratee DeleteAttributesResponse where + type ResponseMetadata DeleteAttributesResponse = SdbMetadata + responseIteratee = sdbResponseIteratee $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" -instance Transaction DeleteAttributes (SdbResponse DeleteAttributesResponse) +instance Transaction DeleteAttributes DeleteAttributesResponse diff --git a/Aws/SimpleDb/Commands/DeleteDomain.hs b/Aws/SimpleDb/Commands/DeleteDomain.hs --- a/Aws/SimpleDb/Commands/DeleteDomain.hs +++ b/Aws/SimpleDb/Commands/DeleteDomain.hs @@ -2,13 +2,13 @@ module Aws.SimpleDb.Commands.DeleteDomain where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction -import Control.Applicative -import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data DeleteDomain @@ -28,7 +28,8 @@ type Info DeleteDomain = SdbInfo signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", BU.fromString ddDomainName)] -instance SdbFromResponse DeleteDomainResponse where - sdbFromResponse = DeleteDomainResponse <$ testElementNameUI "DeleteDomainResponse" +instance ResponseIteratee DeleteDomainResponse where + type ResponseMetadata DeleteDomainResponse = SdbMetadata + responseIteratee = sdbResponseIteratee $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" -instance Transaction DeleteDomain (SdbResponse DeleteDomainResponse) +instance Transaction DeleteDomain DeleteDomainResponse diff --git a/Aws/SimpleDb/Commands/DomainMetadata.hs b/Aws/SimpleDb/Commands/DomainMetadata.hs --- a/Aws/SimpleDb/Commands/DomainMetadata.hs +++ b/Aws/SimpleDb/Commands/DomainMetadata.hs @@ -2,17 +2,18 @@ module Aws.SimpleDb.Commands.DomainMetadata where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction -import Control.Applicative -import Control.Monad.Compose.Class +import Aws.Xml import Data.Time import Data.Time.Clock.POSIX -import Text.XML.Monad -import qualified Data.ByteString.UTF8 as BU +import Text.XML.Enumerator.Cursor (($//), (&|)) +import qualified Data.ByteString.UTF8 as BU data DomainMetadata = DomainMetadata { @@ -39,16 +40,19 @@ type Info DomainMetadata = SdbInfo signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", BU.fromString dmDomainName)] -instance SdbFromResponse DomainMetadataResponse where - sdbFromResponse = do - testElementNameUI "DomainMetadataResponse" - dmrTimestamp <- posixSecondsToUTCTime . fromInteger <$> readContent <<< findElementNameUI "Timestamp" - dmrItemCount <- readContent <<< findElementNameUI "ItemCount" - dmrAttributeValueCount <- readContent <<< findElementNameUI "AttributeValueCount" - dmrAttributeNameCount <- readContent <<< findElementNameUI "AttributeNameCount" - dmrItemNamesSizeBytes <- readContent <<< findElementNameUI "ItemNamesSizeBytes" - dmrAttributeValuesSizeBytes <- readContent <<< findElementNameUI "AttributeValuesSizeBytes" - dmrAttributeNamesSizeBytes <- readContent <<< findElementNameUI "AttributeNamesSizeBytes" - return DomainMetadataResponse{..} +instance ResponseIteratee DomainMetadataResponse where + type ResponseMetadata DomainMetadataResponse = SdbMetadata -instance Transaction DomainMetadata (SdbResponse DomainMetadataResponse) + responseIteratee = sdbResponseIteratee parse + where parse cursor = do + sdbCheckResponseType () "DomainMetadataResponse" cursor + dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt) + dmrItemCount <- forceM "ItemCount expected" $ cursor $// elCont "ItemCount" &| readInt + dmrAttributeValueCount <- forceM "AttributeValueCount expected" $ cursor $// elCont "AttributeValueCount" &| readInt + dmrAttributeNameCount <- forceM "AttributeNameCount expected" $ cursor $// elCont "AttributeNameCount" &| readInt + dmrItemNamesSizeBytes <- forceM "ItemNamesSizeBytes expected" $ cursor $// elCont "ItemNamesSizeBytes" &| readInt + dmrAttributeValuesSizeBytes <- forceM "AttributeValuesSizeBytes expected" $ cursor $// elCont "AttributeValuesSizeBytes" &| readInt + dmrAttributeNamesSizeBytes <- forceM "AttributeNamesSizeBytes expected" $ cursor $// elCont "AttributeNamesSizeBytes" &| readInt + return DomainMetadataResponse{..} + +instance Transaction DomainMetadata DomainMetadataResponse diff --git a/Aws/SimpleDb/Commands/GetAttributes.hs b/Aws/SimpleDb/Commands/GetAttributes.hs --- a/Aws/SimpleDb/Commands/GetAttributes.hs +++ b/Aws/SimpleDb/Commands/GetAttributes.hs @@ -2,8 +2,10 @@ module Aws.SimpleDb.Commands.GetAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response @@ -11,10 +13,10 @@ import Aws.Util import Control.Applicative import Control.Monad -import Control.Monad.Compose.Class import Data.Maybe -import Text.XML.Monad -import qualified Data.ByteString.UTF8 as BU +import Text.XML.Enumerator.Cursor (($//), (&|)) +import qualified Data.ByteString.UTF8 as BU +import qualified Text.XML.Enumerator.Cursor as Cu data GetAttributes = GetAttributes { @@ -42,10 +44,12 @@ maybeToList (("AttributeName",) <$> BU.fromString <$> gaAttributeName) ++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)]) -instance SdbFromResponse GetAttributesResponse where - sdbFromResponse = do - testElementNameUI "GetAttributesResponse" - attributes <- inList readAttribute <<< findElementsNameUI "Attribute" - return $ GetAttributesResponse attributes +instance ResponseIteratee GetAttributesResponse where + type ResponseMetadata GetAttributesResponse = SdbMetadata + responseIteratee = sdbResponseIteratee parse + where parse cursor = do + sdbCheckResponseType () "GetAttributesResponse" cursor + attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute + return $ GetAttributesResponse attributes -instance Transaction GetAttributes (SdbResponse GetAttributesResponse) +instance Transaction GetAttributes GetAttributesResponse diff --git a/Aws/SimpleDb/Commands/ListDomains.hs b/Aws/SimpleDb/Commands/ListDomains.hs --- a/Aws/SimpleDb/Commands/ListDomains.hs +++ b/Aws/SimpleDb/Commands/ListDomains.hs @@ -2,16 +2,18 @@ module Aws.SimpleDb.Commands.ListDomains where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction +import Aws.Xml import Control.Applicative -import Control.Monad.Compose.Class import Data.Maybe -import Text.XML.Monad -import qualified Data.ByteString.UTF8 as BU +import Text.XML.Enumerator.Cursor (($//)) +import qualified Data.ByteString.UTF8 as BU data ListDomains = ListDomains { @@ -38,11 +40,13 @@ , ("NextToken",) <$> BU.fromString <$> ldNextToken ] -instance SdbFromResponse ListDomainsResponse where - sdbFromResponse = do - testElementNameUI "ListDomainsResponse" - names <- inList strContent <<< findElementsNameUI "DomainName" - nextToken <- tryMaybe $ strContent <<< findElementNameUI "NextToken" - return $ ListDomainsResponse names nextToken +instance ResponseIteratee ListDomainsResponse where + type ResponseMetadata ListDomainsResponse = SdbMetadata + responseIteratee = sdbResponseIteratee parse + where parse cursor = do + sdbCheckResponseType () "ListDomainsResponse" cursor + let names = cursor $// elCont "DomainName" + let nextToken = listToMaybe $ cursor $// elCont "NextToken" + return $ ListDomainsResponse names nextToken -instance Transaction ListDomains (SdbResponse ListDomainsResponse) +instance Transaction ListDomains ListDomainsResponse diff --git a/Aws/SimpleDb/Commands/PutAttributes.hs b/Aws/SimpleDb/Commands/PutAttributes.hs --- a/Aws/SimpleDb/Commands/PutAttributes.hs +++ b/Aws/SimpleDb/Commands/PutAttributes.hs @@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.PutAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util -import Control.Applicative -import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data PutAttributes @@ -42,7 +42,8 @@ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected -instance SdbFromResponse PutAttributesResponse where - sdbFromResponse = PutAttributesResponse <$ testElementNameUI "PutAttributesResponse" +instance ResponseIteratee PutAttributesResponse where + type ResponseMetadata PutAttributesResponse = SdbMetadata + responseIteratee = sdbResponseIteratee $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" -instance Transaction PutAttributes (SdbResponse PutAttributesResponse) +instance Transaction PutAttributes PutAttributesResponse diff --git a/Aws/SimpleDb/Commands/Select.hs b/Aws/SimpleDb/Commands/Select.hs --- a/Aws/SimpleDb/Commands/Select.hs +++ b/Aws/SimpleDb/Commands/Select.hs @@ -2,17 +2,21 @@ module Aws.SimpleDb.Commands.Select where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info +import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util +import Aws.Xml import Control.Monad -import Control.Monad.Compose.Class -import Text.XML.Monad -import qualified Data.ByteString.UTF8 as BU +import Data.Maybe +import Text.XML.Enumerator.Cursor (($//), (&|)) +import qualified Data.ByteString.UTF8 as BU +import qualified Text.XML.Enumerator.Cursor as Cu data Select = Select { @@ -40,11 +44,13 @@ (guard sConsistentRead >> [("ConsistentRead", awsTrue)]) ++ (guard (not $ null sNextToken) >> [("NextToken", BU.fromString sNextToken)]) -instance SdbFromResponse SelectResponse where - sdbFromResponse = do - testElementNameUI "SelectResponse" - items <- inList readItem <<< findElementsNameUI "Item" - nextToken <- tryMaybe $ strContent <<< findElementNameUI "NextToken" - return $ SelectResponse items nextToken +instance ResponseIteratee SelectResponse where + type ResponseMetadata SelectResponse = SdbMetadata + responseIteratee = sdbResponseIteratee parse + where parse cursor = do + sdbCheckResponseType () "SelectResponse" cursor + items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem + let nextToken = listToMaybe $ cursor $// elCont "NextToken" + return $ SelectResponse items nextToken -instance Transaction Select (SdbResponse SelectResponse) +instance Transaction Select SelectResponse diff --git a/Aws/SimpleDb/Error.hs b/Aws/SimpleDb/Error.hs --- a/Aws/SimpleDb/Error.hs +++ b/Aws/SimpleDb/Error.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, RecordWildCards #-} module Aws.SimpleDb.Error where -import Aws.Metadata -import Aws.SimpleDb.Metadata -import Control.Monad.Error.Class import Data.Typeable -import Text.XML.Monad import qualified Control.Exception as C import qualified Network.HTTP.Types as HTTP @@ -17,26 +13,7 @@ sdbStatusCode :: HTTP.Status , sdbErrorCode :: ErrorCode , sdbErrorMessage :: String - , sdbErrorMetadata :: Maybe SdbMetadata } - | SdbXmlError { - fromSdbXmlError :: XmlError - , sdbXmlErrorMetadata :: Maybe SdbMetadata - } deriving (Show, Typeable) - -instance FromXmlError SdbError where - fromXmlError = flip SdbXmlError Nothing - -instance WithMetadata SdbError SdbMetadata where - getMetadata SdbError { sdbErrorMetadata = err } = err - getMetadata SdbXmlError { sdbXmlErrorMetadata = err } = err - - setMetadata m e@SdbError{} = e { sdbErrorMetadata = Just m } - setMetadata m e@SdbXmlError{} = e { sdbXmlErrorMetadata = Just m } - -instance Error SdbError where - noMsg = fromXmlError noMsg - strMsg = fromXmlError . strMsg instance C.Exception SdbError diff --git a/Aws/SimpleDb/Metadata.hs b/Aws/SimpleDb/Metadata.hs --- a/Aws/SimpleDb/Metadata.hs +++ b/Aws/SimpleDb/Metadata.hs @@ -1,9 +1,18 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Aws.SimpleDb.Metadata where + +import Control.Monad +import Data.Monoid +import Data.Typeable data SdbMetadata = SdbMetadata { - requestId :: String + requestId :: Maybe String , boxUsage :: Maybe String } - deriving (Show) + deriving (Show, Typeable) + +instance Monoid SdbMetadata where + mempty = SdbMetadata Nothing Nothing + SdbMetadata r1 b1 `mappend` SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2) diff --git a/Aws/SimpleDb/Model.hs b/Aws/SimpleDb/Model.hs --- a/Aws/SimpleDb/Model.hs +++ b/Aws/SimpleDb/Model.hs @@ -1,24 +1,25 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Aws.SimpleDb.Model where -import Aws.SimpleDb.Error import Aws.SimpleDb.Response import Aws.Util -import Control.Monad.Compose.Class -import Text.XML.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as BU -import qualified Text.XML.Light as XL +import Aws.Xml +import Control.Monad +import Text.XML.Enumerator.Cursor (($/), (&|)) +import qualified Control.Failure as F +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BU +import qualified Text.XML.Enumerator.Cursor as Cu data Attribute a = ForAttribute { attributeName :: String, attributeData :: a } deriving (Show) -readAttribute :: Xml SdbError XL.Element (Attribute String) -readAttribute = do - name <- decodeBase64 <<< findElementNameUI "Name" - value <- decodeBase64 <<< findElementNameUI "Value" +readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute String) +readAttribute cursor = do + name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64 + value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64 return $ ForAttribute name value data SetAttribute @@ -66,10 +67,10 @@ = Item { itemName :: String, itemData :: a } deriving (Show) -readItem :: Xml SdbError XL.Element (Item [Attribute String]) -readItem = do - name <- decodeBase64 <<< findElementNameUI "Name" - attributes <- inList readAttribute <<< findElementsNameUI "Attribute" +readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute String]) +readItem cursor = do + name <- force "Missing Name" <=< sequence $ cursor $/ Cu.laxElement "Name" &| decodeBase64 + attributes <- sequence $ cursor $/ Cu.laxElement "Attribute" &| readAttribute return $ Item name attributes itemQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Item a -> [(B.ByteString, B.ByteString)] diff --git a/Aws/SimpleDb/Response.hs b/Aws/SimpleDb/Response.hs --- a/Aws/SimpleDb/Response.hs +++ b/Aws/SimpleDb/Response.hs @@ -1,62 +1,54 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies #-} module Aws.SimpleDb.Response where -import Aws.Metadata import Aws.Response import Aws.SimpleDb.Error import Aws.SimpleDb.Metadata -import Control.Applicative -import Control.Arrow ((+++)) -import Control.Monad.Compose.Class -import Data.Char -import Text.XML.Monad -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.UTF8 as BU -import qualified Text.XML.Light as XL - -data SdbResponse a - = SdbResponse { - fromSdbResponse :: a - , sdbResponseMetadata :: SdbMetadata - } - deriving (Show) - -instance Functor SdbResponse where - fmap f (SdbResponse a m) = SdbResponse (f a) m +import Aws.Xml +import Data.IORef +import Data.Maybe +import Text.XML.Enumerator.Cursor (($|), ($/), ($//), (&|)) +import qualified Control.Failure as F +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.UTF8 as BU +import qualified Data.Enumerator as En +import qualified Data.Text as T +import qualified Network.HTTP.Types as HTTP +import qualified Text.XML.Enumerator.Cursor as Cu -instance (SdbFromResponse a) => ResponseIteratee (SdbResponse a) where - responseIteratee status headers = xmlResponseIteratee (fromXml <<< parseXmlResponse) status headers - where fromXml :: SdbFromResponse a => Xml SdbError XL.Element (SdbResponse a) - fromXml = do - requestId' <- strContent <<< findElementNameUI "RequestID" - boxUsage' <- tryMaybe $ strContent <<< findElementNameUI "BoxUsage" - let metadata = SdbMetadata requestId' boxUsage' - innerTry <- try $ fromXmlInner - inner <- case innerTry of - Left err -> raise $ setMetadata metadata err - Right response -> return response - return $ SdbResponse inner metadata - fromXmlInner :: SdbFromResponse a => Xml SdbError XL.Element a - fromXmlInner = do - xmlError <- tryMaybe $ findElementNameUI "Error" - case xmlError of - Just err -> mapply fromError err - Nothing -> sdbFromResponse - fromError :: Xml SdbError XL.Element a - fromError = do - errCode <- strContent <<< findElementNameUI "Code" - errMessage <- strContent <<< findElementNameUI "Message" - raise $ SdbError status errCode errMessage Nothing +sdbResponseIteratee :: + (Cu.Cursor -> Response SdbMetadata a) + -> IORef SdbMetadata + -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a +sdbResponseIteratee inner metadataRef status headers = xmlCursorIteratee parse metadataRef status headers + where parse cursor + = do let requestId' = listToMaybe $ cursor $// elCont "RequestID" + let boxUsage' = listToMaybe $ cursor $// elCont "BoxUsage" + tellMetadata $ SdbMetadata requestId' boxUsage' + case cursor $/ Cu.laxElement "Error" of + [] -> inner cursor + (err:_) -> fromError err + fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elCont "Code" + errMessage <- force "Missing Error Message" $ cursor $// elCont "Message" + F.failure $ SdbError status errCode errMessage class SdbFromResponse a where - sdbFromResponse :: Xml SdbError XL.Element a + sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a -decodeBase64 :: Xml SdbError XL.Element String -decodeBase64 = do - encoded <- strContent - encoding <- tryMaybe $ findAttr (XL.unqual "encoding") - raisesXml $ case map toLower <$> encoding of - Nothing -> Right encoded - Just "base64" -> (EncodingError . ("Invalid Base64 data: "++) +++ BU.toString) . Base64.decode . BU.fromString $ encoded - Just actual -> Left $ UnexpectedAttributeValueQ actual "base64" +sdbCheckResponseType :: F.Failure XmlException m => a -> T.Text -> Cu.Cursor -> m a +sdbCheckResponseType a n c = do _ <- force ("Expected response type " ++ T.unpack n) (Cu.laxElement n c) + return a + +decodeBase64 :: F.Failure XmlException m => Cu.Cursor -> m String +decodeBase64 cursor = + let encoded = T.unpack . T.concat $ cursor $/ Cu.content + encoding = listToMaybe $ cursor $| Cu.laxAttribute "encoding" &| T.toCaseFold + in + case encoding of + Nothing -> return encoded + Just "base64" -> case fmap BU.toString $ Base64.decode . BU.fromString $ encoded of + Left msg -> F.failure $ XmlException ("Invalid Base64 data: " ++ msg) + Right x -> return x + Just actual -> F.failure $ XmlException ("Unrecognized encoding " ++ T.unpack actual) diff --git a/Aws/Transaction.hs b/Aws/Transaction.hs --- a/Aws/Transaction.hs +++ b/Aws/Transaction.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} module Aws.Transaction where import Aws.Response import Aws.Signature +import Data.Monoid -class (SignQuery r, ResponseIteratee a) +class (SignQuery r, ResponseIteratee a, Monoid (ResponseMetadata a)) => Transaction r a | r -> a, a -> r diff --git a/Aws/Util.hs b/Aws/Util.hs --- a/Aws/Util.hs +++ b/Aws/Util.hs @@ -37,11 +37,17 @@ fmtTime :: String -> UTCTime -> B.ByteString fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t +rfc822Time :: String +rfc822Time = "%a, %_d %b %Y %H:%M:%S GMT" + fmtRfc822Time :: UTCTime -> B.ByteString -fmtRfc822Time = fmtTime "%a, %_d %b %Y %H:%M:%S GMT" +fmtRfc822Time = fmtTime rfc822Time +amzTime :: String +amzTime = "%Y-%m-%dT%H:%M:%S" + fmtAmzTime :: UTCTime -> B.ByteString -fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S" +fmtAmzTime = fmtTime amzTime fmtTimeEpochSeconds :: UTCTime -> B.ByteString fmtTimeEpochSeconds = fmtTime "%s" diff --git a/Aws/Xml.hs b/Aws/Xml.hs new file mode 100644 --- /dev/null +++ b/Aws/Xml.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} +module Aws.Xml +where + +import Aws.Response +import Control.Monad.IO.Class +import Data.Attempt (Attempt(..)) +import Data.Enumerator ((=$)) +import Data.IORef +import Data.Monoid +import Data.Typeable +import Text.XML.Enumerator.Cursor +import qualified Control.Exception as C +import qualified Control.Failure as F +import qualified Data.ByteString as B +import qualified Data.Enumerator as En +import qualified Data.Text as T +import qualified Network.HTTP.Types as HTTP +import qualified Text.XML.Enumerator.Cursor as Cu +import qualified Text.XML.Enumerator.Parse as XML +import qualified Text.XML.Enumerator.Resolved as XML + +newtype XmlException = XmlException { xmlErrorMessage :: String } + deriving (Show, Typeable) + +instance C.Exception XmlException + +elCont :: T.Text -> Cursor -> [String] +elCont name = laxElement name &/ content &| T.unpack + +force :: F.Failure XmlException m => String -> [a] -> m a +force = Cu.force . XmlException + +forceM :: F.Failure XmlException m => String -> [m a] -> m a +forceM = Cu.forceM . XmlException + +readInt :: (F.Failure XmlException m, Num a) => String -> m a +readInt s = case reads s of + [(n,"")] -> return $ fromInteger n + _ -> F.failure $ XmlException "Invalid Integer" + +xmlCursorIteratee :: + (Monoid m) + => (Cu.Cursor -> Response m a) + -> IORef m + -> HTTP.Status + -> HTTP.ResponseHeaders + -> En.Iteratee B.ByteString IO a +xmlCursorIteratee parse metadataRef _status _headers + = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents + let cursor = Cu.fromDocument doc + let Response metadata x = parse cursor + liftIO $ tellMetadataRef metadataRef metadata + case x of + Failure err -> En.throwError err + Success v -> return v diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -6,7 +6,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.0.3 +Version: 0.0.4 -- A short (one-line) description of the package. Synopsis: Amazon Web Services (AWS) for Haskell @@ -53,7 +53,6 @@ Aws.Credentials, Aws.Debug, Aws.Http, - Aws.Metadata, Aws.Query, Aws.Response, Aws.S3, @@ -86,32 +85,34 @@ Aws.SimpleDb.Query, Aws.SimpleDb.Response, Aws.Transaction, - Aws.Util + Aws.Util, + Aws.Xml -- Packages needed in order to build this package. Build-depends: + attempt >=0.3.1.1 && <0.4, base ==4.*, base64-bytestring ==0.1.*, blaze-builder >=0.2.1.4 && <0.4, bytestring ==0.9.*, cereal ==0.3.*, containers >=0.3 && <0.5, - crypto-api ==0.5.*, - cryptohash ==0.6.*, + crypto-api >= 0.5 && < 0.7, + cryptohash >= 0.6 && < 0.8, directory >=1.0 && <1.2, enumerator ==0.4.*, + failure >=0.1.0.1 && <0.2, filepath >=1.1 && <1.3, - http-enumerator >=0.5 && < 0.6, + http-enumerator >=0.6 && < 0.7, http-types >=0.6 && <0.7, mtl ==2.*, old-locale ==1.*, shortcircuit ==0.1.*, + text >=0.11 && <0.12, time >=1.1.4 && <1.3, transformers >=0.2.2.0 && <0.3, - transformers-compose ==0.1.*, utf8-string ==0.3.*, - xml ==1.3.*, - xml-monad >=0.5 && <0.6 + xml-enumerator >=0.3.3.667 && <0.4 GHC-Options: -Wall @@ -120,4 +121,15 @@ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - + + +-- Source repository +source-repository head + type: git + location: git://github.com/aristidb/aws.git + branch: master + +source-repository this + type: git + location: git://github.com/aristidb/aws.git + tag: 0.0.4