diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -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 diff --git a/Aws/Credentials.hs b/Aws/Credentials.hs --- a/Aws/Credentials.hs +++ b/Aws/Credentials.hs @@ -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 diff --git a/Aws/Debug.hs b/Aws/Debug.hs --- a/Aws/Debug.hs +++ b/Aws/Debug.hs @@ -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 diff --git a/Aws/Http.hs b/Aws/Http.hs --- a/Aws/Http.hs +++ b/Aws/Http.hs @@ -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" diff --git a/Aws/Query.hs b/Aws/Query.hs --- a/Aws/Query.hs +++ b/Aws/Query.hs @@ -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 ] diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -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 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 @@ -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 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 @@ -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 diff --git a/Aws/S3/Commands/PutBucket.hs b/Aws/S3/Commands/PutBucket.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/PutBucket.hs @@ -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 diff --git a/Aws/S3/Error.hs b/Aws/S3/Error.hs --- a/Aws/S3/Error.hs +++ b/Aws/S3/Error.hs @@ -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) diff --git a/Aws/S3/Metadata.hs b/Aws/S3/Metadata.hs --- a/Aws/S3/Metadata.hs +++ b/Aws/S3/Metadata.hs @@ -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) diff --git a/Aws/S3/Model.hs b/Aws/S3/Model.hs --- a/Aws/S3/Model.hs +++ b/Aws/S3/Model.hs @@ -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 = "" diff --git a/Aws/S3/Query.hs b/Aws/S3/Query.hs --- a/Aws/S3/Query.hs +++ b/Aws/S3/Query.hs @@ -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) diff --git a/Aws/S3/Response.hs b/Aws/S3/Response.hs --- a/Aws/S3/Response.hs +++ b/Aws/S3/Response.hs @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/Aws/SimpleDb/Metadata.hs b/Aws/SimpleDb/Metadata.hs --- a/Aws/SimpleDb/Metadata.hs +++ b/Aws/SimpleDb/Metadata.hs @@ -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) diff --git a/Aws/SimpleDb/Model.hs b/Aws/SimpleDb/Model.hs --- a/Aws/SimpleDb/Model.hs +++ b/Aws/SimpleDb/Model.hs @@ -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 diff --git a/Aws/SimpleDb/Query.hs b/Aws/SimpleDb/Query.hs --- a/Aws/SimpleDb/Query.hs +++ b/Aws/SimpleDb/Query.hs @@ -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 diff --git a/Aws/SimpleDb/Response.hs b/Aws/SimpleDb/Response.hs --- a/Aws/SimpleDb/Response.hs +++ b/Aws/SimpleDb/Response.hs @@ -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) diff --git a/Aws/Util.hs b/Aws/Util.hs --- a/Aws/Util.hs +++ b/Aws/Util.hs @@ -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" diff --git a/Aws/Xml.hs b/Aws/Xml.hs --- a/Aws/Xml.hs +++ b/Aws/Xml.hs @@ -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 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.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