aws 0.10.5 → 0.11

raw patch · 10 files changed

+525/−170 lines, 10 filesdep ~data-defaultPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: data-default

API changes (from Hackage documentation)

Files

• Aws/Aws.hs +143/−80
• Aws/Core.hs +17/−17
• Aws/DynamoDb/Commands.hs +3/−1
• Aws/DynamoDb/Commands/DeleteItem.hs +113/−0
• Aws/DynamoDb/Core.hs +189/−19
• Aws/S3/Commands/Multipart.hs +28/−40
• Aws/S3/Core.hs +15/−8
• Examples/MultipartUpload.hs +1/−1
• README.org +11/−0
• aws.cabal +5/−4

@@ -1,4 +1,8 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE BangPatterns          #-}+ module Aws.Aws ( -- * Logging   LogLevel(..)@@ -13,6 +17,7 @@ , aws , awsRef , pureAws+, memoryAws , simpleAws   -- ** Unsafe runners , unsafeAws@@ -22,28 +27,31 @@   -- * Iterated runners --, awsIteratedAll , awsIteratedSource+, awsIteratedSource' , awsIteratedList+, awsIteratedList' ) where  import           Aws.Core import           Control.Applicative-import qualified Control.Exception.Lifted as E+import qualified Control.Exception.Lifted     as E import           Control.Monad import           Control.Monad.IO.Class import           Control.Monad.Trans import           Control.Monad.Trans.Resource-import qualified Data.ByteString      as B-import qualified Data.CaseInsensitive as CI-import qualified Data.Conduit         as C-import qualified Data.Conduit.List    as CL+import qualified Data.ByteString              as B+import qualified Data.ByteString.Lazy         as L+import qualified Data.CaseInsensitive         as CI+import qualified Data.Conduit                 as C+import qualified Data.Conduit.List            as CL import           Data.IORef import           Data.Monoid-import qualified Data.Text            as T-import qualified Data.Text.Encoding   as T-import qualified Data.Text.IO         as T-import qualified Network.HTTP.Conduit as HTTP-import           System.IO            (stderr)+import qualified Data.Text                    as T+import qualified Data.Text.Encoding           as T+import qualified Data.Text.IO                 as T+import qualified Network.HTTP.Conduit         as HTTP+import           System.IO                    (stderr)  -- | The severity of a log message, in rising order. data LogLevel@@ -68,11 +76,11 @@     = Configuration {         -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration         -- (absolute or relative).-        timeInfo :: TimeInfo+        timeInfo    :: TimeInfo         -- | AWS access credentials.       , credentials :: Credentials         -- | The error / message logger.-      , logger :: Logger+      , logger      :: Logger       }  -- | The default configuration, with credentials loaded from environment variable or configuration file@@ -95,29 +103,29 @@   return c { logger = defaultLog Debug }  -- | Run an AWS transaction, with HTTP manager and metadata wrapped in a 'Response'.--- +-- -- All errors are caught and wrapped in the 'Response' value.--- +-- -- Metadata is logged at level 'Info'.--- +-- -- Usage (with existing 'HTTP.Manager'): -- @ --     resp <- aws cfg serviceCfg manager request -- @ aws :: (Transaction r a)-      => Configuration -      -> ServiceConfiguration r NormalQuery -      -> HTTP.Manager -      -> r +      => Configuration+      -> ServiceConfiguration r NormalQuery+      -> HTTP.Manager+      -> r       -> ResourceT IO (Response (ResponseMetadata a) a) aws = unsafeAws  -- | Run an AWS transaction, with HTTP manager and metadata returned in an 'IORef'.--- +-- -- Errors are not caught, and need to be handled with exception handlers.--- +-- -- Metadata is not logged.--- +-- -- Usage (with existing 'HTTP.Manager'): -- @ --     ref <- newIORef mempty;@@ -126,55 +134,71 @@  -- Unfortunately, the ";" above seems necessary, as haddock does not want to split lines for me. awsRef :: (Transaction r a)-      => Configuration -      -> ServiceConfiguration r NormalQuery -      -> HTTP.Manager -      -> IORef (ResponseMetadata a) -      -> r +      => Configuration+      -> ServiceConfiguration r NormalQuery+      -> HTTP.Manager+      -> IORef (ResponseMetadata a)+      -> r       -> ResourceT IO a awsRef = unsafeAwsRef  -- | Run an AWS transaction, with HTTP manager and without metadata.--- +-- -- Metadata is logged at level 'Info'.--- +-- -- Usage (with existing 'HTTP.Manager'): -- @ --     resp <- aws cfg serviceCfg manager request -- @ pureAws :: (Transaction r a)-      => Configuration -      -> ServiceConfiguration r NormalQuery -      -> HTTP.Manager -      -> r +      => Configuration+      -> ServiceConfiguration r NormalQuery+      -> HTTP.Manager+      -> r       -> ResourceT IO a pureAws cfg scfg mgr req = readResponseIO =<< aws cfg scfg mgr req +-- | Run an AWS transaction, with HTTP manager and without metadata.+--+-- Metadata is logged at level 'Info'.+--+-- Usage (with existing 'HTTP.Manager'):+-- @+--     resp <- aws cfg serviceCfg manager request+-- @+memoryAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)+      => Configuration+      -> ServiceConfiguration r NormalQuery+      -> HTTP.Manager+      -> r+      -> io (MemoryResponse a)+memoryAws cfg scfg mgr req = liftIO $ runResourceT $ loadToMemory =<< readResponseIO =<< aws cfg scfg mgr req+ -- | Run an AWS transaction, /without/ HTTP manager and without metadata.--- +-- -- Metadata is logged at level 'Info'.--- +-- -- Note that this is potentially less efficient than using 'aws', because HTTP connections cannot be re-used.--- +-- -- Usage: -- @ --     resp <- simpleAws cfg serviceCfg request -- @ simpleAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)-            => Configuration +            => Configuration             -> ServiceConfiguration r NormalQuery-            -> r +            -> r             -> io (MemoryResponse a) simpleAws cfg scfg request   = liftIO $ HTTP.withManager $ \manager ->       loadToMemory =<< readResponseIO =<< aws cfg scfg manager request  -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.--- +-- -- This is especially useful for debugging and development, you should not have to use it in production.--- +-- -- All errors are caught and wrapped in the 'Response' value.--- +-- -- Metadata is wrapped in the Response, and also logged at level 'Info'. unsafeAws   :: (ResponseConsumer r a,@@ -195,11 +219,11 @@   return $ Response metadata resp  -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.--- +-- -- This is especially useful for debugging and development, you should not have to use it in production.--- +-- -- Errors are not caught, and need to be handled with exception handlers.--- +-- -- Metadata is put in the 'IORef', but not logged. unsafeAwsRef   :: (ResponseConsumer r a,@@ -208,25 +232,25 @@      Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a unsafeAwsRef cfg info manager metadataRef request = do   sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg-  let q = signQuery request info sd+  let !q = {-# SCC "unsafeAwsRef:signQuery" #-} signQuery request info sd   let logDebug = liftIO . logger cfg Debug . T.pack   logDebug $ "String to sign: " ++ show (sqStringToSign q)-  httpRequest <- liftIO $ queryToHttpRequest q+  !httpRequest <- {-# SCC "unsafeAwsRef:httpRequest" #-} liftIO $ queryToHttpRequest q   logDebug $ "Host: " ++ show (HTTP.host httpRequest)   logDebug $ "Path: " ++ show (HTTP.path httpRequest)   logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest)   case HTTP.requestBody httpRequest of-    HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show lbs-    HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show bs+    HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show (L.take 1000 lbs)+    HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show (B.take 1000 bs)     _ -> return ()-  hresp <- HTTP.http httpRequest manager+  hresp <- {-# SCC "unsafeAwsRef:http" #-} HTTP.http httpRequest manager   logDebug $ "Response status: " ++ show (HTTP.responseStatus hresp)   forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $     logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'"-  responseConsumer request metadataRef hresp+  {-# SCC "unsafeAwsRef:responseConsumer" #-} responseConsumer request metadataRef hresp  -- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests.--- +-- -- Usage: -- @ --     uri <- awsUri cfg request@@ -253,37 +277,76 @@   where go request prevResp = do Response meta respAttempt <- aws cfg scfg manager request                                  case maybeCombineIteratedResponse prevResp <$> respAttempt of                                    f@(Failure _) -> return (Response [meta] f)-                                   s@(Success resp) -> +                                   s@(Success resp) ->                                      case nextIteratedRequest request resp of-                                       Nothing -> +                                       Nothing ->                                          return (Response [meta] s)-                                       Just nextRequest -> +                                       Just nextRequest ->                                          mapMetadata (meta:) `liftM` go nextRequest (Just resp) -} -awsIteratedSource :: (IteratedTransaction r a)-                     => Configuration-                     -> ServiceConfiguration r NormalQuery-                     -> HTTP.Manager-                     -> r-                     -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a)-awsIteratedSource cfg scfg manager req_ = go req_-  where go request = do resp <- lift $ aws cfg scfg manager request-                        C.yield resp-                        case responseResult resp of-                          Left _  -> return ()-                          Right x ->-                            case nextIteratedRequest request x of-                              Nothing -> return ()-                              Just nextRequest -> go nextRequest+awsIteratedSource+    :: (IteratedTransaction r a)+    => Configuration+    -> ServiceConfiguration r NormalQuery+    -> HTTP.Manager+    -> r+    -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a)+awsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_+  where+    run r = do+        res <- aws cfg scfg manager r+        a <- readResponseIO res+        return (a, res) -awsIteratedList :: (IteratedTransaction r a, ListResponse a i)-                     => Configuration-                     -> ServiceConfiguration r NormalQuery-                     -> HTTP.Manager-                     -> r-                     -> C.Producer (ResourceT IO) i-awsIteratedList cfg scfg manager req-  = awsIteratedSource cfg scfg manager req-    C.=$=-    CL.concatMapM (fmap listResponse . readResponseIO)++awsIteratedList+    :: (IteratedTransaction r a, ListResponse a i)+    => Configuration+    -> ServiceConfiguration r NormalQuery+    -> HTTP.Manager+    -> r+    -> C.Producer (ResourceT IO) i+awsIteratedList cfg scfg manager req = awsIteratedList' run req+  where+    run r = readResponseIO =<< aws cfg scfg manager r+++-------------------------------------------------------------------------------+-- | A more flexible version of 'awsIteratedSource' that uses a+-- user-supplied run function. Useful for embedding AWS functionality+-- within application specific monadic contexts.+awsIteratedSource'+    :: (Monad m, IteratedTransaction r a)+    => (r -> m (a, b))+    -- ^ A runner function for executing transactions.+    -> r+    -- ^ An initial request+    -> C.Producer m b+awsIteratedSource' run r0 = go r0+    where+      go q = do+          (a, b) <- lift $ run q+          C.yield b+          case nextIteratedRequest q a of+            Nothing -> return ()+            Just q' -> go q'+++-------------------------------------------------------------------------------+-- | A more flexible version of 'awsIteratedList' that uses a+-- user-supplied run function. Useful for embedding AWS functionality+-- within application specific monadic contexts.+awsIteratedList'+    :: (Monad m, IteratedTransaction r b, ListResponse b c)+    => (r -> m b)+    -- ^ A runner function for executing transactions.+    -> r+    -- ^ An initial request+    -> C.Producer m c+awsIteratedList' run r0 =+    awsIteratedSource' run' r0 C.=$=+    CL.concatMap listResponse+  where+    dupl a = (a,a)+    run' r = dupl `liftM` run r

@@ -230,10 +230,10 @@ -- resides in 'SignQuery' and 'ResponseConsumer' respectively. class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a))       => Transaction r a-      | r -> a, a -> r+      | r -> a  -- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits.-class Transaction r a => IteratedTransaction r a | r -> a , a -> r where+class Transaction r a => IteratedTransaction r a | r -> a where     nextIteratedRequest :: r -> a -> Maybe r  -- | Signature version 4: ((region, service),(date,key))@@ -408,37 +408,37 @@ data SignedQuery     = SignedQuery {         -- | Request method.-        sqMethod :: Method+        sqMethod :: !Method         -- | Protocol to be used.-      , sqProtocol :: Protocol+      , sqProtocol :: !Protocol         -- | HTTP host.-      , sqHost :: B.ByteString+      , sqHost :: !B.ByteString         -- | IP port.-      , sqPort :: Int+      , sqPort :: !Int         -- | HTTP path.-      , sqPath :: B.ByteString+      , sqPath :: !B.ByteString         -- | Query string list (used with 'Get' and 'PostQuery').-      , sqQuery :: HTTP.Query+      , sqQuery :: !HTTP.Query         -- | Request date/time.-      , sqDate :: Maybe UTCTime+      , sqDate :: !(Maybe UTCTime)         -- | Authorization string (if applicable), for @Authorization@ header.  See 'authorizationV4'-      , sqAuthorization :: Maybe (IO B.ByteString)+      , sqAuthorization :: !(Maybe (IO B.ByteString))         -- | Request body content type.-      , sqContentType :: Maybe B.ByteString+      , sqContentType :: !(Maybe B.ByteString)         -- | Request body content MD5.-      , sqContentMd5 :: Maybe (Digest MD5)+      , sqContentMd5 :: !(Maybe (Digest MD5))         -- | Additional Amazon "amz" headers.-      , sqAmzHeaders :: HTTP.RequestHeaders+      , sqAmzHeaders :: !HTTP.RequestHeaders         -- | Additional non-"amz" headers.-      , sqOtherHeaders :: HTTP.RequestHeaders+      , sqOtherHeaders :: !HTTP.RequestHeaders         -- | Request body (used with 'Post' and 'Put'). #if MIN_VERSION_http_conduit(2, 0, 0)-      , sqBody :: Maybe HTTP.RequestBody+      , sqBody :: !(Maybe HTTP.RequestBody) #else-      , sqBody :: Maybe (HTTP.RequestBody (C.ResourceT IO))+      , sqBody :: !(Maybe (HTTP.RequestBody (C.ResourceT IO))) #endif         -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes.-      , sqStringToSign :: B.ByteString+      , sqStringToSign :: !B.ByteString       }     --deriving (Show) 

@@ -1,5 +1,6 @@ module Aws.DynamoDb.Commands-    ( module Aws.DynamoDb.Commands.GetItem+    ( module Aws.DynamoDb.Commands.DeleteItem+    , module Aws.DynamoDb.Commands.GetItem     , module Aws.DynamoDb.Commands.PutItem     , module Aws.DynamoDb.Commands.Query     , module Aws.DynamoDb.Commands.Scan@@ -8,6 +9,7 @@     ) where  -------------------------------------------------------------------------------+import           Aws.DynamoDb.Commands.DeleteItem import           Aws.DynamoDb.Commands.GetItem import           Aws.DynamoDb.Commands.PutItem import           Aws.DynamoDb.Commands.Query

@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.DeleteItem+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability   :  experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_DeleteItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.DeleteItem where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import qualified Data.Text           as T+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++data DeleteItem = DeleteItem {+      diTable   :: T.Text+    -- ^ Target table+    , diKey     :: PrimaryKey+    -- ^ The item to delete.+    , diExpect  :: Conditions+    -- ^ (Possible) set of expections for a conditional Put+    , diReturn  :: UpdateReturn+    -- ^ What to return from this query.+    , diRetCons :: ReturnConsumption+    , diRetMet  :: ReturnItemCollectionMetrics+    } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'DeleteItem' request.+deleteItem :: T.Text+        -- ^ A Dynamo table name+        -> PrimaryKey+        -- ^ Item to be saved+        -> DeleteItem+deleteItem tn key = DeleteItem tn key def def def def+++instance ToJSON DeleteItem where+    toJSON DeleteItem{..} =+        object $ expectsJson diExpect +++          [ "TableName" .= diTable+          , "Key" .= diKey+          , "ReturnValues" .= diReturn+          , "ReturnConsumedCapacity" .= diRetCons+          , "ReturnItemCollectionMetrics" .= diRetMet+          ]++++data DeleteItemResponse = DeleteItemResponse {+      dirAttrs    :: Maybe Item+    -- ^ Old attributes, if requested+    , dirConsumed :: Maybe ConsumedCapacity+    -- ^ Amount of capacity consumed+    , dirColMet   :: Maybe ItemCollectionMetrics+    -- ^ Collection metrics if they have been requested.+    } deriving (Eq,Show,Read,Ord)++++instance Transaction DeleteItem DeleteItemResponse+++instance SignQuery DeleteItem where+    type ServiceConfiguration DeleteItem = DdbConfiguration+    signQuery gi = ddbSignQuery "DeleteItem" gi+++instance FromJSON DeleteItemResponse where+    parseJSON (Object v) = DeleteItemResponse+        <$> v .:? "Attributes"+        <*> v .:? "ConsumedCapacity"+        <*> v .:? "ItemCollectionMetrics"+    parseJSON _ = fail "DeleteItemResponse must be an object."+++instance ResponseConsumer r DeleteItemResponse where+    type ResponseMetadata DeleteItemResponse = DdbResponse+    responseConsumer _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse DeleteItemResponse where+    type MemoryResponse DeleteItemResponse = DeleteItemResponse+    loadToMemory = return++++++++

@@ -1,20 +1,22 @@-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Aws.DynamoDb.Core -- Copyright   :  Soostone Inc, Chris Allen -- License     :  BSD3 ----- Maintainer  :  Ozgun Ataman, Chris Allen+-- Maintainer  :  Ozgun Ataman <ozgun.ataman@soostone.com> -- Stability   :  experimental -- -- Shared types and utilities for DyanmoDb functionality.@@ -65,6 +67,12 @@     , Item     , item     , attributes+    , ToDynItem (..)+    , FromDynItem (..)+    , fromItem+    , Parser (..)+    , getAttr+    , getAttr'      -- * Common types used by operations     , Conditions (..)@@ -80,7 +88,7 @@     , ItemCollectionMetrics (..)     , ReturnItemCollectionMetrics (..)     , UpdateReturn (..)-    , QuerySelect+    , QuerySelect (..)     , querySelectJson      -- * Size estimation@@ -137,6 +145,7 @@ import qualified Data.Serialize               as Ser import qualified Data.Set                     as S import           Data.String+import           Data.Tagged import qualified Data.Text                    as T import qualified Data.Text.Encoding           as T import           Data.Time@@ -360,13 +369,13 @@   --------------------------------------------------------------------------------pico :: Integer-pico = 10 ^ (12 :: Integer)+pico :: Rational+pico = toRational $ 10 ^ (12 :: Integer)   ------------------------------------------------------------------------------- dayPico :: Integer-dayPico = 86400 * pico+dayPico = 86400 * round pico   -------------------------------------------------------------------------------@@ -376,8 +385,7 @@ toTS :: UTCTime -> Integer toTS (UTCTime (ModifiedJulianDay i) diff) = i' + diff'     where-      diff' = floor (toRational diff * pico')-      pico' = toRational pico+      diff' = floor (toRational diff * pico)       i' = i * dayPico  @@ -389,7 +397,7 @@ fromTS i = UTCTime (ModifiedJulianDay days) diff     where       (days, secs) = i `divMod` dayPico-      diff = fromRational ((toRational secs) / toRational pico)+      diff = fromRational ((toRational secs) / pico)   -- | Encoded as 0 and 1.@@ -408,7 +416,8 @@ -- | Type wrapper for binary data to be written to DynamoDB. Wrap any -- 'Serialize' instance in there and 'DynVal' will know how to -- automatically handle conversions in binary form.-newtype Bin a = Bin a deriving (Eq,Show,Read,Ord)+newtype Bin a = Bin { getBin :: a }+    deriving (Eq,Show,Read,Ord,Typeable,Enum)   instance (Ser.Serialize a) => DynVal (Bin a) where@@ -549,6 +558,7 @@ showT :: Show a => a -> T.Text showT = T.pack . show + instance ToJSON DValue where     toJSON (DNum i) = object ["N" .= showT i]     toJSON (DString i) = object ["S" .= i]@@ -1139,5 +1149,165 @@       DStringSet s | S.null s -> True       DBinSet s | S.null s -> True       _ -> False+++++-------------------------------------------------------------------------------+--+-- | Item Parsing+--+-------------------------------------------------------------------------------++++-- | Failure continuation.+type Failure f r   = String -> f r++-- | Success continuation.+type Success a f r = a -> f r+++-- | A continuation-based parser type.+newtype Parser a = Parser {+      runParser :: forall f r.+                   Failure f r+                -> Success a f r+                -> f r+    }++instance Monad Parser where+    m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks+                                 in runParser m kf ks'+    {-# INLINE (>>=) #-}+    return a = Parser $ \_kf ks -> ks a+    {-# INLINE return #-}+    fail msg = Parser $ \kf _ks -> kf msg+    {-# INLINE fail #-}++instance Functor Parser where+    fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)+                                  in runParser m kf ks'+    {-# INLINE fmap #-}++instance Applicative Parser where+    pure  = return+    {-# INLINE pure #-}+    (<*>) = apP+    {-# INLINE (<*>) #-}++instance Alternative Parser where+    empty = fail "empty"+    {-# INLINE empty #-}+    (<|>) = mplus+    {-# INLINE (<|>) #-}++instance MonadPlus Parser where+    mzero = fail "mzero"+    {-# INLINE mzero #-}+    mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks+                                   in runParser a kf' ks+    {-# INLINE mplus #-}++instance Monoid (Parser a) where+    mempty  = fail "mempty"+    {-# INLINE mempty #-}+    mappend = mplus+    {-# INLINE mappend #-}++apP :: Parser (a -> b) -> Parser a -> Parser b+apP d e = do+  b <- d+  a <- e+  return (b a)+{-# INLINE apP #-}+++-------------------------------------------------------------------------------+-- | Types convertible to DynamoDb 'Item' collections.+--+-- Use 'attr' and 'attrAs' combinators to conveniently define instances.+class ToDynItem a where+    toItem :: a -> Item+++-------------------------------------------------------------------------------+-- | Types parseable from DynamoDb 'Item' collections.+--+-- User 'getAttr' family of functions to applicatively or monadically+-- parse into your custom types.+class FromDynItem a where+    parseItem :: Item -> Parser a+++instance ToDynItem Item where toItem = id++instance FromDynItem Item where parseItem = return+++instance DynVal a => ToDynItem [(T.Text, a)] where+    toItem as = item $ map (uncurry attr) as++instance (Typeable a, DynVal a) => FromDynItem [(T.Text, a)] where+    parseItem i = mapM f $ M.toList i+        where+          f (k,v) = do+              v' <- maybe (fail (valErr (Tagged v :: Tagged a DValue))) return $+                    fromValue v+              return (k, v')+++instance DynVal a => ToDynItem (M.Map T.Text a) where+    toItem m = toItem $ M.toList m+++instance (Typeable a, DynVal a) => FromDynItem (M.Map T.Text a) where+    parseItem i = M.fromList <$> parseItem i+++valErr :: forall a. Typeable a => Tagged a DValue -> String+valErr (Tagged dv) = "Can't convert DynamoDb value " <> show dv <>+              " into type " <> (show (typeOf (undefined :: a)))+++-- | Convenience combinator for parsing fields from an 'Item' returned+-- by DynamoDb.+getAttr+    :: forall a. (Typeable a, DynVal a)+    => T.Text+    -- ^ Attribute name+    -> Item+    -- ^ Item from DynamoDb+    -> Parser a+getAttr k m = do+    case M.lookup k m of+      Nothing -> fail ("Key " <> T.unpack k <> " not found")+      Just dv -> maybe (fail (valErr (Tagged dv :: Tagged a DValue))) return $ fromValue dv+++-- | Parse attribute if it's present in the 'Item'. Fail if attribute+-- is present but conversion fails.+getAttr'+    :: forall a. (Typeable a, DynVal a)+    => T.Text+    -- ^ Attribute name+    -> Item+    -- ^ Item from DynamoDb+    -> Parser (Maybe a)+getAttr' k m = do+    case M.lookup k m of+      Nothing -> return Nothing+      Just dv -> return $ fromValue dv+++-------------------------------------------------------------------------------+-- | Parse an 'Item' into target type using the 'FromDynItem'+-- instance.+fromItem :: FromDynItem a => Item -> Either String a+fromItem i = runParser (parseItem i) Left Right++++  

@@ -5,14 +5,14 @@ import           Aws.S3.Core import           Control.Applicative import           Control.Arrow         (second)+import           Control.Monad.IO.Class import           Control.Monad.Trans.Resource import           Crypto.Hash-import qualified Crypto.Hash.MD5       as MD5 import           Data.ByteString.Char8 ({- IsString -}) import           Data.Conduit-import qualified Data.Conduit.Binary   as CB import qualified Data.Conduit.List     as CL import           Data.Maybe+import           Data.Monoid import           Text.XML.Cursor       (($/)) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy  as BL@@ -22,7 +22,6 @@ import qualified Data.Text.Encoding    as T import qualified Network.HTTP.Conduit  as HTTP import qualified Network.HTTP.Types    as HTTP-import           Text.Printf(printf) import qualified Text.XML              as XML  {-@@ -66,9 +65,9 @@  data InitiateMultipartUploadResponse   = InitiateMultipartUploadResponse {-      imurBucket   :: Bucket-    , imurKey      :: T.Text-    , imurUploadId :: T.Text+      imurBucket   :: !Bucket+    , imurKey      :: !T.Text+    , imurUploadId :: !T.Text     }  -- | ServiceConfiguration: 'S3Configuration'@@ -141,7 +140,8 @@  data UploadPartResponse   = UploadPartResponse {-      uprVersionId :: Maybe T.Text+      uprVersionId :: !(Maybe T.Text),+      uprETag :: !T.Text     }   deriving (Show) @@ -170,7 +170,8 @@     type ResponseMetadata UploadPartResponse = S3Metadata     responseConsumer _ = s3ResponseConsumer $ \resp -> do       let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp)-      return $ UploadPartResponse vid+      let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp)+      return $ UploadPartResponse vid etag  instance Transaction UploadPart UploadPartResponse @@ -200,10 +201,10 @@  data CompleteMultipartUploadResponse   = CompleteMultipartUploadResponse {-      cmurLocation :: T.Text-    , cmurBucket   :: Bucket-    , cmurKey      :: T.Text-    , cmurETag     :: T.Text+      cmurLocation :: !T.Text+    , cmurBucket   :: !Bucket+    , cmurKey      :: !T.Text+    , cmurETag     :: !T.Text     }  -- | ServiceConfiguration: 'S3Configuration'@@ -333,13 +334,13 @@   -> HTTP.Manager   -> T.Text   -> T.Text-  -> ResourceT IO T.Text+  -> IO T.Text getUploadId cfg s3cfg mgr bucket object = do   InitiateMultipartUploadResponse {       imurBucket = _bucket     , imurKey = _object'     , imurUploadId = uploadId-    } <- pureAws cfg s3cfg mgr $ postInitiateMultipartUpload bucket object+    } <- memoryAws cfg s3cfg mgr $ postInitiateMultipartUpload bucket object   return uploadId  @@ -350,21 +351,13 @@   -> T.Text   -> T.Text   -> T.Text-  -> [String]-  -> ResourceT IO ()+  -> [T.Text]+  -> IO () sendEtag cfg s3cfg mgr bucket object uploadId etags = do-  _ <- pureAws cfg s3cfg mgr $-       postCompleteMultipartUpload bucket object uploadId (zip [1..] (map T.pack etags))+  _ <- memoryAws cfg s3cfg mgr $+       postCompleteMultipartUpload bucket object uploadId (zip [1..] etags)   return () --bstr2str :: B8.ByteString -> String-bstr2str bstr =-  foldr1 (++) $ map toHex $ B8.unpack bstr-  where-    toHex :: Char -> String-    toHex chr = printf "%02x" chr- putConduit ::   MonadResource m =>   Configuration@@ -373,29 +366,24 @@   -> T.Text   -> T.Text   -> T.Text-  -> Conduit B8.ByteString m String+  -> Conduit BL.ByteString m T.Text putConduit cfg s3cfg mgr bucket object uploadId = loop 1   where     loop n = do       v' <- await       case v' of         Just v -> do-          let str= (BL.fromStrict v)-          _ <- liftResourceT $ pureAws cfg s3cfg mgr $-            uploadPart bucket object n uploadId-            (HTTP.requestBodySource-             (BL.length str)-             (CB.sourceLbs str)-            )-          let etag= bstr2str $ MD5.hash v+          UploadPartResponse _ etag <- memoryAws cfg s3cfg mgr $+            uploadPart bucket object n uploadId (HTTP.RequestBodyLBS v)           yield etag           loop (n+1)         Nothing -> return () -chunkedConduit :: (MonadResource m) => Integer -> Conduit B8.ByteString m B8.ByteString+chunkedConduit :: (MonadResource m) => Integer -> Conduit B8.ByteString m BL.ByteString chunkedConduit size = do   loop 0 ""   where+    loop :: MonadResource m => Int -> BL.ByteString -> Conduit B8.ByteString m BL.ByteString     loop cnt str = do       line' <- await       case line' of @@ -403,8 +391,8 @@           yield str           return ()         Just line -> do-          let len = (B8.length line)+cnt-          let newStr = B8.concat [str, line]+          let len = B8.length line+cnt+          let newStr = str <> BL.fromStrict line           if len >= (fromIntegral size)             then do             yield newStr@@ -422,9 +410,9 @@   -> Integer   -> ResourceT IO () multipartUpload cfg s3cfg mgr bucket object src chunkSize = do-  uploadId <- getUploadId cfg s3cfg mgr bucket object+  uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket object   etags <- src            $= chunkedConduit chunkSize            $= putConduit cfg s3cfg mgr bucket object uploadId            $$ CL.consume-  sendEtag cfg s3cfg mgr bucket object uploadId etags+  liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-} module Aws.S3.Core where  import           Aws.Core@@ -26,6 +26,7 @@ import qualified Data.ByteString.Char8          as B8 import qualified Data.ByteString.Base64         as Base64 import qualified Data.CaseInsensitive           as CI+import qualified Data.Conduit                   as C import qualified Data.Text                      as T import qualified Data.Text.Encoding             as T import qualified Network.HTTP.Conduit           as HTTP@@ -218,9 +219,19 @@             , ("Signature", sig)] ++ iamTok  s3ResponseConsumer :: HTTPResponseConsumer a+                         -> IORef S3Metadata+                         -> HTTPResponseConsumer a+s3ResponseConsumer inner metadataRef = s3BinaryResponseConsumer inner' metadataRef+  where inner' resp =+          do+            !res <- inner resp+            C.closeResumableSource (HTTP.responseBody resp)+            return res++s3BinaryResponseConsumer :: HTTPResponseConsumer a                    -> IORef S3Metadata                    -> HTTPResponseConsumer a-s3ResponseConsumer inner metadata resp = do+s3BinaryResponseConsumer inner metadata resp = do       let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)       let amzId2 = headerString "x-amz-id-2"       let requestId = headerString "x-amz-request-id"@@ -238,11 +249,6 @@ s3XmlResponseConsumer parse metadataRef =     s3ResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef -s3BinaryResponseConsumer :: HTTPResponseConsumer a-                         -> IORef S3Metadata-                         -> HTTPResponseConsumer a-s3BinaryResponseConsumer inner metadataRef = s3ResponseConsumer inner metadataRef- s3ErrorResponseConsumer :: HTTPResponseConsumer a s3ErrorResponseConsumer resp     = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def@@ -438,11 +444,12 @@  type LocationConstraint = T.Text -locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint+locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint locationUsClassic = "" locationUsWest = "us-west-1" locationUsWest2 = "us-west-2" locationEu = "EU"+locationEuFrankfurt = "eu-central-1" locationApSouthEast = "ap-southeast-1" locationApSouthEast2 = "ap-southeast-2" locationApNorthEast = "ap-northeast-1"

@@ -11,7 +11,7 @@ main :: IO () main = do   {- Set up AWS credentials and the default configuration. -}-  cfg <- Aws.baseConfiguration+  cfg <- Aws.dbgConfiguration   let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery    args <- getArgs

@@ -88,6 +88,14 @@  * Release Notes +** 0.11 series++- 0.11+  - New functions for running AWS transactions+  - Performance optimizations for DynamoDB and S3 MultiPartUpload+  - New DynamoDB commands & features+  - S3 endpoint eu-central-1+ ** 0.10 series  - 0.10.5@@ -120,6 +128,9 @@   - core: fix typo in NoCredentialsException accessor  ** 0.9 series++- 0.9.4+  - allow conduit 1.2  - 0.9.3   - fix performance regression for loadCredentialsDefault

@@ -1,5 +1,5 @@ Name:                aws-Version:             0.10.5+Version:             0.11 Synopsis:            Amazon Web Services (AWS) for Haskell Description:         Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at <https://github.com/aristidb/aws/blob/master/README.org>. Homepage:            http://github.com/aristidb/aws@@ -20,7 +20,7 @@ Source-repository this   type: git   location: https://github.com/aristidb/aws.git-  tag: 0.10.5+  tag: 0.11  Source-repository head   type: git@@ -37,6 +37,7 @@                        Aws.Core                        Aws.DynamoDb                        Aws.DynamoDb.Commands+                       Aws.DynamoDb.Commands.DeleteItem                        Aws.DynamoDb.Commands.GetItem                        Aws.DynamoDb.Commands.PutItem                        Aws.DynamoDb.Commands.Query@@ -122,8 +123,8 @@                        conduit              >= 1.1     && < 1.3,                        conduit-extra        >= 1.1     && < 1.2,                        containers           >= 0.4,-                       cryptohash           >= 0.11     && < 0.12,-                       data-default         == 0.5.*,+                       cryptohash           >= 0.11    && < 0.12,+                       data-default         >= 0.5.3   && < 0.6,                        directory            >= 1.0     && < 1.3,                        filepath             >= 1.1     && < 1.4,                        http-conduit         >= 2.1     && < 2.2,