aws 0.0.4 → 0.0.5
raw patch · 31 files changed
+377/−249 lines, 31 filesdep +case-insensitivedep +tlsdep −utf8-stringdep ~http-enumeratordep ~xml-enumerator
Dependencies added: case-insensitive, tls
Dependencies removed: utf8-string
Dependency ranges changed: http-enumerator, xml-enumerator
Files
- Aws/Aws.hs +17/−50
- Aws/Credentials.hs +18/−16
- Aws/Debug.hs +2/−4
- Aws/Http.hs +5/−1
- Aws/Query.hs +16/−10
- Aws/S3/Commands.hs +2/−0
- Aws/S3/Commands/GetBucket.hs +21/−17
- Aws/S3/Commands/GetService.hs +12/−3
- Aws/S3/Commands/PutBucket.hs +69/−0
- Aws/S3/Error.hs +6/−5
- Aws/S3/Metadata.hs +6/−5
- Aws/S3/Model.hs +40/−20
- Aws/S3/Query.hs +32/−13
- Aws/S3/Response.hs +7/−7
- Aws/SimpleDb/Commands/BatchDeleteAttributes.hs +5/−4
- Aws/SimpleDb/Commands/BatchPutAttributes.hs +5/−4
- Aws/SimpleDb/Commands/CreateDomain.hs +5/−4
- Aws/SimpleDb/Commands/DeleteAttributes.hs +6/−5
- Aws/SimpleDb/Commands/DeleteDomain.hs +5/−4
- Aws/SimpleDb/Commands/DomainMetadata.hs +5/−4
- Aws/SimpleDb/Commands/GetAttributes.hs +9/−8
- Aws/SimpleDb/Commands/ListDomains.hs +9/−8
- Aws/SimpleDb/Commands/PutAttributes.hs +6/−5
- Aws/SimpleDb/Commands/Select.hs +17/−13
- Aws/SimpleDb/Metadata.hs +6/−5
- Aws/SimpleDb/Model.hs +18/−17
- Aws/SimpleDb/Query.hs +2/−2
- Aws/SimpleDb/Response.hs +7/−7
- Aws/Util.hs +5/−4
- Aws/Xml.hs +8/−0
- aws.cabal +6/−4
Aws/Aws.hs view
@@ -12,7 +12,6 @@ import Aws.SimpleDb.Info import Aws.Transaction import Control.Applicative-import Control.Monad.Reader import Data.Attempt (attemptIO) import Data.IORef import Data.Monoid@@ -47,7 +46,7 @@ configurationFetch = s3Info configurationFetchUri = s3InfoUri -baseConfiguration :: MonadIO io => io Configuration+baseConfiguration :: IO Configuration baseConfiguration = do Just cr <- loadCredentialsDefault return Configuration {@@ -60,74 +59,42 @@ } -- TODO: better error handling when credentials cannot be loaded -debugConfiguration :: MonadIO io => io Configuration+debugConfiguration :: IO Configuration debugConfiguration = do c <- baseConfiguration return c { sdbInfo = sdbHttpPost sdbUsEast, sdbInfoUri = sdbHttpGet sdbUsEast } -newtype AwsT m a = AwsT { fromAwsT :: ReaderT Configuration m a }--type Aws = AwsT IO--runAws :: AwsT m a -> Configuration -> m a-runAws = runReaderT . fromAwsT--runAws' :: MonadIO io => AwsT io a -> io a-runAws' a = baseConfiguration >>= runAws a--runAwsDebug :: MonadIO io => AwsT io a -> io a-runAwsDebug a = debugConfiguration >>= runAws a--instance Monad m => Monad (AwsT m) where- return = AwsT . return- m >>= k = AwsT $ fromAwsT m >>= fromAwsT . k--instance MonadIO m => MonadIO (AwsT m) where- liftIO = AwsT . liftIO--class MonadIO aws => MonadAws aws where- configuration :: MonadAws aws => aws Configuration--instance MonadIO m => MonadAws (AwsT m) where- configuration = AwsT ask- aws :: (Transaction r a- , ConfigurationFetch (Info r)- , MonadAws aws) - => r -> aws (Response (ResponseMetadata a) a)+ , ConfigurationFetch (Info r)) + => Configuration -> r -> IO (Response (ResponseMetadata a) a) aws = unsafeAws unsafeAws- :: (MonadAws aws,- ResponseIteratee a,+ :: (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+ Configuration -> r -> IO (Response (ResponseMetadata a) a)+unsafeAws cfg request = do+ sd <- signatureData <$> timeInfo <*> credentials $ cfg let info = configurationFetch cfg let q = signQuery request info sd debugPrint "String to sign" $ sqStringToSign q let httpRequest = queryToHttpRequest q- 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+ 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)- , MonadAws aws)- => request -> aws B.ByteString-awsUri request = do- cfg <- configuration+ , ConfigurationFetch (Info request))+ => Configuration -> request -> IO B.ByteString+awsUri cfg request = do let ti = timeInfo cfg cr = credentials cfg info = configurationFetchUri cfg- sd <- liftIO $ signatureData ti cr+ sd <- signatureData ti cr let q = signQuery request info sd debugPrint "String to sign" $ sqStringToSign q return $ queryToUri q
Aws/Credentials.hs view
@@ -1,16 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} module Aws.Credentials where import Control.Applicative import Control.Monad-import Control.Monad.IO.Class-import Control.Shortcircuit (orM)+import Control.Shortcircuit (orM) import Data.List import System.Directory import System.Environment import System.FilePath-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BU+import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T data Credentials = Credentials {@@ -19,34 +21,34 @@ } deriving (Show) -credentialsDefaultFile :: MonadIO io => io FilePath-credentialsDefaultFile = liftIO $ (</> ".aws-keys") <$> getHomeDirectory+credentialsDefaultFile :: IO FilePath+credentialsDefaultFile = (</> ".aws-keys") <$> getHomeDirectory -credentialsDefaultKey :: String+credentialsDefaultKey :: T.Text credentialsDefaultKey = "default" -loadCredentialsFromFile :: MonadIO io => FilePath -> String -> io (Maybe Credentials)-loadCredentialsFromFile file key = liftIO $ do- contents <- map words . lines <$> readFile file+loadCredentialsFromFile :: FilePath -> T.Text -> IO (Maybe Credentials)+loadCredentialsFromFile file key = do+ contents <- map T.words . T.lines <$> T.readFile file return $ do [_key, keyID, secret] <- find (hasKey key) contents- return Credentials { accessKeyID = BU.fromString keyID, secretAccessKey = BU.fromString secret }+ return Credentials { accessKeyID = T.encodeUtf8 keyID, secretAccessKey = T.encodeUtf8 secret } where hasKey _ [] = False hasKey k (k2 : _) = k == k2 -loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials)-loadCredentialsFromEnv = liftIO $ do+loadCredentialsFromEnv :: IO (Maybe Credentials)+loadCredentialsFromEnv = do env <- getEnvironment let lk = flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY"- return (Credentials <$> (BU.fromString <$> keyID) <*> (BU.fromString <$> secret))+ return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret)) -loadCredentialsFromEnvOrFile :: MonadIO io => FilePath -> String -> io (Maybe Credentials)+loadCredentialsFromEnvOrFile :: FilePath -> T.Text -> IO (Maybe Credentials) loadCredentialsFromEnvOrFile file key = loadCredentialsFromEnv `orM` loadCredentialsFromFile file key -loadCredentialsDefault :: MonadIO io => io (Maybe Credentials)+loadCredentialsDefault :: IO (Maybe Credentials) loadCredentialsDefault = do file <- credentialsDefaultFile loadCredentialsFromEnvOrFile file credentialsDefaultKey
Aws/Debug.hs view
@@ -1,7 +1,5 @@ module Aws.Debug where -import Control.Monad.IO.Class--debugPrint :: (MonadIO io, Show a) => String -> a -> io ()-debugPrint p v = liftIO . putStrLn $ "AWS Debug: " ++ p ++ " - " ++ show v+debugPrint :: (Show a) => String -> a -> IO ()+debugPrint p v = putStrLn $ "AWS Debug: " ++ p ++ " - " ++ show v
Aws/Http.hs view
@@ -17,8 +17,12 @@ data Method = Get | PostQuery+ | Post+ | Put deriving (Show, Eq) httpMethod :: Method -> HTTP.Method-httpMethod Get = "GET"+httpMethod Get = "GET" httpMethod PostQuery = "POST"+httpMethod Post = "POST"+httpMethod Put = "PUT"
Aws/Query.hs view
@@ -5,13 +5,15 @@ import Aws.Http import Aws.Util import Data.Maybe+import Data.Monoid import Data.Time import qualified Blaze.ByteString.Builder as Blaze import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Network.HTTP.Enumerator as HTTP import qualified Network.HTTP.Types as HTTP+import qualified Network.TLS as TLS data SignedQuery = SignedQuery {@@ -25,19 +27,20 @@ , sqAuthorization :: Maybe B.ByteString , sqContentType :: Maybe B.ByteString , sqContentMd5 :: Maybe B.ByteString- , sqBody :: L.ByteString+ , sqAmzHeaders :: HTTP.RequestHeaders+ , sqBody :: Maybe (HTTP.RequestBody IO) , sqStringToSign :: B.ByteString }- deriving (Show)+ --deriving (Show) -queryToHttpRequest :: SignedQuery -> HTTP.Request m+queryToHttpRequest :: SignedQuery -> HTTP.Request IO queryToHttpRequest SignedQuery{..} = HTTP.Request { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False HTTPS -> True- , HTTP.checkCerts = const (return True) -- FIXME: actually check certificates+ , HTTP.checkCerts = const (return TLS.CertificateUsageAccept) -- FIXME: actually check certificates , HTTP.host = sqHost , HTTP.port = sqPort , HTTP.path = sqPath@@ -46,9 +49,12 @@ , fmap (\c -> ("Content-Type", c)) contentType , fmap (\md5 -> ("Content-MD5", md5)) sqContentMd5 , fmap (\auth -> ("Authorization", auth)) sqAuthorization]- , HTTP.requestBody = HTTP.RequestBodyLBS $ case sqMethod of- Get -> L.empty- PostQuery -> Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery+ ++ sqAmzHeaders+ , HTTP.requestBody = case sqMethod of+ PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery+ _ -> case sqBody of+ Nothing -> HTTP.RequestBodyBuilder 0 mempty+ Just x -> x , HTTP.proxy = Nothing , HTTP.rawBody = False }@@ -63,7 +69,7 @@ HTTP -> "http://" HTTPS -> "https://" , sqHost- , if sqPort == defaultPort sqProtocol then "" else BU.fromString $ ':' : show sqPort+ , if sqPort == defaultPort sqProtocol then "" else T.encodeUtf8 . T.pack $ ':' : show sqPort , sqPath , HTTP.renderQuery True sqQuery ]
Aws/S3/Commands.hs view
@@ -2,8 +2,10 @@ ( module Aws.S3.Commands.GetBucket , module Aws.S3.Commands.GetService+, module Aws.S3.Commands.PutBucket ) where import Aws.S3.Commands.GetBucket import Aws.S3.Commands.GetService+import Aws.S3.Commands.PutBucket
Aws/S3/Commands/GetBucket.hs view
@@ -2,6 +2,7 @@ module Aws.S3.Commands.GetBucket where +import Aws.Http import Aws.Response import Aws.S3.Info import Aws.S3.Metadata@@ -16,8 +17,8 @@ import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe import Text.XML.Enumerator.Cursor (($/), (&|), (&//))-import qualified Data.ByteString.UTF8 as BU import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Traversable import qualified Network.HTTP.Types as HTTP import qualified Text.XML.Enumerator.Cursor as Cu@@ -25,10 +26,10 @@ data GetBucket = GetBucket { gbBucket :: Bucket- , gbDelimiter :: Maybe String- , gbMarker :: Maybe String+ , gbDelimiter :: Maybe T.Text+ , gbMarker :: Maybe T.Text , gbMaxKeys :: Maybe Int- , gbPrefix :: Maybe String+ , gbPrefix :: Maybe T.Text } deriving (Show) @@ -45,26 +46,29 @@ data GetBucketResponse = GetBucketResponse { gbrName :: Bucket- , gbrDelimiter :: Maybe String- , gbrMarker :: Maybe String+ , gbrDelimiter :: Maybe T.Text+ , gbrMarker :: Maybe T.Text , gbrMaxKeys :: Maybe Int- , gbrPrefix :: Maybe String+ , gbrPrefix :: Maybe T.Text , gbrContents :: [ObjectInfo]- , gbrCommonPrefixes :: [String]+ , gbrCommonPrefixes :: [T.Text] } deriving (Show) instance SignQuery GetBucket where type Info GetBucket = S3Info signQuery GetBucket {..} = s3SignQuery S3Query { - s3QBucket = Just $ BU.fromString gbBucket+ s3QMethod = Get+ , s3QBucket = Just $ T.encodeUtf8 gbBucket , s3QSubresources = []- , s3QQuery = HTTP.simpleQueryToQuery $ map (second BU.fromString) $ catMaybes [+ , s3QQuery = HTTP.simpleQueryToQuery $ map (second T.encodeUtf8) $ catMaybes [ ("delimiter",) <$> gbDelimiter , ("marker",) <$> gbMarker- , ("max-keys",) <$> show <$> gbMaxKeys+ , ("max-keys",) . T.pack . show <$> gbMaxKeys , ("prefix",) <$> gbPrefix ]+ , s3QAmzHeaders = []+ , s3QRequestBody = Nothing } instance ResponseIteratee GetBucketResponse where@@ -72,13 +76,13 @@ 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"+ = do name <- force "Missing Name" $ cursor $/ elContent "Name"+ let delimiter = listToMaybe $ cursor $/ elContent "Delimiter"+ let marker = listToMaybe $ cursor $/ elContent "Marker"+ maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent "MaxKeys" &| textReadInt+ let prefix = listToMaybe $ cursor $/ elContent "Prefix" contents <- sequence $ cursor $/ Cu.laxElement "Contents" &| parseObjectInfo- let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content &| T.unpack+ let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content return GetBucketResponse{ gbrName = name , gbrDelimiter = delimiter
Aws/S3/Commands/GetService.hs view
@@ -2,6 +2,7 @@ module Aws.S3.Commands.GetService where +import Aws.Http import Aws.Response import Aws.S3.Info import Aws.S3.Metadata@@ -15,6 +16,7 @@ import Data.Time.Format import System.Locale import Text.XML.Enumerator.Cursor (($/), ($//), (&|))+import qualified Data.Text as T import qualified Text.XML.Enumerator.Cursor as Cu data GetService = GetService@@ -37,13 +39,20 @@ return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets } parseBucket el = do- name <- force "Missing owner Name" $ el $/ elCont "Name"- creationDateString <- force "Missing owner CreationDate" $ el $/ elCont "CreationDate"+ name <- force "Missing owner Name" $ el $/ elContent "Name"+ creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack 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 = [] }+ signQuery GetService = s3SignQuery S3Query { + s3QMethod = Get+ , s3QBucket = Nothing+ , s3QSubresources = []+ , s3QQuery = []+ , s3QAmzHeaders = [] + , s3QRequestBody = Nothing + } instance Transaction GetService GetServiceResponse
+ Aws/S3/Commands/PutBucket.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE RecordWildCards, TypeFamilies, OverloadedStrings, MultiParamTypeClasses #-}+module Aws.S3.Commands.PutBucket where++import Aws.Http+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 Control.Monad+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Enumerator as HTTPE+import qualified Text.XML.Enumerator.Resolved as XML++data PutBucket+ = PutBucket {+ pbBucket :: Bucket+ , pbCannedAcl :: Maybe CannedAcl+ , pbLocationConstraint :: LocationConstraint+ }+ deriving (Show)++data PutBucketResponse+ = PutBucketResponse+ deriving (Show)++instance SignQuery PutBucket where+ type Info PutBucket = S3Info++ signQuery PutBucket{..} = s3SignQuery (S3Query {+ s3QMethod = Put+ , s3QBucket = Just $ T.encodeUtf8 pbBucket+ , s3QSubresources = []+ , s3QQuery = []+ , s3QAmzHeaders = case pbCannedAcl of + Nothing -> []+ Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)]+ , s3QRequestBody+ = guard (not . T.null $ pbLocationConstraint) >>+ (Just . HTTPE.RequestBodyLBS . XML.renderLBS) + XML.Document {+ XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = root+ , XML.documentEpilogue = []+ }+ })+ where root = XML.Element {+ XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}CreateBucketConfiguration"+ , XML.elementAttributes = []+ , XML.elementNodes = [+ XML.NodeElement (XML.Element {+ XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint"+ , XML.elementAttributes = []+ , XML.elementNodes = [XML.NodeContent pbLocationConstraint]+ })+ ]+ }++instance ResponseIteratee PutBucketResponse where+ type ResponseMetadata PutBucketResponse = S3Metadata+ + responseIteratee = s3ResponseIteratee inner+ where inner _status _headers = return PutBucketResponse++instance Transaction PutBucket PutBucketResponse
Aws/S3/Error.hs view
@@ -5,18 +5,19 @@ import Data.Typeable import qualified Control.Exception as C import qualified Data.ByteString as B+import qualified Data.Text as T import qualified Network.HTTP.Types as HTTP -type ErrorCode = String+type ErrorCode = T.Text data S3Error = S3Error { s3StatusCode :: HTTP.Status , s3ErrorCode :: ErrorCode -- Error/Code- , s3ErrorMessage :: String -- Error/Message- , s3ErrorResource :: Maybe String -- Error/Resource- , s3ErrorHostId :: Maybe String -- Error/HostId- , s3ErrorAccessKeyId :: Maybe String -- Error/AWSAccessKeyId+ , s3ErrorMessage :: T.Text -- Error/Message+ , s3ErrorResource :: Maybe T.Text -- Error/Resource+ , s3ErrorHostId :: Maybe T.Text -- Error/HostId+ , s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId , s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding) } deriving (Show, Typeable)
Aws/S3/Metadata.hs view
@@ -2,14 +2,15 @@ module Aws.S3.Metadata where -import Control.Monad-import Data.Monoid-import Data.Typeable+import Control.Monad+import Data.Monoid+import Data.Typeable+import qualified Data.Text as T data S3Metadata = S3Metadata {- s3MAmzId2 :: Maybe String- , s3MRequestId :: Maybe String+ s3MAmzId2 :: Maybe T.Text+ , s3MRequestId :: Maybe T.Text } deriving (Show, Typeable)
Aws/S3/Model.hs view
@@ -5,54 +5,74 @@ import Aws.Xml import Data.Time import System.Locale-import Text.XML.Enumerator.Cursor (($/), (&|))+import Text.XML.Enumerator.Cursor (($/), (&|), (>=>)) import qualified Control.Failure as F import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Data.Text as T -type CanonicalUserId = String+type CanonicalUserId = T.Text data UserInfo = UserInfo {- userId :: CanonicalUserId- , userDisplayName :: String+ userId :: CanonicalUserId+ , userDisplayName :: T.Text } deriving (Show) 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"+parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elContent "ID"+ displayName <- force "Missing user DisplayName" $ el $/ elContent "DisplayName" return UserInfo { userId = id_, userDisplayName = displayName } -type Bucket = String+data CannedAcl+ = AclPrivate + | AclPublicRead + | AclPublicReadWrite + | AclAuthenticatedRead + | AclBucketOwnerRead + | AclBucketOwnerFullControl+ | AclLogDeliveryWrite+ deriving (Show) +writeCannedAcl :: CannedAcl -> T.Text+writeCannedAcl AclPrivate = "private"+writeCannedAcl AclPublicRead = "public-read"+writeCannedAcl AclPublicReadWrite = "public-read-write"+writeCannedAcl AclAuthenticatedRead = "authenticated-read"+writeCannedAcl AclBucketOwnerRead = "bucket-owner-read"+writeCannedAcl AclBucketOwnerFullControl = "bucket-owner-full-control"+writeCannedAcl AclLogDeliveryWrite = "log-delivery-write"++type Bucket = T.Text+ data BucketInfo = BucketInfo {- bucketName :: Bucket+ bucketName :: Bucket , bucketCreationDate :: UTCTime } deriving (Show) data ObjectInfo = ObjectInfo {- objectKey :: String+ objectKey :: T.Text , objectLastModified :: UTCTime- , objectETag :: String- , objectSize :: Integer- , objectStorageClass :: String- , objectOwner :: UserInfo+ , objectETag :: T.Text+ , objectSize :: Integer+ , objectStorageClass :: T.Text+ , objectOwner :: UserInfo } 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+ = do key <- force "Missing object Key" $ el $/ elContent "Key"+ let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack 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"+ lastModified <- forceM "Missing object LastModified" $ el $/ Cu.laxElement "LastModified" >=> Cu.content &| time+ eTag <- force "Missing object ETag" $ el $/ elContent "ETag"+ size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt+ storageClass <- force "Missing object StorageClass" $ el $/ elContent "StorageClass" owner <- forceM "Missing object Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo return ObjectInfo{ objectKey = key@@ -63,7 +83,7 @@ , objectOwner = owner } -type LocationConstraint = String+type LocationConstraint = T.Text locationUsClassic, locationUsWest, locationEu, locationApSouthEast, locationApNorthEast :: LocationConstraint locationUsClassic = ""
Aws/S3/Query.hs view
@@ -9,6 +9,7 @@ import Aws.S3.Info import Aws.Signature import Aws.Util+import Data.Function import Data.List import Data.Maybe import Data.Monoid@@ -16,21 +17,34 @@ import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as B8+import qualified Data.CaseInsensitive as CI+import qualified Network.HTTP.Enumerator as HTTPE import qualified Network.HTTP.Types as HTTP data S3Query = S3Query {- s3QBucket :: Maybe B.ByteString+ s3QMethod :: Method+ , s3QBucket :: Maybe B.ByteString , s3QSubresources :: HTTP.Query , s3QQuery :: HTTP.Query+ , s3QAmzHeaders :: HTTP.RequestHeaders+ , s3QRequestBody :: Maybe (HTTPE.RequestBody IO) }- deriving (Show) +instance Show S3Query where+ show S3Query{..} = "S3Query [" +++ " method: " ++ show s3QMethod +++ " ; bucket: " ++ show s3QBucket ++ + " ; subresources: " ++ show s3QSubresources ++ + " ; query: " ++ show s3QQuery +++ " ; request body: " ++ (case s3QRequestBody of Nothing -> "no"; _ -> "yes") ++ + "]"+ s3SignQuery :: S3Query -> S3Info -> SignatureData -> SignedQuery s3SignQuery S3Query{..} S3Info{..} SignatureData{..} = SignedQuery {- sqMethod = method+ sqMethod = s3QMethod , sqProtocol = s3Protocol , sqHost = B.intercalate "." $ catMaybes host , sqPort = s3Port@@ -40,37 +54,42 @@ , sqAuthorization = authorization , sqContentType = contentType , sqContentMd5 = contentMd5- , sqBody = L.empty+ , sqAmzHeaders = amzHeaders+ , sqBody = s3QRequestBody , sqStringToSign = stringToSign } where- method = Get contentMd5 = Nothing contentType = Nothing+ amzHeaders = merge $ sortBy (compare `on` fst) s3QAmzHeaders+ where merge (x1@(k1,v1):x2@(k2,v2):xs) = if k1 == k2+ then (k1, B8.intercalate "," [v1, v2]):merge xs+ else x1:x2:merge xs+ merge xs = xs (host, path) = case s3RequestStyle of - PathStyle -> ([Just s3Endpoint], [Just "/", s3QBucket, Just "/"])+ PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket]) 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 `mappend`- Blaze.copyByteString "/"+ canonicalizedResource = Blaze8.fromChar '/' `mappend`+ maybe mempty (\s -> Blaze.copyByteString s `mappend` Blaze8.fromChar '/') s3QBucket `mappend`+ HTTP.renderQueryBuilder True sortedSubresources ti = case (s3UseUri, signatureTimeInfo) of (False, ti') -> ti' (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time (True, AbsoluteExpires time) -> AbsoluteExpires time sig = signature signatureCredentials HmacSHA1 stringToSign stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $- [[Blaze.copyByteString $ httpMethod method]+ [[Blaze.copyByteString $ httpMethod s3QMethod] , [maybe mempty Blaze.copyByteString contentMd5] , [maybe mempty Blaze.copyByteString contentType] , [Blaze.copyByteString $ case ti of AbsoluteTimestamp time -> fmtRfc822Time time AbsoluteExpires time -> fmtTimeEpochSeconds time]- , [] -- canonicalized AMZ headers+ , map amzHeader amzHeaders , [canonicalizedResource] ]+ where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v (authorization, authQuery) = case ti of AbsoluteTimestamp _ -> (Just $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], []) AbsoluteExpires time -> (Nothing, HTTP.simpleQueryToQuery $ makeAuthQuery time)
Aws/S3/Response.hs view
@@ -15,8 +15,8 @@ import Data.Word 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 Data.Text.Encoding 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@@ -27,7 +27,7 @@ -> 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 headerString = fmap T.decodeUtf8 . flip lookup headers let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id" @@ -53,11 +53,11 @@ 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"+ parseError root = do code <- force "Missing error Code" $ root $/ elContent "Code"+ message <- force "Missing error Message" $ root $/ elContent "Message"+ let resource = listToMaybe $ root $/ elContent "Resource"+ hostId = listToMaybe $ root $/ elContent "HostId"+ accessKeyId = listToMaybe $ root $/ elContent "AWSAccessKeyId" stringToSign = do unprocessed <- listToMaybe $ root $/ elCont "StringToSignBytes" bytes <- mapM readHex2 $ words unprocessed return $ B.pack bytes
Aws/SimpleDb/Commands/BatchDeleteAttributes.hs view
@@ -11,12 +11,13 @@ import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data BatchDeleteAttributes = BatchDeleteAttributes { bdaItems :: [Item [Attribute DeleteAttribute]]- , bdaDomainName :: String+ , bdaDomainName :: T.Text } deriving (Show) @@ -24,7 +25,7 @@ = BatchDeleteAttributesResponse deriving (Show) -batchDeleteAttributes :: [Item [Attribute DeleteAttribute]] -> String -> BatchDeleteAttributes+batchDeleteAttributes :: [Item [Attribute DeleteAttribute]] -> T.Text -> BatchDeleteAttributes batchDeleteAttributes items domain = BatchDeleteAttributes { bdaItems = items, bdaDomainName = domain } instance SignQuery BatchDeleteAttributes where@@ -32,7 +33,7 @@ signQuery BatchDeleteAttributes{..} = sdbSignQuery $ [("Action", "BatchDeleteAttributes")- , ("DomainName", BU.fromString bdaDomainName)] +++ , ("DomainName", T.encodeUtf8 bdaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems instance ResponseIteratee BatchDeleteAttributesResponse where
Aws/SimpleDb/Commands/BatchPutAttributes.hs view
@@ -11,12 +11,13 @@ import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data BatchPutAttributes = BatchPutAttributes { bpaItems :: [Item [Attribute SetAttribute]]- , bpaDomainName :: String+ , bpaDomainName :: T.Text } deriving (Show) @@ -24,7 +25,7 @@ = BatchPutAttributesResponse deriving (Show) -batchPutAttributes :: [Item [Attribute SetAttribute]] -> String -> BatchPutAttributes+batchPutAttributes :: [Item [Attribute SetAttribute]] -> T.Text -> BatchPutAttributes batchPutAttributes items domain = BatchPutAttributes { bpaItems = items, bpaDomainName = domain } instance SignQuery BatchPutAttributes where@@ -32,7 +33,7 @@ signQuery BatchPutAttributes{..} = sdbSignQuery $ [("Action", "BatchPutAttributes")- , ("DomainName", BU.fromString bpaDomainName)] +++ , ("DomainName", T.encodeUtf8 bpaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems instance ResponseIteratee BatchPutAttributesResponse where
Aws/SimpleDb/Commands/CreateDomain.hs view
@@ -9,11 +9,12 @@ import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data CreateDomain = CreateDomain {- cdDomainName :: String+ cdDomainName :: T.Text } deriving (Show) @@ -21,12 +22,12 @@ = CreateDomainResponse deriving (Show) -createDomain :: String -> CreateDomain+createDomain :: T.Text -> CreateDomain createDomain name = CreateDomain { cdDomainName = name } instance SignQuery CreateDomain where type Info CreateDomain = SdbInfo- signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", BU.fromString cdDomainName)]+ signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", T.encodeUtf8 cdDomainName)] instance ResponseIteratee CreateDomainResponse where type ResponseMetadata CreateDomainResponse = SdbMetadata
Aws/SimpleDb/Commands/DeleteAttributes.hs view
@@ -11,14 +11,15 @@ import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data DeleteAttributes = DeleteAttributes {- daItemName :: String+ daItemName :: T.Text , daAttributes :: [Attribute DeleteAttribute] , daExpected :: [Attribute ExpectedAttribute]- , daDomainName :: String+ , daDomainName :: T.Text } deriving (Show) @@ -26,7 +27,7 @@ = DeleteAttributesResponse deriving (Show) -deleteAttributes :: String -> [Attribute DeleteAttribute] -> String -> DeleteAttributes+deleteAttributes :: T.Text -> [Attribute DeleteAttribute] -> T.Text -> DeleteAttributes deleteAttributes item attributes domain = DeleteAttributes { daItemName = item , daAttributes = attributes@@ -38,7 +39,7 @@ type Info DeleteAttributes = SdbInfo signQuery DeleteAttributes{..} = sdbSignQuery $ - [("Action", "DeleteAttributes"), ("ItemName", BU.fromString daItemName), ("DomainName", BU.fromString daDomainName)] +++ [("Action", "DeleteAttributes"), ("ItemName", T.encodeUtf8 daItemName), ("DomainName", T.encodeUtf8 daDomainName)] ++ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected
Aws/SimpleDb/Commands/DeleteDomain.hs view
@@ -9,11 +9,12 @@ import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data DeleteDomain = DeleteDomain {- ddDomainName :: String+ ddDomainName :: T.Text } deriving (Show) @@ -21,12 +22,12 @@ = DeleteDomainResponse deriving (Show) -deleteDomain :: String -> DeleteDomain+deleteDomain :: T.Text -> DeleteDomain deleteDomain name = DeleteDomain { ddDomainName = name } instance SignQuery DeleteDomain where type Info DeleteDomain = SdbInfo- signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", BU.fromString ddDomainName)]+ signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", T.encodeUtf8 ddDomainName)] instance ResponseIteratee DeleteDomainResponse where type ResponseMetadata DeleteDomainResponse = SdbMetadata
Aws/SimpleDb/Commands/DomainMetadata.hs view
@@ -13,11 +13,12 @@ import Data.Time import Data.Time.Clock.POSIX import Text.XML.Enumerator.Cursor (($//), (&|))-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data DomainMetadata = DomainMetadata {- dmDomainName :: String+ dmDomainName :: T.Text } deriving (Show) @@ -33,12 +34,12 @@ } deriving (Show) -domainMetadata :: String -> DomainMetadata+domainMetadata :: T.Text -> DomainMetadata domainMetadata name = DomainMetadata { dmDomainName = name } instance SignQuery DomainMetadata where type Info DomainMetadata = SdbInfo- signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", BU.fromString dmDomainName)]+ signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", T.encodeUtf8 dmDomainName)] instance ResponseIteratee DomainMetadataResponse where type ResponseMetadata DomainMetadataResponse = SdbMetadata
Aws/SimpleDb/Commands/GetAttributes.hs view
@@ -15,33 +15,34 @@ import Control.Monad import Data.Maybe import Text.XML.Enumerator.Cursor (($//), (&|))-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Text.XML.Enumerator.Cursor as Cu data GetAttributes = GetAttributes {- gaItemName :: String- , gaAttributeName :: Maybe String+ gaItemName :: T.Text+ , gaAttributeName :: Maybe T.Text , gaConsistentRead :: Bool- , gaDomainName :: String+ , gaDomainName :: T.Text } deriving (Show) data GetAttributesResponse = GetAttributesResponse {- garAttributes :: [Attribute String]+ garAttributes :: [Attribute T.Text] } deriving (Show) -getAttributes :: String -> String -> GetAttributes+getAttributes :: T.Text -> T.Text -> GetAttributes getAttributes item domain = GetAttributes { gaItemName = item, gaAttributeName = Nothing, gaConsistentRead = False, gaDomainName = domain } instance SignQuery GetAttributes where type Info GetAttributes = SdbInfo signQuery GetAttributes{..} = sdbSignQuery $- [("Action", "GetAttributes"), ("ItemName", BU.fromString gaItemName), ("DomainName", BU.fromString gaDomainName)] ++- maybeToList (("AttributeName",) <$> BU.fromString <$> gaAttributeName) +++ [("Action", "GetAttributes"), ("ItemName", T.encodeUtf8 gaItemName), ("DomainName", T.encodeUtf8 gaDomainName)] +++ maybeToList (("AttributeName",) <$> T.encodeUtf8 <$> gaAttributeName) ++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)]) instance ResponseIteratee GetAttributesResponse where
Aws/SimpleDb/Commands/ListDomains.hs view
@@ -13,19 +13,20 @@ import Control.Applicative import Data.Maybe import Text.XML.Enumerator.Cursor (($//))-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data ListDomains = ListDomains { ldMaxNumberOfDomains :: Maybe Int- , ldNextToken :: Maybe String+ , ldNextToken :: Maybe T.Text } deriving (Show) data ListDomainsResponse = ListDomainsResponse {- ldrDomainNames :: [String]- , ldrNextToken :: Maybe String+ ldrDomainNames :: [T.Text]+ , ldrNextToken :: Maybe T.Text } deriving (Show) @@ -36,8 +37,8 @@ type Info ListDomains = SdbInfo signQuery ListDomains{..} = sdbSignQuery $ catMaybes [ Just ("Action", "ListDomains")- , ("MaxNumberOfDomains",) <$> BU.fromString <$> show <$> ldMaxNumberOfDomains- , ("NextToken",) <$> BU.fromString <$> ldNextToken+ , ("MaxNumberOfDomains",) . T.encodeUtf8 . T.pack . show <$> ldMaxNumberOfDomains+ , ("NextToken",) . T.encodeUtf8 <$> ldNextToken ] instance ResponseIteratee ListDomainsResponse where@@ -45,8 +46,8 @@ responseIteratee = sdbResponseIteratee parse where parse cursor = do sdbCheckResponseType () "ListDomainsResponse" cursor- let names = cursor $// elCont "DomainName"- let nextToken = listToMaybe $ cursor $// elCont "NextToken"+ let names = cursor $// elContent "DomainName"+ let nextToken = listToMaybe $ cursor $// elContent "NextToken" return $ ListDomainsResponse names nextToken instance Transaction ListDomains ListDomainsResponse
Aws/SimpleDb/Commands/PutAttributes.hs view
@@ -11,14 +11,15 @@ import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T data PutAttributes = PutAttributes {- paItemName :: String+ paItemName :: T.Text , paAttributes :: [Attribute SetAttribute] , paExpected :: [Attribute ExpectedAttribute]- , paDomainName :: String+ , paDomainName :: T.Text } deriving (Show) @@ -26,7 +27,7 @@ = PutAttributesResponse deriving (Show) -putAttributes :: String -> [Attribute SetAttribute] -> String -> PutAttributes+putAttributes :: T.Text -> [Attribute SetAttribute] -> T.Text -> PutAttributes putAttributes item attributes domain = PutAttributes { paItemName = item , paAttributes = attributes@@ -38,7 +39,7 @@ type Info PutAttributes = SdbInfo signQuery PutAttributes{..} = sdbSignQuery $ - [("Action", "PutAttributes"), ("ItemName", BU.fromString paItemName), ("DomainName", BU.fromString paDomainName)] +++ [("Action", "PutAttributes"), ("ItemName", T.encodeUtf8 paItemName), ("DomainName", T.encodeUtf8 paDomainName)] ++ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected
Aws/SimpleDb/Commands/Select.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} module Aws.SimpleDb.Commands.Select where @@ -12,37 +12,41 @@ import Aws.Transaction import Aws.Util import Aws.Xml+import Control.Applicative import Control.Monad import Data.Maybe import Text.XML.Enumerator.Cursor (($//), (&|))-import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Text.XML.Enumerator.Cursor as Cu data Select = Select {- sSelectExpression :: String+ sSelectExpression :: T.Text , sConsistentRead :: Bool- , sNextToken :: String+ , sNextToken :: Maybe T.Text } deriving (Show) data SelectResponse = SelectResponse {- srItems :: [Item [Attribute String]]- , srNextToken :: Maybe String+ srItems :: [Item [Attribute T.Text]]+ , srNextToken :: Maybe T.Text } deriving (Show) -select :: String -> Select-select expr = Select { sSelectExpression = expr, sConsistentRead = False, sNextToken = "" }+select :: T.Text -> Select+select expr = Select { sSelectExpression = expr, sConsistentRead = False, sNextToken = Nothing } instance SignQuery Select where type Info Select = SdbInfo signQuery Select{..}- = sdbSignQuery $- [("Action", "Select"), ("SelectExpression", BU.fromString sSelectExpression)] ++- (guard sConsistentRead >> [("ConsistentRead", awsTrue)]) ++- (guard (not $ null sNextToken) >> [("NextToken", BU.fromString sNextToken)])+ = sdbSignQuery . catMaybes $+ [ Just ("Action", "Select")+ , Just ("SelectExpression", T.encodeUtf8 sSelectExpression)+ , ("ConsistentRead", awsTrue) <$ guard sConsistentRead+ , (("NextToken",) . T.encodeUtf8) <$> sNextToken+ ] instance ResponseIteratee SelectResponse where type ResponseMetadata SelectResponse = SdbMetadata@@ -50,7 +54,7 @@ where parse cursor = do sdbCheckResponseType () "SelectResponse" cursor items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem- let nextToken = listToMaybe $ cursor $// elCont "NextToken"+ let nextToken = listToMaybe $ cursor $// elContent "NextToken" return $ SelectResponse items nextToken instance Transaction Select SelectResponse
Aws/SimpleDb/Metadata.hs view
@@ -2,14 +2,15 @@ module Aws.SimpleDb.Metadata where -import Control.Monad-import Data.Monoid-import Data.Typeable+import Control.Monad+import Data.Monoid+import Data.Typeable+import qualified Data.Text as T data SdbMetadata = SdbMetadata {- requestId :: Maybe String- , boxUsage :: Maybe String+ requestId :: Maybe T.Text+ , boxUsage :: Maybe T.Text } deriving (Show, Typeable)
Aws/SimpleDb/Model.hs view
@@ -9,69 +9,70 @@ 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 Data.Text as T+import qualified Data.Text.Encoding as T import qualified Text.XML.Enumerator.Cursor as Cu data Attribute a- = ForAttribute { attributeName :: String, attributeData :: a }+ = ForAttribute { attributeName :: T.Text, attributeData :: a } deriving (Show) -readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute String)+readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute T.Text) 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- = SetAttribute { setAttribute :: String, isReplaceAttribute :: Bool }+ = SetAttribute { setAttribute :: T.Text, isReplaceAttribute :: Bool } deriving (Show) attributeQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Attribute a -> [(B.ByteString, B.ByteString)]-attributeQuery f (ForAttribute name x) = ("Name", BU.fromString name) : f x+attributeQuery f (ForAttribute name x) = ("Name", T.encodeUtf8 name) : f x -addAttribute :: String -> String -> Attribute SetAttribute+addAttribute :: T.Text -> T.Text -> Attribute SetAttribute addAttribute name value = ForAttribute name (SetAttribute value False) -replaceAttribute :: String -> String -> Attribute SetAttribute+replaceAttribute :: T.Text -> T.Text -> Attribute SetAttribute replaceAttribute name value = ForAttribute name (SetAttribute value True) setAttributeQuery :: SetAttribute -> [(B.ByteString, B.ByteString)] setAttributeQuery (SetAttribute value replace)- = ("Value", BU.fromString value) : [("Replace", awsTrue) | replace]+ = ("Value", T.encodeUtf8 value) : [("Replace", awsTrue) | replace] data DeleteAttribute = DeleteAttribute- | ValuedDeleteAttribute { deleteAttributeValue :: String }+ | ValuedDeleteAttribute { deleteAttributeValue :: T.Text } deriving (Show) deleteAttributeQuery :: DeleteAttribute -> [(B.ByteString, B.ByteString)] deleteAttributeQuery DeleteAttribute = []-deleteAttributeQuery (ValuedDeleteAttribute value) = [("Value", BU.fromString value)]+deleteAttributeQuery (ValuedDeleteAttribute value) = [("Value", T.encodeUtf8 value)] data ExpectedAttribute- = ExpectedValue { expectedAttributeValue :: String }+ = ExpectedValue { expectedAttributeValue :: T.Text } | ExpectedExists { expectedAttributeExists :: Bool } deriving (Show) -expectedValue :: String -> String -> Attribute ExpectedAttribute+expectedValue :: T.Text -> T.Text -> Attribute ExpectedAttribute expectedValue name value = ForAttribute name (ExpectedValue value) -expectedExists :: String -> Bool -> Attribute ExpectedAttribute+expectedExists :: T.Text -> Bool -> Attribute ExpectedAttribute expectedExists name exists = ForAttribute name (ExpectedExists exists) expectedAttributeQuery :: ExpectedAttribute -> [(B.ByteString, B.ByteString)]-expectedAttributeQuery (ExpectedValue value) = [("Value", BU.fromString value)]+expectedAttributeQuery (ExpectedValue value) = [("Value", T.encodeUtf8 value)] expectedAttributeQuery (ExpectedExists exists) = [("Exists", awsBool exists)] data Item a- = Item { itemName :: String, itemData :: a }+ = Item { itemName :: T.Text, itemData :: a } deriving (Show) -readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute String])+readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute T.Text]) 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)]-itemQuery f (Item name x) = ("ItemName", BU.fromString name) : f x+itemQuery f (Item name x) = ("ItemName", T.encodeUtf8 name) : f x
Aws/SimpleDb/Query.hs view
@@ -13,7 +13,6 @@ import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as HTTP sdbSignQuery :: [(B.ByteString, B.ByteString)] -> SdbInfo -> SignatureData -> SignedQuery@@ -29,7 +28,8 @@ , sqAuthorization = Nothing , sqContentType = Nothing , sqContentMd5 = Nothing- , sqBody = L.empty+ , sqAmzHeaders = []+ , sqBody = Nothing , sqStringToSign = stringToSign } where
Aws/SimpleDb/Response.hs view
@@ -12,9 +12,9 @@ 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 Data.Text.Encoding as T import qualified Network.HTTP.Types as HTTP import qualified Text.XML.Enumerator.Cursor as Cu @@ -24,8 +24,8 @@ -> 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"+ = do let requestId' = listToMaybe $ cursor $// elContent "RequestID"+ let boxUsage' = listToMaybe $ cursor $// elContent "BoxUsage" tellMetadata $ SdbMetadata requestId' boxUsage' case cursor $/ Cu.laxElement "Error" of [] -> inner cursor@@ -41,14 +41,14 @@ 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 :: F.Failure XmlException m => Cu.Cursor -> m T.Text decodeBase64 cursor =- let encoded = T.unpack . T.concat $ cursor $/ Cu.content+ let encoded = 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+ Just "base64" -> case Base64.decode . T.encodeUtf8 $ encoded of Left msg -> F.failure $ XmlException ("Invalid Base64 data: " ++ msg)- Right x -> return x+ Right x -> return $ T.decodeUtf8 x Just actual -> F.failure $ XmlException ("Unrecognized encoding " ++ T.unpack actual)
Aws/Util.hs view
@@ -9,8 +9,9 @@ import Data.Time import System.Locale import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BU import qualified Data.Enumerator as En+import qualified Data.Text as T+import qualified Data.Text.Encoding as T tryError :: (Exception e, Monad m) => En.Iteratee a m b -> En.Iteratee a m (Either e b) tryError m = En.catchError (fmap Right m) h@@ -20,9 +21,9 @@ queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)] queryList f prefix xs = concat $ zipWith combine prefixList (map f xs)- where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..]+ where prefixList = map (dot prefix . T.encodeUtf8 . T.pack . show) [(1 :: Int) ..] combine pf = map $ first (pf `dot`)- dot x y = B.concat [x, BU.fromString ".", y]+ dot x y = B.concat [x, ".", y] awsBool :: Bool -> B.ByteString awsBool True = "true"@@ -35,7 +36,7 @@ awsFalse = awsBool False fmtTime :: String -> UTCTime -> B.ByteString-fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t+fmtTime s t = T.encodeUtf8 . T.pack $ formatTime defaultTimeLocale s t rfc822Time :: String rfc822Time = "%a, %_d %b %Y %H:%M:%S GMT"
Aws/Xml.hs view
@@ -25,6 +25,9 @@ instance C.Exception XmlException +elContent :: T.Text -> Cursor -> [T.Text]+elContent name = laxElement name &/ content+ elCont :: T.Text -> Cursor -> [String] elCont name = laxElement name &/ content &| T.unpack @@ -33,6 +36,11 @@ forceM :: F.Failure XmlException m => String -> [m a] -> m a forceM = Cu.forceM . XmlException++textReadInt :: (F.Failure XmlException m, Num a) => T.Text -> m a+textReadInt s = case reads $ T.unpack s of+ [(n,"")] -> return $ fromInteger n+ _ -> F.failure $ XmlException "Invalid Integer" readInt :: (F.Failure XmlException m, Num a) => String -> m a readInt s = case reads s of
aws.cabal view
@@ -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.4+Version: 0.0.5 -- A short (one-line) description of the package. Synopsis: Amazon Web Services (AWS) for Haskell@@ -59,6 +59,7 @@ Aws.S3.Commands, Aws.S3.Commands.GetBucket, Aws.S3.Commands.GetService,+ Aws.S3.Commands.PutBucket, Aws.S3.Error, Aws.S3.Info, Aws.S3.Metadata,@@ -95,6 +96,7 @@ base64-bytestring ==0.1.*, blaze-builder >=0.2.1.4 && <0.4, bytestring ==0.9.*,+ case-insensitive >=0.2 && <0.3, cereal ==0.3.*, containers >=0.3 && <0.5, crypto-api >= 0.5 && < 0.7,@@ -103,16 +105,16 @@ enumerator ==0.4.*, failure >=0.1.0.1 && <0.2, filepath >=1.1 && <1.3,- http-enumerator >=0.6 && < 0.7,+ http-enumerator >=0.6.5.5 && < 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,+ tls >=0.7.1 && <0.8, transformers >=0.2.2.0 && <0.3,- utf8-string ==0.3.*,- xml-enumerator >=0.3.3.667 && <0.4+ xml-enumerator >=0.3.4 && <0.4 GHC-Options: -Wall