aws 0.20 → 0.25.3
raw patch · 53 files changed
Files
- Aws.hs +1/−0
- Aws/Aws.hs +7/−6
- Aws/Core.hs +22/−8
- Aws/DynamoDb/Commands/BatchWriteItem.hs +2/−2
- Aws/DynamoDb/Commands/DeleteItem.hs +1/−1
- Aws/DynamoDb/Commands/PutItem.hs +1/−1
- Aws/DynamoDb/Commands/Table.hs +2/−2
- Aws/DynamoDb/Commands/UpdateItem.hs +4/−3
- Aws/DynamoDb/Core.hs +37/−23
- Aws/Iam/Commands.hs +21/−1
- Aws/Iam/Commands/AddUserToGroup.hs +47/−0
- Aws/Iam/Commands/CreateGroup.hs +53/−0
- Aws/Iam/Commands/DeleteGroup.hs +37/−0
- Aws/Iam/Commands/DeleteGroupPolicy.hs +47/−0
- Aws/Iam/Commands/GetGroupPolicy.hs +72/−0
- Aws/Iam/Commands/GetUser.hs +1/−1
- Aws/Iam/Commands/GetUserPolicy.hs +1/−1
- Aws/Iam/Commands/ListGroupPolicies.hs +71/−0
- Aws/Iam/Commands/ListGroups.hs +76/−0
- Aws/Iam/Commands/PutGroupPolicy.hs +51/−0
- Aws/Iam/Commands/RemoveUserFromGroup.hs +47/−0
- Aws/Iam/Commands/UpdateGroup.hs +53/−0
- Aws/Iam/Core.hs +34/−0
- Aws/Iam/Internal.hs +1/−1
- Aws/S3/Commands.hs +6/−0
- Aws/S3/Commands/DeleteObjects.hs +2/−1
- Aws/S3/Commands/GetBucketVersioning.hs +65/−0
- Aws/S3/Commands/GetObject.hs +1/−1
- Aws/S3/Commands/HeadObject.hs +1/−1
- Aws/S3/Commands/Multipart.hs +20/−20
- Aws/S3/Commands/PutBucketVersioning.hs +71/−0
- Aws/S3/Commands/PutObject.hs +22/−15
- Aws/S3/Commands/RestoreObject.hs +112/−0
- Aws/S3/Core.hs +82/−52
- Aws/Ses/Commands/GetIdentityDkimAttributes.hs +2/−1
- Aws/Ses/Commands/GetIdentityNotificationAttributes.hs +2/−1
- Aws/Ses/Commands/GetIdentityVerificationAttributes.hs +2/−1
- Aws/Ses/Commands/ListIdentities.hs +2/−1
- Aws/Ses/Commands/SendRawEmail.hs +2/−1
- Aws/Ses/Commands/SetIdentityNotificationTopic.hs +2/−1
- Aws/Sqs/Commands/Message.hs +4/−4
- CHANGELOG.md +92/−4
- Examples/DynamoDb.hs +1/−1
- Examples/MultipartUpload.hs +2/−2
- Examples/NukeBucket.hs +1/−1
- Examples/Sqs.hs +1/−1
- README.md +4/−3
- aws.cabal +38/−28
- tests/DynamoDb/Main.hs +3/−2
- tests/DynamoDb/Utils.hs +2/−1
- tests/S3/Main.hs +5/−5
- tests/Sqs/Main.hs +7/−5
- tests/Utils.hs +3/−2
Aws.hs view
@@ -58,6 +58,7 @@ , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault+, anonymousCredentials ) where
Aws/Aws.hs view
@@ -51,6 +51,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Client.TLS as HTTP import System.IO (stderr) import Prelude @@ -193,7 +194,7 @@ -> r -> io (MemoryResponse a) simpleAws cfg scfg request = liftIO $ runResourceT $ do- manager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings+ manager <- liftIO HTTP.getGlobalManager loadToMemory =<< readResponseIO =<< aws cfg scfg manager request -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.@@ -295,7 +296,7 @@ -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r- -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a)+ -> forall i. C.ConduitT i (Response (ResponseMetadata a) a) (ResourceT IO) () awsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_ where run r = do@@ -310,7 +311,7 @@ -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r- -> C.Producer (ResourceT IO) i+ -> forall j. C.ConduitT j i (ResourceT IO) () awsIteratedList cfg scfg manager req = awsIteratedList' run req where run r = readResponseIO =<< aws cfg scfg manager r@@ -326,7 +327,7 @@ -- ^ A runner function for executing transactions. -> r -- ^ An initial request- -> C.Producer m b+ -> forall i. C.ConduitT i b m () awsIteratedSource' run r0 = go r0 where go q = do@@ -347,9 +348,9 @@ -- ^ A runner function for executing transactions. -> r -- ^ An initial request- -> C.Producer m c+ -> forall i. C.ConduitT i c m () awsIteratedList' run r0 =- awsIteratedSource' run' r0 C.=$=+ awsIteratedSource' run' r0 `C.fuse` CL.concatMap listResponse where dupl a = (a,a)
Aws/Core.hs view
@@ -84,6 +84,7 @@ , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault+, anonymousCredentials -- * Service configuration , DefaultServiceConfiguration(..) -- * HTTP types@@ -121,6 +122,7 @@ import qualified Data.Conduit.Binary as CB #endif import qualified Data.Conduit.List as CL+import Data.Kind import Data.IORef import Data.List import qualified Data.Map as M@@ -134,6 +136,7 @@ import Data.Typeable import Data.Word import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Client.TLS as HTTP import qualified Network.HTTP.Types as HTTP import System.Directory import System.Environment@@ -182,7 +185,7 @@ (<*>) = ap instance Monoid m => Monad (Response m) where- return x = Response mempty (Right x)+ return = pure Response m1 (Left e) >>= _ = Response m1 (Left e) Response m1 (Right x) >>= f = let Response m2 y = f x in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too@@ -224,7 +227,7 @@ -- | Class for responses that are fully loaded into memory class AsMemoryResponse resp where- type MemoryResponse resp :: *+ type MemoryResponse resp :: Type loadToMemory :: resp -> ResourceT IO (MemoryResponse resp) -- | Responses that have one main list in them, and perhaps some decoration.@@ -261,9 +264,11 @@ , v4SigningKeys :: IORef [V4Key] -- | Signed IAM token , iamToken :: Maybe B.ByteString+ -- | Set when the credentials are intended for anonymous access.+ , isAnonymousCredentials :: Bool } instance Show Credentials where- show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}"+ show c@(Credentials {}) = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" makeCredentials :: MonadIO io => B.ByteString -- ^ AWS Access Key ID@@ -272,6 +277,7 @@ makeCredentials accessKeyID secretAccessKey = liftIO $ do v4SigningKeys <- newIORef [] let iamToken = Nothing+ let isAnonymousCredentials = False return Credentials { .. } -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'.@@ -326,7 +332,7 @@ loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) loadCredentialsFromInstanceMetadata = do- mgr <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings+ mgr <- liftIO HTTP.getGlobalManager -- check if the path is routable avail <- liftIO $ hostAvailable "169.254.169.254" if not avail@@ -349,7 +355,8 @@ return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret) <*> return ref- <*> (Just . T.encodeUtf8 . T.pack <$> token))+ <*> (Just . T.encodeUtf8 . T.pack <$> token)+ <*> return False) Nothing -> return Nothing -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name.@@ -393,6 +400,13 @@ Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey Nothing -> loadCredentialsFromEnv +-- | Make a dummy Credentials that can be used to access some AWS services+-- anonymously.+anonymousCredentials :: MonadIO io => io Credentials+anonymousCredentials = do+ cr <- makeCredentials mempty mempty+ return (cr { isAnonymousCredentials = True })+ -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol = HTTP@@ -483,7 +497,7 @@ ++ sqOtherHeaders , HTTP.requestBody = - -- An explicityly defined body parameter should overwrite everything else.+ -- An explicitly defined body parameter should overwrite everything else. case sqBody of Just x -> x Nothing ->@@ -510,7 +524,7 @@ PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8" _ -> Nothing --- | Create a URI fro a 'SignedQuery' object.+-- | Create a URI from a 'SignedQuery' object. -- -- Unused / incompatible fields will be silently ignored. queryToUri :: SignedQuery -> B.ByteString@@ -577,7 +591,7 @@ -- | A "signable" request object. Assembles together the Query, and signs it in one go. class SignQuery request where -- | Additional information, like API endpoints and service-specific preferences.- type ServiceConfiguration request :: * {- Query Type -} -> *+ type ServiceConfiguration request :: Type {- Query Type -} -> Type -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'. signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery
Aws/DynamoDb/Commands/BatchWriteItem.hs view
@@ -25,7 +25,7 @@ import Control.Applicative import Data.Aeson import Data.Default-import Data.Foldable (asum)+import qualified Data.Foldable as F (asum) import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Prelude@@ -89,7 +89,7 @@ instance FromJSON Request where parseJSON = withObject "PutRequest or DeleteRequest" $ \o -> - asum [+ F.asum [ do pr <- o .: "PutRequest" i <- pr .: "Item"
Aws/DynamoDb/Commands/DeleteItem.hs view
@@ -39,7 +39,7 @@ , diKey :: PrimaryKey -- ^ The item to delete. , diExpect :: Conditions- -- ^ (Possible) set of expections for a conditional Put+ -- ^ (Possible) set of exceptions for a conditional Put , diReturn :: UpdateReturn -- ^ What to return from this query. , diRetCons :: ReturnConsumption
Aws/DynamoDb/Commands/PutItem.hs view
@@ -40,7 +40,7 @@ -- ^ An item to Put. Attributes here will replace what maybe under -- the key on DDB. , piExpect :: Conditions- -- ^ (Possible) set of expections for a conditional Put+ -- ^ (Possible) set of exceptions for a conditional Put , piReturn :: UpdateReturn -- ^ What to return from this query. , piRetCons :: ReturnConsumption
Aws/DynamoDb/Commands/Table.hs view
@@ -35,9 +35,9 @@ import Control.Applicative import Data.Aeson ((.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as A+import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Types as A import Data.Char (toUpper)-import qualified Data.HashMap.Strict as M import Data.Scientific (Scientific) import qualified Data.Text as T import Data.Time@@ -281,7 +281,7 @@ instance A.FromJSON TableDescription where parseJSON = A.withObject "Table must be an object" $ \o -> do- t <- case (M.lookup "Table" o, M.lookup "TableDescription" o) of+ t <- case (KM.lookup "Table" o, KM.lookup "TableDescription" o) of (Just (A.Object t), _) -> return t (_, Just (A.Object t)) -> return t _ -> fail "Table description must have key 'Table' or 'TableDescription'"
Aws/DynamoDb/Commands/UpdateItem.hs view
@@ -31,6 +31,7 @@ ------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson+import qualified Data.Aeson.Key as AK import Data.Default import qualified Data.Text as T import Prelude@@ -91,9 +92,9 @@ toJSON = object . map mk . getAttributeUpdates where mk AttributeUpdate { auAction = UDelete, auAttr = auAttr } =- (attrName auAttr) .= object+ (AK.fromText (attrName auAttr)) .= object ["Action" .= UDelete]- mk AttributeUpdate { .. } = (attrName auAttr) .= object+ mk AttributeUpdate { .. } = AK.fromText (attrName auAttr) .= object ["Value" .= (attrVal auAttr), "Action" .= auAction] @@ -104,7 +105,7 @@ -- -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_UpdateItem.html@ data UpdateAction- = UPut -- ^ Simpley write, overwriting any previous value+ = UPut -- ^ Simply write, overwriting any previous value | UAdd -- ^ Numerical add or add to set. | UDelete -- ^ Empty value: remove; Set value: Subtract from set. deriving (Eq,Show,Read,Ord)
Aws/DynamoDb/Core.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -119,11 +120,17 @@ import Control.Applicative import qualified Control.Exception as C import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif import Control.Monad.Trans import Control.Monad.Trans.Resource (throwM) import qualified Crypto.Hash as CH import Data.Aeson import qualified Data.Aeson as A+import qualified Data.Aeson.Key as AK+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Parser as A (json') import Data.Aeson.Types (Pair, parseEither) import qualified Data.Aeson.Types as A import qualified Data.Attoparsec.ByteString as AttoB (endOfInput)@@ -137,7 +144,6 @@ import Data.Conduit.Attoparsec (sinkParser) import Data.Default import Data.Function (on)-import qualified Data.HashMap.Strict as HM import Data.Int import Data.IORef import Data.List@@ -532,7 +538,7 @@ toJSON (PrimaryKey h (Just r)) = let Object p1 = toJSON h Object p2 = toJSON r- in Object (p1 `HM.union` p2)+ in Object (p1 `KM.union` p2) instance FromJSON PrimaryKey where parseJSON p = do@@ -540,8 +546,8 @@ case length l of 1 -> return $ head l _ -> fail "Unable to parse PrimaryKey" - where listPKey p'= map (\(txt,dval)-> hk txt dval)- . HM.toList <$> parseJSON p'+ where listPKey p'= map (\(k,dval)-> hk (AK.toText k) dval)+ . KM.toList <$> parseJSON p' -- | A key-value pair@@ -657,9 +663,9 @@ ------------------------------------------------------------------------------- -- | Parse a JSON object that contains attributes parseAttributeJson :: Value -> A.Parser [Attribute]-parseAttributeJson (Object v) = mapM conv $ HM.toList v+parseAttributeJson (Object v) = mapM conv $ KM.toList v where- conv (k, o) = Attribute k <$> parseJSON o+ conv (k, o) = Attribute (AK.toText k) <$> parseJSON o parseAttributeJson _ = error "Attribute JSON must be an Object" @@ -670,7 +676,7 @@ -- | Convert into JSON pair attributeJson :: Attribute -> Pair-attributeJson (Attribute nm v) = nm .= v+attributeJson (Attribute nm v) = AK.fromText nm .= v -------------------------------------------------------------------------------@@ -958,7 +964,7 @@ where a = if null es then []- else [key .= object (map conditionJson es)]+ else [AK.fromText key .= object (map conditionJson es)] b = if length (take 2 es) > 1 then ["ConditionalOperator" .= String (rendCondOp op) ]@@ -1042,7 +1048,7 @@ conditionJson :: Condition -> Pair-conditionJson Condition{..} = condAttr .= condOp+conditionJson Condition{..} = AK.fromText condAttr .= condOp instance ToJSON CondOp where@@ -1072,12 +1078,12 @@ instance FromJSON ConsumedCapacity where- parseJSON (Object v) = ConsumedCapacity- <$> v .: "CapacityUnits"- <*> (HM.toList <$> v .:? "GlobalSecondaryIndexes" .!= mempty)- <*> (HM.toList <$> v .:? "LocalSecondaryIndexes" .!= mempty)- <*> (v .:? "Table" >>= maybe (return Nothing) (.: "CapacityUnits"))- <*> v .: "TableName"+ parseJSON (Object o) = ConsumedCapacity+ <$> o .: "CapacityUnits"+ <*> (map (\(k, v) -> (AK.toText k, v)) . KM.toList <$> o .:? "GlobalSecondaryIndexes" .!= mempty)+ <*> (map (\(k, v) -> (AK.toText k, v)) . KM.toList <$> o .:? "LocalSecondaryIndexes" .!= mempty)+ <*> (o .:? "Table" >>= maybe (return Nothing) (.: "CapacityUnits"))+ <*> o .: "TableName" parseJSON _ = fail "ConsumedCapacity must be an Object." @@ -1111,10 +1117,10 @@ instance FromJSON ItemCollectionMetrics where- parseJSON (Object v) = ItemCollectionMetrics- <$> (do m <- v .: "ItemCollectionKey"- return $ head $ HM.toList m)- <*> v .: "SizeEstimateRangeGB"+ parseJSON (Object o) = ItemCollectionMetrics+ <$> (do m <- o .: "ItemCollectionKey"+ return $ (\(k, v) -> (AK.toText k, v)) $ head $ KM.toList m)+ <*> o .: "SizeEstimateRangeGB" parseJSON _ = fail "ItemCollectionMetrics must be an Object." @@ -1159,7 +1165,7 @@ instance Default QuerySelect where def = SelectAll --------------------------------------------------------------------------------querySelectJson :: KeyValue t => QuerySelect -> [t]+querySelectJson :: KeyValue A.Value t => QuerySelect -> [t] querySelectJson (SelectSpecific as) = [ "Select" .= String "SPECIFIC_ATTRIBUTES" , "AttributesToGet" .= as]@@ -1248,18 +1254,26 @@ 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+ return = pure {-# INLINE return #-}+#if !(MIN_VERSION_base(4,13,0)) fail msg = Parser $ \kf _ks -> kf msg {-# INLINE fail #-}+#endif +#if MIN_VERSION_base(4,9,0)+instance Fail.MonadFail Parser where+ fail msg = Parser $ \kf _ks -> kf msg+ {-# INLINE fail #-}+#endif+ 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+ pure a = Parser $ \_kf ks -> ks a {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-}@@ -1382,7 +1396,7 @@ parseAttr k m = case M.lookup k m of Nothing -> fail ("Key " Sem.<> T.unpack k Sem.<> " not found")- Just (DMap dv) -> either (fail "...") return $ fromItem dv+ Just (DMap dv) -> either (const (fail "...")) return $ fromItem dv _ -> fail ("Key " Sem.<> T.unpack k Sem.<> " is not a map!") -------------------------------------------------------------------------------
Aws/Iam/Commands.hs view
@@ -1,31 +1,51 @@ module Aws.Iam.Commands- ( module Aws.Iam.Commands.CreateAccessKey+ ( module Aws.Iam.Commands.AddUserToGroup+ , module Aws.Iam.Commands.CreateAccessKey+ , module Aws.Iam.Commands.CreateGroup , module Aws.Iam.Commands.CreateUser , module Aws.Iam.Commands.DeleteAccessKey+ , module Aws.Iam.Commands.DeleteGroup+ , module Aws.Iam.Commands.DeleteGroupPolicy , module Aws.Iam.Commands.DeleteUser , module Aws.Iam.Commands.DeleteUserPolicy+ , module Aws.Iam.Commands.GetGroupPolicy , module Aws.Iam.Commands.GetUser , module Aws.Iam.Commands.GetUserPolicy , module Aws.Iam.Commands.ListAccessKeys , module Aws.Iam.Commands.ListMfaDevices+ , module Aws.Iam.Commands.ListGroupPolicies+ , module Aws.Iam.Commands.ListGroups , module Aws.Iam.Commands.ListUserPolicies , module Aws.Iam.Commands.ListUsers+ , module Aws.Iam.Commands.PutGroupPolicy , module Aws.Iam.Commands.PutUserPolicy+ , module Aws.Iam.Commands.RemoveUserFromGroup , module Aws.Iam.Commands.UpdateAccessKey+ , module Aws.Iam.Commands.UpdateGroup , module Aws.Iam.Commands.UpdateUser ) where +import Aws.Iam.Commands.AddUserToGroup import Aws.Iam.Commands.CreateAccessKey+import Aws.Iam.Commands.CreateGroup import Aws.Iam.Commands.CreateUser import Aws.Iam.Commands.DeleteAccessKey+import Aws.Iam.Commands.DeleteGroup+import Aws.Iam.Commands.DeleteGroupPolicy import Aws.Iam.Commands.DeleteUser import Aws.Iam.Commands.DeleteUserPolicy+import Aws.Iam.Commands.GetGroupPolicy import Aws.Iam.Commands.GetUser import Aws.Iam.Commands.GetUserPolicy import Aws.Iam.Commands.ListAccessKeys import Aws.Iam.Commands.ListMfaDevices+import Aws.Iam.Commands.ListGroupPolicies+import Aws.Iam.Commands.ListGroups import Aws.Iam.Commands.ListUserPolicies import Aws.Iam.Commands.ListUsers+import Aws.Iam.Commands.PutGroupPolicy import Aws.Iam.Commands.PutUserPolicy+import Aws.Iam.Commands.RemoveUserFromGroup import Aws.Iam.Commands.UpdateAccessKey+import Aws.Iam.Commands.UpdateGroup import Aws.Iam.Commands.UpdateUser
+ Aws/Iam/Commands/AddUserToGroup.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.AddUserToGroup+ ( AddUserToGroup(..)+ , AddUserToGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Adds the specified user to the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_AddUserToGroup.html>+data AddUserToGroup+ = AddUserToGroup {+ autgGroupName :: Text+ -- ^ Name of the group to update.+ , autgUserName :: Text+ -- ^ The of the user to add.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery AddUserToGroup where+ type ServiceConfiguration AddUserToGroup = IamConfiguration+ signQuery AddUserToGroup{..}+ = iamAction "AddUserToGroup" [+ ("GroupName" , autgGroupName)+ , ("UserName" , autgUserName)+ ]++data AddUserToGroupResponse = AddUserToGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer AddUserToGroup AddUserToGroupResponse where+ type ResponseMetadata AddUserToGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return AddUserToGroupResponse)++instance Transaction AddUserToGroup AddUserToGroupResponse++instance AsMemoryResponse AddUserToGroupResponse where+ type MemoryResponse AddUserToGroupResponse = AddUserToGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/CreateGroup.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.CreateGroup+ ( CreateGroup(..)+ , CreateGroupResponse(..)+ , Group(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Creates a new group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_CreateGroup.html>+data CreateGroup+ = CreateGroup {+ cgGroupName :: Text+ -- ^ Name of the new group+ , cgPath :: Maybe Text+ -- ^ Path under which the group will be created. Defaults to @/@ if+ -- omitted.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery CreateGroup where+ type ServiceConfiguration CreateGroup = IamConfiguration+ signQuery CreateGroup{..}+ = iamAction' "CreateGroup" [+ Just ("GroupName", cgGroupName)+ , ("Path",) <$> cgPath+ ]++data CreateGroupResponse = CreateGroupResponse Group+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer CreateGroup CreateGroupResponse where+ type ResponseMetadata CreateGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $+ fmap CreateGroupResponse . parseGroup++instance Transaction CreateGroup CreateGroupResponse++instance AsMemoryResponse CreateGroupResponse where+ type MemoryResponse CreateGroupResponse = CreateGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteGroup.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteGroup+ ( DeleteGroup(..)+ , DeleteGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Deletes the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteGroup.html>+data DeleteGroup = DeleteGroup Text+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteGroup where+ type ServiceConfiguration DeleteGroup = IamConfiguration+ signQuery (DeleteGroup groupName)+ = iamAction "DeleteGroup" [("GroupName", groupName)]++data DeleteGroupResponse = DeleteGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteGroup DeleteGroupResponse where+ type ResponseMetadata DeleteGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return DeleteGroupResponse)++instance Transaction DeleteGroup DeleteGroupResponse++instance AsMemoryResponse DeleteGroupResponse where+ type MemoryResponse DeleteGroupResponse = DeleteGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteGroupPolicy.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteGroupPolicy+ ( DeleteGroupPolicy(..)+ , DeleteGroupPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Deletes the specified policy associated with the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteGroupPolicy.html>+data DeleteGroupPolicy+ = DeleteGroupPolicy {+ dgpPolicyName :: Text+ -- ^ Name of the policy to be deleted.+ , dgpGroupName :: Text+ -- ^ Name of the group with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteGroupPolicy where+ type ServiceConfiguration DeleteGroupPolicy = IamConfiguration+ signQuery DeleteGroupPolicy{..}+ = iamAction "DeleteGroupPolicy" [+ ("PolicyName", dgpPolicyName)+ , ("GroupName", dgpGroupName)+ ]++data DeleteGroupPolicyResponse = DeleteGroupPolicyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteGroupPolicy DeleteGroupPolicyResponse where+ type ResponseMetadata DeleteGroupPolicyResponse = IamMetadata+ responseConsumer _ _ =+ iamResponseConsumer (const $ return DeleteGroupPolicyResponse)++instance Transaction DeleteGroupPolicy DeleteGroupPolicyResponse++instance AsMemoryResponse DeleteGroupPolicyResponse where+ type MemoryResponse DeleteGroupPolicyResponse = DeleteGroupPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/GetGroupPolicy.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.GetGroupPolicy+ ( GetGroupPolicy(..)+ , GetGroupPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Typeable+import qualified Network.HTTP.Types as HTTP+import Text.XML.Cursor (($//))+import Prelude++-- | Retrieves the specified policy document for the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetGroupPolicy.html>+data GetGroupPolicy+ = GetGroupPolicy {+ ggpPolicyName :: Text+ -- ^ Name of the policy.+ , ggpGroupName :: Text+ -- ^ Name of the group with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery GetGroupPolicy where+ type ServiceConfiguration GetGroupPolicy = IamConfiguration+ signQuery GetGroupPolicy{..}+ = iamAction "GetGroupPolicy" [+ ("PolicyName", ggpPolicyName)+ , ("GroupName", ggpGroupName)+ ]++data GetGroupPolicyResponse+ = GetGroupPolicyResponse {+ ggprPolicyDocument :: Text+ -- ^ The policy document.+ , ggprPolicyName :: Text+ -- ^ Name of the policy.+ , ggprGroupName :: Text+ -- ^ Name of the group with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetGroupPolicy GetGroupPolicyResponse where+ type ResponseMetadata GetGroupPolicyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ let attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+ ggprPolicyDocument <- decodePolicy <$>+ attr "PolicyDocument"+ ggprPolicyName <- attr "PolicyName"+ ggprGroupName <- attr "GroupName"+ return GetGroupPolicyResponse{..}+ where+ decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False+ . Text.encodeUtf8+++instance Transaction GetGroupPolicy GetGroupPolicyResponse++instance AsMemoryResponse GetGroupPolicyResponse where+ type MemoryResponse GetGroupPolicyResponse = GetGroupPolicyResponse+ loadToMemory = return
Aws/Iam/Commands/GetUser.hs view
@@ -15,7 +15,7 @@ import Data.Typeable import Prelude --- | Retreives information about the given user.+-- | Retrieves information about the given user. -- -- If a user name is not given, IAM determines the user name based on the -- access key signing the request.
Aws/Iam/Commands/GetUserPolicy.hs view
@@ -18,7 +18,7 @@ import Text.XML.Cursor (($//)) import Prelude --- | Retreives the specified policy document for the specified user.+-- | Retrieves the specified policy document for the specified user. -- -- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetUserPolicy.html> data GetUserPolicy
+ Aws/Iam/Commands/ListGroupPolicies.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListGroupPolicies+ ( ListGroupPolicies(..)+ , ListGroupPoliciesResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable+import Text.XML.Cursor (content, laxElement, ($//), (&/))++-- | Lists the group policies associated with the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListGroupPolicies.html>+data ListGroupPolicies+ = ListGroupPolicies {+ lgpGroupName :: Text+ -- ^ Policies associated with this group will be listed.+ , lgpMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , lgpMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListGroupPolicies where+ type ServiceConfiguration ListGroupPolicies = IamConfiguration+ signQuery ListGroupPolicies{..}+ = iamAction' "ListGroupPolicies" $ [+ Just ("GroupName", lgpGroupName)+ ] <> markedIter lgpMarker lgpMaxItems++data ListGroupPoliciesResponse+ = ListGroupPoliciesResponse {+ lgprPolicyNames :: [Text]+ -- ^ List of policy names.+ , lgprIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , lgprMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListGroupPolicies ListGroupPoliciesResponse where+ type ResponseMetadata ListGroupPoliciesResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (lgprIsTruncated, lgprMarker) <- markedIterResponse cursor+ let lgprPolicyNames = cursor $// laxElement "member" &/ content+ return ListGroupPoliciesResponse{..}++instance Transaction ListGroupPolicies ListGroupPoliciesResponse++instance IteratedTransaction ListGroupPolicies ListGroupPoliciesResponse where+ nextIteratedRequest request response+ = case lgprMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lgpMarker = Just marker }++instance AsMemoryResponse ListGroupPoliciesResponse where+ type MemoryResponse ListGroupPoliciesResponse = ListGroupPoliciesResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListGroups.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListGroups+ ( ListGroups(..)+ , ListGroupsResponse(..)+ , Group(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude+import Text.XML.Cursor (laxElement, ($//), (&|))++-- | Lists groups that have the specified path prefix.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListGroups.html>+data ListGroups+ = ListGroups {+ lgPathPrefix :: Maybe Text+ -- ^ Groups defined under this path will be listed. If omitted, defaults+ -- to @/@, which lists all groups.+ , lgMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , lgMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListGroups where+ type ServiceConfiguration ListGroups = IamConfiguration+ signQuery ListGroups{..}+ = iamAction' "ListGroups" $ [+ ("PathPrefix",) <$> lgPathPrefix+ ] <> markedIter lgMarker lgMaxItems++data ListGroupsResponse+ = ListGroupsResponse {+ lgrGroups :: [Group]+ -- ^ List of 'Group's.+ , lgrIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , lgrMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListGroups ListGroupsResponse where+ type ResponseMetadata ListGroupsResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (lgrIsTruncated, lgrMarker) <- markedIterResponse cursor+ lgrGroups <- sequence $+ cursor $// laxElement "member" &| parseGroup+ return ListGroupsResponse{..}++instance Transaction ListGroups ListGroupsResponse++instance IteratedTransaction ListGroups ListGroupsResponse where+ nextIteratedRequest request response+ = case lgrMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lgMarker = Just marker }++instance AsMemoryResponse ListGroupsResponse where+ type MemoryResponse ListGroupsResponse = ListGroupsResponse+ loadToMemory = return
+ Aws/Iam/Commands/PutGroupPolicy.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.PutGroupPolicy+ ( PutGroupPolicy(..)+ , PutGroupPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Adds a policy document with the specified name, associated with the+-- specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_PutGroupPolicy.html>+data PutGroupPolicy+ = PutGroupPolicy {+ pgpPolicyDocument :: Text+ -- ^ The policy document.+ , pgpPolicyName :: Text+ -- ^ Name of the policy.+ , pgpGroupName :: Text+ -- ^ Name of the group with whom this policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery PutGroupPolicy where+ type ServiceConfiguration PutGroupPolicy = IamConfiguration+ signQuery PutGroupPolicy{..}+ = iamAction "PutGroupPolicy" [+ ("PolicyDocument", pgpPolicyDocument)+ , ("PolicyName" , pgpPolicyName)+ , ("GroupName" , pgpGroupName)+ ]++data PutGroupPolicyResponse = PutGroupPolicyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer PutGroupPolicy PutGroupPolicyResponse where+ type ResponseMetadata PutGroupPolicyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return PutGroupPolicyResponse)++instance Transaction PutGroupPolicy PutGroupPolicyResponse++instance AsMemoryResponse PutGroupPolicyResponse where+ type MemoryResponse PutGroupPolicyResponse = PutGroupPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/RemoveUserFromGroup.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.RemoveUserFromGroup+ ( RemoveUserFromGroup(..)+ , RemoveUserFromGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Removes the specified user from the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_RemoveUserFromGroup.html>+data RemoveUserFromGroup+ = RemoveUserFromGroup {+ rufgGroupName :: Text+ -- ^ Name of the group to update.+ , rufgUserName :: Text+ -- ^ The of the user to add.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery RemoveUserFromGroup where+ type ServiceConfiguration RemoveUserFromGroup = IamConfiguration+ signQuery RemoveUserFromGroup{..}+ = iamAction "RemoveUserFromGroup" [+ ("GroupName" , rufgGroupName)+ , ("UserName" , rufgUserName)+ ]++data RemoveUserFromGroupResponse = RemoveUserFromGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer RemoveUserFromGroup RemoveUserFromGroupResponse where+ type ResponseMetadata RemoveUserFromGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return RemoveUserFromGroupResponse)++instance Transaction RemoveUserFromGroup RemoveUserFromGroupResponse++instance AsMemoryResponse RemoveUserFromGroupResponse where+ type MemoryResponse RemoveUserFromGroupResponse = RemoveUserFromGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/UpdateGroup.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.UpdateGroup+ ( UpdateGroup(..)+ , UpdateGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Updates the name and/or path of the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_UpdateGroup.html>+data UpdateGroup+ = UpdateGroup {+ ugGroupName :: Text+ -- ^ Name of the group to be updated.+ , ugNewGroupName :: Maybe Text+ -- ^ New name for the group.+ , ugNewPath :: Maybe Text+ -- ^ New path to which the group will be moved.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery UpdateGroup where+ type ServiceConfiguration UpdateGroup = IamConfiguration+ signQuery UpdateGroup{..}+ = iamAction' "UpdateGroup" [+ Just ("GroupName", ugGroupName)+ , ("NewGroupName",) <$> ugNewGroupName+ , ("NewPath",) <$> ugNewPath+ ]++data UpdateGroupResponse = UpdateGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer UpdateGroup UpdateGroupResponse where+ type ResponseMetadata UpdateGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return UpdateGroupResponse)++instance Transaction UpdateGroup UpdateGroupResponse++instance AsMemoryResponse UpdateGroupResponse where+ type MemoryResponse UpdateGroupResponse = UpdateGroupResponse+ loadToMemory = return
Aws/Iam/Core.hs view
@@ -14,6 +14,8 @@ , AccessKeyStatus(..) , User(..) , parseUser+ , Group(..)+ , parseGroup , MfaDevice(..) , parseMfaDevice ) where@@ -197,6 +199,38 @@ userUserId <- attr "UserId" userUserName <- attr "UserName" return User{..}+ where+ attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+++-- | The IAM @Group@ data type.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_Group.html>+data Group+ = Group {+ groupArn :: Text+ -- ^ ARN used to refer to this group.+ , groupCreateDate :: UTCTime+ -- ^ Date and time at which the group was created.+ , groupPath :: Text+ -- ^ Path under which the group was created.+ , groupGroupId :: Text+ -- ^ Unique identifier used to refer to this group. + , groupGroupName :: Text+ -- ^ Name of the group.+ }+ deriving (Eq, Ord, Show, Typeable)++-- | Parses the IAM @Group@ data type.+parseGroup :: MonadThrow m => Cu.Cursor -> m Group+parseGroup cursor = do+ groupArn <- attr "Arn"+ groupCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack+ groupPath <- attr "Path"+ groupGroupId <- attr "GroupId"+ groupGroupName <- attr "GroupName"+ return Group{..} where attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name
Aws/Iam/Internal.hs view
@@ -19,7 +19,7 @@ import Control.Monad.Trans.Resource (MonadThrow) import Data.ByteString (ByteString) import Data.Maybe-import Data.Monoid ((<>))+import Data.Monoid import Prelude import Data.Text (Text) import qualified Data.Text as Text
Aws/S3/Commands.hs view
@@ -8,11 +8,14 @@ , module Aws.S3.Commands.GetBucket , module Aws.S3.Commands.GetBucketLocation , module Aws.S3.Commands.GetBucketObjectVersions+, module Aws.S3.Commands.GetBucketVersioning , module Aws.S3.Commands.GetObject , module Aws.S3.Commands.GetService , module Aws.S3.Commands.HeadObject , module Aws.S3.Commands.PutBucket+, module Aws.S3.Commands.PutBucketVersioning , module Aws.S3.Commands.PutObject+, module Aws.S3.Commands.RestoreObject , module Aws.S3.Commands.Multipart ) where@@ -25,9 +28,12 @@ import Aws.S3.Commands.GetBucket import Aws.S3.Commands.GetBucketLocation import Aws.S3.Commands.GetBucketObjectVersions+import Aws.S3.Commands.GetBucketVersioning import Aws.S3.Commands.GetObject import Aws.S3.Commands.GetService import Aws.S3.Commands.HeadObject import Aws.S3.Commands.PutBucket+import Aws.S3.Commands.PutBucketVersioning import Aws.S3.Commands.PutObject+import Aws.S3.Commands.RestoreObject import Aws.S3.Commands.Multipart
Aws/S3/Commands/DeleteObjects.hs view
@@ -14,7 +14,8 @@ import Text.XML.Cursor (($/), (&|)) import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 ({- IsString -})-import Control.Applicative ((<$>))+import Control.Applicative+import Prelude data DeleteObjects = DeleteObjects {
+ Aws/S3/Commands/GetBucketVersioning.hs view
@@ -0,0 +1,65 @@+module Aws.S3.Commands.GetBucketVersioning +( + module Aws.S3.Commands.GetBucketVersioning+, VersioningState(..)+) where++import Aws.Core+import Aws.S3.Commands.PutBucketVersioning (VersioningState(..))+import Aws.S3.Core+import Control.Monad.Trans.Resource (throwM)+import Network.HTTP.Types (toQuery)+import qualified Data.Text.Encoding as T+import Text.XML.Cursor (($.//))+import qualified Data.ByteString.Lazy.Char8 as B8++-- | Gets the versioning state of an existing bucket.+data GetBucketVersioning+ = GetBucketVersioning+ { gbvBucket :: Bucket+ }+ deriving (Show)++getBucketVersioning :: Bucket -> GetBucketVersioning+getBucketVersioning = GetBucketVersioning++data GetBucketVersioningResponse+ = GetBucketVersioningResponse+ { gbvVersioning :: Maybe VersioningState }+ -- ^ Nothing when the bucket is not versioned+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery GetBucketVersioning where+ type ServiceConfiguration GetBucketVersioning = S3Configuration++ signQuery GetBucketVersioning{..} = s3SignQuery $ S3Query+ { s3QMethod = Get+ , s3QBucket = Just $ T.encodeUtf8 gbvBucket+ , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QObject = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer r GetBucketVersioningResponse where+ type ResponseMetadata GetBucketVersioningResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse cursor = do+ v <- case cursor $.// elContent "Status" of+ [] -> return Nothing+ ("Enabled":[]) -> return (Just VersioningEnabled)+ ("Suspended":[]) -> return (Just VersioningSuspended)+ _ -> throwM $ XmlException "Invalid Status"+ return GetBucketVersioningResponse { gbvVersioning = v }++instance Transaction GetBucketVersioning GetBucketVersioningResponse++instance AsMemoryResponse GetBucketVersioningResponse where+ type MemoryResponse GetBucketVersioningResponse = GetBucketVersioningResponse+ loadToMemory = return
Aws/S3/Commands/GetObject.hs view
@@ -83,7 +83,7 @@ instance ResponseConsumer GetObject GetObjectResponse where type ResponseMetadata GetObjectResponse = S3Metadata- responseConsumer httpReq GetObject{..} metadata resp+ responseConsumer httpReq GetObject{} metadata resp | status == HTTP.status200 = do rsp <- s3BinaryResponseConsumer return metadata resp om <- parseObjectMetadata (HTTP.responseHeaders resp)
Aws/S3/Commands/HeadObject.hs view
@@ -60,7 +60,7 @@ instance ResponseConsumer HeadObject HeadObjectResponse where type ResponseMetadata HeadObjectResponse = S3Metadata- responseConsumer httpReq HeadObject{..} _ resp+ responseConsumer httpReq HeadObject{} _ resp | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers | status == HTTP.status404 = return $ HeadObjectResponse Nothing | otherwise = throwStatusCodeException httpReq resp
Aws/S3/Commands/Multipart.hs view
@@ -1,5 +1,5 @@ module Aws.S3.Commands.Multipart- where+where import Aws.Aws import Aws.Core import Aws.S3.Core@@ -370,7 +370,7 @@ -> T.Text -> T.Text -> T.Text- -> Conduit BL.ByteString m T.Text+ -> ConduitT BL.ByteString T.Text m () putConduit cfg s3cfg mgr bucket object uploadId = loop 1 where loop n = do@@ -383,13 +383,13 @@ loop (n+1) Nothing -> return () -chunkedConduit :: (MonadResource m) => Integer -> Conduit B8.ByteString m BL.ByteString+chunkedConduit :: (MonadResource m) => Integer -> ConduitT B8.ByteString BL.ByteString m () chunkedConduit size = loop 0 [] where- loop :: Monad m => Integer -> [B8.ByteString] -> Conduit B8.ByteString m BL.ByteString+ loop :: Monad m => Integer -> [B8.ByteString] -> ConduitT B8.ByteString BL.ByteString m () loop cnt str = await >>= maybe (yieldChunk str) go where- go :: Monad m => B8.ByteString -> Conduit B8.ByteString m BL.ByteString+ go :: Monad m => B8.ByteString -> ConduitT B8.ByteString BL.ByteString m () go line | size <= len = yieldChunk newStr >> loop 0 [] | otherwise = loop len newStr@@ -397,7 +397,7 @@ len = fromIntegral (B8.length line) + cnt newStr = line:str - yieldChunk :: Monad m => [B8.ByteString] -> Conduit i m BL.ByteString+ yieldChunk :: Monad m => [B8.ByteString] -> ConduitT i BL.ByteString m () yieldChunk = yield . BL.fromChunks . reverse multipartUpload ::@@ -406,15 +406,15 @@ -> HTTP.Manager -> T.Text -> T.Text- -> Conduit () (ResourceT IO) B8.ByteString+ -> ConduitT () B8.ByteString (ResourceT IO) () -> Integer -> ResourceT IO () multipartUpload cfg s3cfg mgr bucket object src chunkSize = do uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket object- etags <- src- $= chunkedConduit chunkSize- $= putConduit cfg s3cfg mgr bucket object uploadId- $$ CL.consume+ etags <- (src+ .| chunkedConduit chunkSize+ .| putConduit cfg s3cfg mgr bucket object uploadId+ ) `connect` CL.consume void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags multipartUploadSink :: MonadResource m@@ -424,7 +424,7 @@ -> T.Text -- ^ Bucket name -> T.Text -- ^ Object name -> Integer -- ^ chunkSize (minimum: 5MB)- -> Sink B8.ByteString m ()+ -> ConduitT B8.ByteString Void m () multipartUploadSink cfg s3cfg = multipartUploadSinkWithInitiator cfg s3cfg postInitiateMultipartUpload multipartUploadWithInitiator ::@@ -434,15 +434,15 @@ -> HTTP.Manager -> T.Text -> T.Text- -> Conduit () (ResourceT IO) B8.ByteString+ -> ConduitT () B8.ByteString (ResourceT IO) () -> Integer -> ResourceT IO () multipartUploadWithInitiator cfg s3cfg initiator mgr bucket object src chunkSize = do uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object)- etags <- src- $= chunkedConduit chunkSize- $= putConduit cfg s3cfg mgr bucket object uploadId- $$ CL.consume+ etags <- (src+ .| chunkedConduit chunkSize+ .| putConduit cfg s3cfg mgr bucket object uploadId+ ) `connect` CL.consume void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags multipartUploadSinkWithInitiator :: MonadResource m@@ -453,10 +453,10 @@ -> T.Text -- ^ Bucket name -> T.Text -- ^ Object name -> Integer -- ^ chunkSize (minimum: 5MB)- -> Sink B8.ByteString m ()+ -> ConduitT B8.ByteString Void m () multipartUploadSinkWithInitiator cfg s3cfg initiator mgr bucket object chunkSize = do uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object) etags <- chunkedConduit chunkSize- $= putConduit cfg s3cfg mgr bucket object uploadId- $= CL.consume+ .| putConduit cfg s3cfg mgr bucket object uploadId+ .| CL.consume void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags
+ Aws/S3/Commands/PutBucketVersioning.hs view
@@ -0,0 +1,71 @@+module Aws.S3.Commands.PutBucketVersioning where++import Aws.Core+import Aws.S3.Core+import Network.HTTP.Types (toQuery)+import qualified Data.Map as M+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML as XML+import qualified Data.ByteString.Lazy.Char8 as B8++data VersioningState = VersioningSuspended | VersioningEnabled+ deriving (Show)++-- | Sets the versioning state of an existing bucket.+data PutBucketVersioning+ = PutBucketVersioning+ { pbvBucket :: Bucket+ , pbvVersioningConfiguration :: VersioningState+ }+ deriving (Show)++putBucketVersioning :: Bucket -> VersioningState -> PutBucketVersioning+putBucketVersioning = PutBucketVersioning++data PutBucketVersioningResponse+ = PutBucketVersioningResponse+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery PutBucketVersioning where+ type ServiceConfiguration PutBucketVersioning = S3Configuration++ signQuery PutBucketVersioning{..} = s3SignQuery $ S3Query+ { s3QMethod = Put+ , s3QBucket = Just $ T.encodeUtf8 pbvBucket+ , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QObject = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)+ XML.Document+ { XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}VersioningConfiguration"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [ XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Status"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = case pbvVersioningConfiguration of+ VersioningSuspended -> [XML.NodeContent "Suspended"]+ VersioningEnabled -> [XML.NodeContent "Enabled"]+ })]+ }+ , XML.documentEpilogue = []+ }+ }++instance ResponseConsumer r PutBucketVersioningResponse where+ type ResponseMetadata PutBucketVersioningResponse = S3Metadata++ responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketVersioningResponse++instance Transaction PutBucketVersioning PutBucketVersioningResponse++instance AsMemoryResponse PutBucketVersioningResponse where+ type MemoryResponse PutBucketVersioningResponse = PutBucketVersioningResponse+ loadToMemory = return
Aws/S3/Commands/PutObject.hs view
@@ -5,16 +5,17 @@ import Aws.Core import Aws.S3.Core import Control.Applicative-import Control.Arrow (second)-import qualified Crypto.Hash as CH-import Data.ByteString.Char8 ({- IsString -})+import Control.Arrow (second)+import qualified Crypto.Hash as CH+import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe-import qualified Data.ByteString.Char8 as B-import qualified Data.CaseInsensitive as CI-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Char8 as B+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Prelude-import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types.URI as URI data PutObject = PutObject { poObjectName :: T.Text,@@ -32,16 +33,18 @@ poRequestBody :: HTTP.RequestBody, poMetadata :: [(T.Text,T.Text)], poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension- poExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10+ poExpect100Continue :: Bool, -- ^ Note: Requires http-client >= 0.4.10+ poTagging :: [(T.Text,T.Text)] -- ^ tag-set as key/value pairs } putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject-putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False+putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False [] data PutObjectResponse- = PutObjectResponse {- porVersionId :: Maybe T.Text- }+ = PutObjectResponse+ { porVersionId :: Maybe T.Text+ , porETag :: T.Text+ } deriving (Show) -- | ServiceConfiguration: 'S3Configuration'@@ -54,13 +57,16 @@ , s3QQuery = [] , s3QContentType = poContentType , s3QContentMd5 = poContentMD5- , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+ , s3QAmzHeaders = map (second T.encodeUtf8) (catMaybes [ ("x-amz-acl",) <$> writeCannedAcl <$> poAcl , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption , if poAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1") else Nothing ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata+ ) ++ if null poTagging+ then []+ else [("x-amz-tagging", URI.renderQuery False $ URI.queryTextToQuery $ map (second Just) poTagging)] , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [ ("Expires",) . T.pack . show <$> poExpires , ("Cache-Control",) <$> poCacheControl@@ -78,7 +84,8 @@ type ResponseMetadata PutObjectResponse = S3Metadata responseConsumer _ _ = s3ResponseConsumer $ \resp -> do let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp)- return $ PutObjectResponse vid+ let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp)+ return $ PutObjectResponse vid etag instance Transaction PutObject PutObjectResponse
+ Aws/S3/Commands/RestoreObject.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+module Aws.S3.Commands.RestoreObject+where++import Aws.Core+import Aws.S3.Core+import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML as XML+#if !MIN_VERSION_time(1,5,0)+import System.Locale+#endif+import Prelude++data RestoreObject+ = RestoreObject { roObjectName :: Object+ , roBucket :: Bucket+ , roVersionId :: Maybe T.Text+ , roTier :: RestoreObjectTier+ , roObjectLifetimeDays :: RestoreObjectLifetimeDays+ }+ deriving (Show)++data RestoreObjectTier+ = RestoreObjectTierExpedited+ | RestoreObjectTierStandard+ | RestoreObjectTierBulk+ deriving (Show)++data RestoreObjectLifetimeDays = RestoreObjectLifetimeDays Integer+ deriving (Show)++restoreObject :: Bucket -> T.Text -> RestoreObjectTier -> RestoreObjectLifetimeDays -> RestoreObject+restoreObject bucket obj tier lifetime = RestoreObject obj bucket Nothing tier lifetime++data RestoreObjectResponse+ = RestoreObjectAccepted+ | RestoreObjectAlreadyRestored+ | RestoreObjectAlreadyInProgress+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery RestoreObject where+ type ServiceConfiguration RestoreObject = S3Configuration+ signQuery RestoreObject {..} = s3SignQuery S3Query+ { s3QMethod = Post+ , s3QBucket = Just $ T.encodeUtf8 roBucket+ , s3QObject = Just $ T.encodeUtf8 roObjectName+ , s3QSubresources = HTTP.toQuery+ [ Just ( "restore" :: B8.ByteString, Nothing :: Maybe T.Text)+ , case roVersionId of+ Nothing -> Nothing+ Just v -> Just ("versionId" :: B8.ByteString, Just v)+ ]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)+ XML.Document+ { XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}RestoreRequest"+ , XML.elementAttributes = M.empty+ , XML.elementNodes =+ [ XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Days"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = case roObjectLifetimeDays of+ RestoreObjectLifetimeDays n -> [XML.NodeContent (T.pack (show n))]+ })+ , XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}GlacierJobParameters"+ , XML.elementAttributes = M.empty+ , XML.elementNodes =+ [ XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Tier"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = case roTier of+ RestoreObjectTierExpedited -> [XML.NodeContent "Expedited"]+ RestoreObjectTierStandard -> [XML.NodeContent "Standard"]+ RestoreObjectTierBulk -> [XML.NodeContent "Bulk"] + })+ ]+ })+ ]+ }+ , XML.documentEpilogue = []+ }+ }++instance ResponseConsumer RestoreObject RestoreObjectResponse where+ type ResponseMetadata RestoreObjectResponse = S3Metadata+ responseConsumer httpReq _ _ resp+ | status == HTTP.status202 = return RestoreObjectAccepted+ | status == HTTP.status200 = return RestoreObjectAlreadyRestored+ | status == HTTP.status409 = return RestoreObjectAlreadyInProgress+ | otherwise = throwStatusCodeException httpReq resp+ where+ status = HTTP.responseStatus resp++instance Transaction RestoreObject RestoreObjectResponse++instance AsMemoryResponse RestoreObjectResponse where+ type MemoryResponse RestoreObjectResponse = RestoreObjectResponse+ loadToMemory = return
Aws/S3/Core.hs view
@@ -9,7 +9,7 @@ import Data.Char (isAscii, isAlphaNum, toUpper, ord) import Data.Conduit ((.|)) import Data.Function-import Data.Functor ((<$>))+import Data.Functor import Data.IORef import Data.List import Data.Maybe@@ -67,16 +67,18 @@ deriving (Eq, Show, Read, Typeable) data S3Configuration qt- = S3Configuration {- s3Protocol :: Protocol- , s3Endpoint :: B.ByteString- , s3RequestStyle :: RequestStyle- , s3Port :: Int- , s3ServerSideEncryption :: Maybe ServerSideEncryption- , s3UseUri :: Bool- , s3DefaultExpiry :: NominalDiffTime- , s3SignVersion :: S3SignVersion- }+ = S3Configuration+ { s3Protocol :: Protocol+ , s3Endpoint :: B.ByteString+ , s3Region :: Maybe B.ByteString+ , s3RequestStyle :: RequestStyle+ , s3Port :: Int+ , s3ServerSideEncryption :: Maybe ServerSideEncryption+ , s3UseUri :: Bool+ , s3DefaultExpiry :: NominalDiffTime+ , s3SignVersion :: S3SignVersion+ , s3UserAgent :: Maybe T.Text+ } deriving (Show) instance DefaultServiceConfiguration (S3Configuration NormalQuery) where@@ -114,29 +116,33 @@ s3 :: Protocol -> B.ByteString -> Bool -> S3Configuration qt s3 protocol endpoint uri- = S3Configuration {- s3Protocol = protocol+ = S3Configuration+ { s3Protocol = protocol , s3Endpoint = endpoint+ , s3Region = Nothing , s3RequestStyle = BucketStyle , s3Port = defaultPort protocol , s3ServerSideEncryption = Nothing , s3UseUri = uri , s3DefaultExpiry = 15*60 , s3SignVersion = S3SignV2+ , s3UserAgent = Nothing } s3v4 :: Protocol -> B.ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt s3v4 protocol endpoint uri payload = S3Configuration- { s3Protocol = protocol- , s3Endpoint = endpoint- , s3RequestStyle = BucketStyle- , s3Port = defaultPort protocol- , s3ServerSideEncryption = Nothing- , s3UseUri = uri- , s3DefaultExpiry = 15*60- , s3SignVersion = S3SignV4 payload- }+ { s3Protocol = protocol+ , s3Endpoint = endpoint+ , s3Region = Nothing+ , s3RequestStyle = BucketStyle+ , s3Port = defaultPort protocol+ , s3ServerSideEncryption = Nothing+ , s3UseUri = uri+ , s3DefaultExpiry = 15*60+ , s3SignVersion = S3SignV4 payload+ , s3UserAgent = Nothing+ } type ErrorCode = T.Text@@ -225,12 +231,17 @@ , sqContentType = s3QContentType , sqContentMd5 = s3QContentMd5 , sqAmzHeaders = amzHeaders- , sqOtherHeaders = s3QOtherHeaders+ , sqOtherHeaders = useragent ++ s3QOtherHeaders , sqBody = s3QRequestBody , sqStringToSign = stringToSign } where- amzHeaders = merge $ sortBy (compare `on` fst) (s3QAmzHeaders ++ (fmap (\(k, v) -> (CI.mk k, v)) iamTok))+ -- This also implements anonymous queries.+ isanon = isAnonymousCredentials signatureCredentials + amzHeaders = merge $ sortBy (compare `on` fst) $ s3QAmzHeaders ++ + if isanon + then []+ else fmap (\(k, v) -> (CI.mk k, v)) iamTok where merge (x1@(k1,v1):x2@(k2,v2):xs) | k1 == k2 = merge ((k1, B8.intercalate "," [v1, v2]) : xs) | otherwise = x1 : merge (x2 : xs) merge xs = xs@@ -278,30 +289,38 @@ ] where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v (authorization, authQuery) = case ti of- AbsoluteTimestamp _ -> (Just $ return $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], [])+ AbsoluteTimestamp _+ | isanon -> (Nothing, [])+ | otherwise -> (Just $ return $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], []) AbsoluteExpires time -> (Nothing, HTTP.toQuery $ makeAuthQuery time) makeAuthQuery time- = [("Expires" :: B8.ByteString, fmtTimeEpochSeconds time)- , ("AWSAccessKeyId", accessKeyID signatureCredentials)- , ("SignatureMethod", "HmacSHA256")- , ("Signature", sig)] ++ iamTok-s3SignQuery S3Query{..} S3Configuration{ s3SignVersion = S3SignV4 signpayload, .. } sd@SignatureData{..}- = SignedQuery- { sqMethod = s3QMethod- , sqProtocol = s3Protocol- , sqHost = B.intercalate "." $ catMaybes host- , sqPort = s3Port- , sqPath = mconcat $ catMaybes path- , sqQuery = queryString ++ signatureQuery :: HTTP.Query- , sqDate = Just signatureTime- , sqAuthorization = authorization- , sqContentType = s3QContentType- , sqContentMd5 = s3QContentMd5- , sqAmzHeaders = Map.toList amzHeaders- , sqOtherHeaders = s3QOtherHeaders- , sqBody = s3QRequestBody- , sqStringToSign = stringToSign- }+ | isanon = []+ | otherwise = + [ ("Expires" :: B8.ByteString, fmtTimeEpochSeconds time)+ , ("AWSAccessKeyId", accessKeyID signatureCredentials)+ , ("SignatureMethod", "HmacSHA256")+ , ("Signature", sig)] ++ iamTok+ + useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent+s3SignQuery sq@S3Query{..} sc@S3Configuration{ s3SignVersion = S3SignV4 signpayload, .. } sd@SignatureData{..}+ | isAnonymousCredentials signatureCredentials =+ s3SignQuery sq (sc { s3SignVersion = S3SignV2 }) sd+ | otherwise = SignedQuery+ { sqMethod = s3QMethod+ , sqProtocol = s3Protocol+ , sqHost = B.intercalate "." $ catMaybes host+ , sqPort = s3Port+ , sqPath = mconcat $ catMaybes path+ , sqQuery = queryString ++ signatureQuery :: HTTP.Query+ , sqDate = Just signatureTime+ , sqAuthorization = authorization+ , sqContentType = s3QContentType+ , sqContentMd5 = s3QContentMd5+ , sqAmzHeaders = Map.toList amzHeaders+ , sqOtherHeaders = useragent ++ s3QOtherHeaders+ , sqBody = s3QRequestBody+ , sqStringToSign = stringToSign+ } where -- V4 signing -- * <http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html>@@ -362,7 +381,7 @@ ) where allQueries = s3QSubresources ++ s3QQuery- region = s3ExtractRegion s3Endpoint+ region = fromMaybe (s3ExtractRegion s3Endpoint) s3Region auth = authorizationV4 sd HmacSHA256 region "s3" signedHeaders stringToSign sig = signatureV4 sd HmacSHA256 region "s3" stringToSign cred = credentialV4 sd region "s3"@@ -370,6 +389,8 @@ (False, t) -> t (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time (True, AbsoluteExpires time) -> AbsoluteExpires time+ + useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent -- | Custom UriEncode function -- see <http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html>@@ -399,7 +420,10 @@ renderItem (k, Just v) = s3UriEncode True k Sem.<> "=" Sem.<> s3UriEncode True v renderItem (k, Nothing) = s3UriEncode True k Sem.<> "=" --- | see: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>+-- | Extract a S3 region from the S3 endpoint. AWS encodes the region names+-- in the hostnames of endpoints in a way that makes this possible,+-- see: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>+-- For other S3 implementations, may instead need to specify s3Region. s3ExtractRegion :: B.ByteString -> B.ByteString s3ExtractRegion "s3.amazonaws.com" = "us-east-1" s3ExtractRegion "s3-external-1.amazonaws.com" = "us-east-1"@@ -483,13 +507,15 @@ data UserInfo = UserInfo { userId :: CanonicalUserId- , userDisplayName :: T.Text+ , userDisplayName :: Maybe T.Text } deriving (Show) parseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elContent "ID"- displayName <- force "Missing user DisplayName" $ el $/ elContent "DisplayName"+ displayName <- return $ case (el $/ elContent "DisplayName") of+ (x:_) -> Just x+ [] -> Nothing return UserInfo { userId = id_, userDisplayName = displayName } data CannedAcl@@ -600,7 +626,9 @@ XML.NodeElement e | elName e == "Version" -> do eTag <- force "Missing object ETag" $ el $/ elContent "ETag" size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt- storageClass <- forceM "Missing object StorageClass" $ el $/ elContent "StorageClass" &| return . parseStorageClass+ storageClass <- case el $/ elContent "StorageClass" &| parseStorageClass of+ (x:_) -> return x+ [] -> return Standard return ObjectVersion{ oviKey = key , oviVersionId = versionId@@ -646,7 +674,9 @@ lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time eTag <- force "Missing object ETag" $ el $/ elContent "ETag" size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt- storageClass <- forceM "Missing object StorageClass" $ el $/ elContent "StorageClass" &| return . parseStorageClass+ storageClass <- case el $/ elContent "StorageClass" &| parseStorageClass of+ (x:_) -> return x+ [] -> return Standard owner <- case el $/ Cu.laxElement "Owner" &| parseUserInfo of (x:_) -> fmap' Just x [] -> return Nothing
Aws/Ses/Commands/GetIdentityDkimAttributes.hs view
@@ -4,13 +4,14 @@ , IdentityDkimAttributes(..) ) where -import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as BS import Data.Text (Text) import Data.Text as T (toCaseFold) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Text.XML.Cursor (laxElement, ($/), ($//), (&/), (&|))+import Control.Applicative+import Prelude import Aws.Core import Aws.Ses.Core
Aws/Ses/Commands/GetIdentityNotificationAttributes.hs view
@@ -6,11 +6,12 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS-import Control.Applicative ((<$>))+import Control.Applicative import Data.Text.Encoding as T (encodeUtf8) import Data.Text as T (toCaseFold) import Data.Typeable import Text.XML.Cursor (($//), ($/), (&|), laxElement)+import Prelude import Aws.Core import Aws.Ses.Core
Aws/Ses/Commands/GetIdentityVerificationAttributes.hs view
@@ -7,10 +7,11 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Data.Maybe (listToMaybe)-import Control.Applicative ((<$>))+import Control.Applicative import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Text.XML.Cursor (($//), ($/), (&|), laxElement)+import Prelude import Aws.Core import Aws.Ses.Core
Aws/Ses/Commands/ListIdentities.hs view
@@ -7,10 +7,11 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Data.Maybe (catMaybes)-import Control.Applicative ((<$>))+import Control.Applicative import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable import Text.XML.Cursor (($//), (&/), laxElement)+import Prelude import Aws.Core import Aws.Ses.Core
Aws/Ses/Commands/SendRawEmail.hs view
@@ -5,10 +5,11 @@ import Data.Text (Text) import Data.Typeable-import Control.Applicative ((<$>))+import Control.Applicative import qualified Data.ByteString.Char8 as BS import Text.XML.Cursor (($//)) import qualified Data.Text.Encoding as T+import Prelude import Aws.Core import Aws.Ses.Core
Aws/Ses/Commands/SetIdentityNotificationTopic.hs view
@@ -5,10 +5,11 @@ ) where import Data.Text (Text)-import Control.Applicative ((<$>))+import Control.Applicative import Data.Maybe (maybeToList) import Data.Text.Encoding as T (encodeUtf8) import Data.Typeable+import Prelude import Aws.Core import Aws.Ses.Core
Aws/Sqs/Commands/Message.hs view
@@ -19,7 +19,7 @@ , ReceiveMessage(..) , ReceiveMessageResponse(..) --- * Change Message Visiblity+-- * Change Message Visibility , ChangeMessageVisibility(..) , ChangeMessageVisibilityResponse(..) ) where@@ -426,7 +426,7 @@ -- <http://queue.amazonaws.com/doc/2012-11-05/QueueService.wsdl> -- all elements except for the attributes are specified as required. -- At least for the field 'mMD5OfMessageAttributes' the the service--- is not always returning a value and therefor we make this field optional.+-- is not always returning a value and therefore we make this field optional. -- data Message = Message { mMessageId :: !T.Text@@ -508,7 +508,7 @@ return $ UserMessageAttributeBinary c val (x, _) -> throwM . XmlException- $ "unkown data type for MessageAttributeValue: " <> T.unpack x+ $ "unknown data type for MessageAttributeValue: " <> T.unpack x where parseType s = case T.break (== '.') s of (a, "") -> (a, Nothing)@@ -519,7 +519,7 @@ readMessage cursor = do mid <- force "Missing Message Id" $ cursor $// Cu.laxElement "MessageId" &/ Cu.content- rh <- force "Missing Reciept Handle"+ rh <- force "Missing Receipt Handle" $ cursor $// Cu.laxElement "ReceiptHandle" &/ Cu.content md5 <- force "Missing MD5 Signature" $ cursor $// Cu.laxElement "MD5OfBody" &/ Cu.content
CHANGELOG.md view
@@ -1,3 +1,91 @@+0.25 series+-----------++NOTES: 0.25 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.25.3+ - Switch from memory to ram to allow building with http-client-tls 0.4.x+- 0.25.2+ - S3: Add RestoreObject command+- 0.25.1+ - S3: Make getBucket support Google Object Storage, which does+ not include StorageClass in its response, by defaulting to Standard.+- 0.25+ - [breaking change] Added poTagging constructor to PutObject+ - Switch from no longer maintained cryptonite to crypton.+ - Removed support for building with network-2.x, and removed the+ NetworkBSD build flag.+++0.24 series+-----------++NOTES: 0.24 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.24.4+ - Support filepath 1.5+ - Support data-default 0.8+- 0.24.3+ - [breaking change] Added s3UserAgent constructor to S3Configuration+ - S3: Add GetBucketVersioning command+- 0.24.2+ - Support bytestring 0.12+ - Support building with aeson 2.2, adding dependency on+ attoparsec-json.+- 0.24.1+ - Support resourcet 1.3+ - Support transformers 0.6+- 0.24+ - [breaking change] Added s3Region constructor to S3Configuration, to+ support custom S3 regions.+ - Fixed several build warnings.+ - Needs base-4.9 or newer.++0.23 series+-----------++NOTES: 0.23 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.23+ - Support anonymous access of S3 buckets.+ - [breaking change] added isAnonymousCredentials to Credentials.+ - Support bytestring 0.11++0.22 series+-----------++- 0.22.1+ - Update to aeson-2+ - Support http-client 0.7+ - Support base64-bytestring 1.2+ - Support attoparsec 0.14+ - Support base16-bytestring 1.0+- 0.22+ - Support GHC 8.8+ - Support network-3+ - Support http-client 0.6++ - S3: add etag to PutObjectResponse+ - Add IAM group manipulation methods++0.21 series+-----------++- 0.21.1+ - S3: Add PutBucketVersioning command++- 0.21+ - S3: Make user DisplayName field optional (used in "GetBucket"+ among other places)+ - Use HTTP.getGlobalManager from http-client-tls by default (more+ efficient, and we have a transitive dependency on the package+ anyways)+ 0.20 series ----------- @@ -24,14 +112,14 @@ 0.17 series ----------- +- 0.17.1+ - Fix testsuite build+ - 0.17 - HTTP proxy support - DDB: Support for additional interfaces, bug fixes - Relax version bounds -- 0.17.1- - Fix testsuite build- 0.16 series ----------- @@ -232,7 +320,7 @@ \#72, \#74) - SES: SendRawEmail now correctly encodes destinations and allows multiple destinations (\#73)- - EC2: support fo Instance metadata (\#37)+ - EC2: support for Instance metadata (\#37) - Core: queryToHttpRequest allows overriding "Date" for the benefit of Chris Dornan's Elastic Transcoder bindings (\#77)
Examples/DynamoDb.hs view
@@ -121,7 +121,7 @@ let q0 = (scan "devel-1") { sLimit = Just 5 } mgr <- newManager tlsManagerSettings- xs <- runResourceT $ awsIteratedList cfg debugServiceConfig mgr q0 $$ C.consume+ xs <- runResourceT $ awsIteratedList cfg debugServiceConfig mgr q0 `connect` C.consume echo ("Pagination returned " ++ show (length xs) ++ " items")
Examples/MultipartUpload.hs view
@@ -4,7 +4,7 @@ import qualified Aws.Core as Aws import qualified Aws.S3 as S3 import qualified Data.ByteString.Char8 as B-import Data.Conduit (($$))+import Data.Conduit (connect) import Data.Conduit.Binary (sourceFile) import qualified Data.Text as T import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)@@ -27,4 +27,4 @@ let s3cfg = S3.s3v4 Aws.HTTPS (B.pack endpoint) False S3.SignWithEffort mgr <- newManager tlsManagerSettings runResourceT $- sourceFile file $$ S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)+ sourceFile file `connect` S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)
Examples/NukeBucket.hs view
@@ -30,7 +30,7 @@ liftIO $ putStrLn ("Deleting objects: " ++ show keys) _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os)) return ()- src C.$$ CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO)+ src `C.connect` CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO) liftIO $ putStrLn ("Deleting bucket: " ++ show bucket) _ <- Aws.pureAws cfg s3cfg mgr (S3.DeleteBucket bucket) return ()
Examples/Sqs.hs view
@@ -90,7 +90,7 @@ -} exceptT T.putStrLn T.putStrLn . retryT 4 $ do qUrls <- liftIO $ do- putStrLn $ "Listing all queueus to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone"+ putStrLn $ "Listing all queues to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone" Sqs.ListQueuesResponse qUrls_ <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing mapM_ T.putStrLn qUrls_ return qUrls_
README.md view
@@ -20,7 +20,7 @@ directory: ``` {.bash}-$ git clone https://github.com/aristidb/aws.git+$ git clone https://github.com/haskell-pkg-janitors/aws.git $ cd aws $ cabal install ```@@ -115,7 +115,7 @@ Resources ========= -- [aws on Github](https://github.com/aristidb/aws)+- [aws on Github](https://github.com/haskell-pkg-janitors/aws) - [aws on Hackage](http://hackage.haskell.org/package/aws) (includes reference documentation) - [Official Amazon Web Services website](http://aws.amazon.com/)@@ -133,8 +133,9 @@ Nathan Howell |[NathanHowell](https://github.com/NathanHowell) |nhowell@alphaheavy.com |[Alpha Heavy Industries](http://www.alphaheavy.com) |S3 Ozgun Ataman |[ozataman](https://github.com/ozataman) |ozgun.ataman@soostone.com |[Soostone Inc](http://soostone.com) |Core, S3, DynamoDb Steve Severance |[sseveran](https://github.com/sseveran) |sseverance@alphaheavy.com |[Alpha Heavy Industries](http://www.alphaheavy.com) |S3, SQS- John Wiegley |[jwiegley](https://github.com/jwiegley) |johnw@fpcomplete.com |[FP Complete](http://fpcomplete.com) |Co-Maintainer, S3+ John Wiegley |[jwiegley](https://github.com/jwiegley) |johnw@fpcomplete.com |[FP Complete](http://fpcomplete.com) |S3 Chris Dornan |[cdornan](https://github.com/cdornan) |chris.dornan@irisconnect.co.uk |[Iris Connect](http://irisconnect.co.uk) |Core John Lenz |[wuzzeb](https://github/com/wuzzeb) | | |DynamoDB, Core+ Joey Hess |[joeyh](https://github.com/joeyh) |id@joeyh.name |- |Co-Maintainer, S3
aws.cabal view
@@ -1,8 +1,8 @@ Name: aws-Version: 0.20+Version: 0.25.3 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.md>.-Homepage: http://github.com/aristidb/aws+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/haskell-pkg-janitors/aws/blob/master/README.md>.+Homepage: http://github.com/haskell-pkg-janitors/aws License: BSD3 License-file: LICENSE Author: Aristid Breitkreuz, contributors see README@@ -18,12 +18,12 @@ Source-repository this type: git- location: https://github.com/aristidb/aws.git- tag: 0.20+ location: https://github.com/haskell-pkg-janitors/aws.git+ tag: 0.25.3 Source-repository head type: git- location: https://github.com/aristidb/aws.git+ location: https://github.com/haskell-pkg-janitors/aws.git Flag Examples Description: Build the examples.@@ -49,19 +49,29 @@ Aws.Ec2.InstanceMetadata Aws.Iam Aws.Iam.Commands+ Aws.Iam.Commands.AddUserToGroup Aws.Iam.Commands.CreateAccessKey+ Aws.Iam.Commands.CreateGroup Aws.Iam.Commands.CreateUser Aws.Iam.Commands.DeleteAccessKey+ Aws.Iam.Commands.DeleteGroup+ Aws.Iam.Commands.DeleteGroupPolicy Aws.Iam.Commands.DeleteUser Aws.Iam.Commands.DeleteUserPolicy+ Aws.Iam.Commands.GetGroupPolicy Aws.Iam.Commands.GetUser Aws.Iam.Commands.GetUserPolicy Aws.Iam.Commands.ListAccessKeys Aws.Iam.Commands.ListMfaDevices+ Aws.Iam.Commands.ListGroupPolicies+ Aws.Iam.Commands.ListGroups Aws.Iam.Commands.ListUserPolicies Aws.Iam.Commands.ListUsers+ Aws.Iam.Commands.PutGroupPolicy Aws.Iam.Commands.PutUserPolicy+ Aws.Iam.Commands.RemoveUserFromGroup Aws.Iam.Commands.UpdateAccessKey+ Aws.Iam.Commands.UpdateGroup Aws.Iam.Commands.UpdateUser Aws.Iam.Core Aws.Iam.Internal@@ -76,11 +86,14 @@ Aws.S3.Commands.GetBucket Aws.S3.Commands.GetBucketLocation Aws.S3.Commands.GetBucketObjectVersions+ Aws.S3.Commands.GetBucketVersioning Aws.S3.Commands.GetObject Aws.S3.Commands.GetService Aws.S3.Commands.HeadObject Aws.S3.Commands.PutBucket+ Aws.S3.Commands.PutBucketVersioning Aws.S3.Commands.PutObject+ Aws.S3.Commands.RestoreObject Aws.S3.Commands.Multipart Aws.S3.Core Aws.Ses@@ -113,49 +126,46 @@ Aws.Sqs.Core Build-depends:- aeson >= 0.6,- attoparsec >= 0.11 && < 0.14,- base >= 4.6 && < 5,- base16-bytestring == 0.1.*,- base64-bytestring == 1.0.*,+ aeson >= 2.2.0.0,+ attoparsec >= 0.11 && < 0.15,+ attoparsec-aeson >= 2.1.0.0,+ base >= 4.9 && < 5,+ base16-bytestring >= 0.1 && < 1.1,+ base64-bytestring >= 1.0 && < 1.3, blaze-builder >= 0.2.1.4 && < 0.5, byteable == 0.1.*,- bytestring >= 0.9 && < 0.11,+ bytestring >= 0.9 && < 0.13, case-insensitive >= 0.2 && < 1.3, cereal >= 0.3 && < 0.6, conduit >= 1.3 && < 1.4, conduit-extra >= 1.3 && < 1.4, containers >= 0.4,- cryptonite >= 0.11,- data-default >= 0.5.3 && < 0.8,+ crypton >= 0.34,+ data-default >= 0.5.3 && < 0.9, directory >= 1.0 && < 2.0,- filepath >= 1.1 && < 1.5,+ filepath >= 1.1 && < 1.6, http-conduit >= 2.3 && < 2.4,+ http-client-tls >= 0.4 && < 0.5, http-types >= 0.7 && < 1.0, lifted-base >= 0.1 && < 0.3,- memory,+ ram, monad-control >= 0.3, exceptions >= 0.8 && < 0.11, mtl == 2.*,- network == 2.*, old-locale == 1.*,- resourcet >= 1.2 && < 1.3,+ resourcet >= 1.2 && < 1.4, safe >= 0.3 && < 0.4, scientific >= 0.3, tagged >= 0.7 && < 0.9, text >= 0.11, time >= 1.4.0 && < 2.0,- transformers >= 0.2.2 && < 0.6,+ transformers >= 0.2.2 && < 0.7, unordered-containers >= 0.2, utf8-string >= 0.3 && < 1.1, vector >= 0.10,- xml-conduit >= 1.8 && <2.0- - if !impl(ghc >= 7.6)- Build-depends: ghc-prim-- if !impl(ghc >= 8.0)- Build-depends: semigroups == 0.18.*+ xml-conduit >= 1.8 && <2.0,+ network == 3.*,+ network-bsd == 2.8.* GHC-Options: -Wall @@ -377,7 +387,7 @@ base == 4.*, bytestring >= 0.10, errors >= 2.0,- http-client >= 0.3 && < 0.6,+ http-client >= 0.3 && < 0.8, lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1,@@ -445,7 +455,7 @@ lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1,- http-client < 0.6,+ http-client < 0.8, http-client-tls < 0.5, http-types, resourcet,
tests/DynamoDb/Main.hs view
@@ -79,7 +79,7 @@ , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , ""- , "In order to actually excute the tests in this test-suite you must"+ , "In order to actually execute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials"@@ -138,7 +138,8 @@ -- counts the number of TCP connections ref <- newIORef (0 :: Int) - void . HTTP.withManager (managerSettings ref) $ \manager -> runExceptT $+ manager <- HTTP.newManager (managerSettings ref)+ void $ runExceptT $ flip catchE (error . T.unpack) . replicateM_ 3 $ do void $ dyT cfg manager DY.ListTables mustFail . dyT cfg manager $ DY.DescribeTable "____"
tests/DynamoDb/Utils.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module: DynamoDb.Utils@@ -118,7 +119,7 @@ withTable = withTable_ True withTable_- :: Bool -- ^ whether to prefix te table name+ :: Bool -- ^ whether to prefix the table name -> T.Text -- ^ table Name -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) -> Int -- ^ write capacity (#writes * itemsize/1KB)
tests/S3/Main.hs view
@@ -88,7 +88,7 @@ , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , ""- , "In order to actually excute the tests in this test-suite you must"+ , "In order to actually execute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials"@@ -228,10 +228,10 @@ (cfg, s3cfg, mgr) <- setup resp <- runResourceT $ do uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket k- etags <- sourceLazy testStr- $= chunkedConduit 65536- $= putConduit cfg s3cfg mgr bucket k uploadId- $$ sinkList+ etags <- (sourceLazy testStr+ .| chunkedConduit 65536+ .| putConduit cfg s3cfg mgr bucket k uploadId+ ) `connect` sinkList liftIO $ sendEtag cfg s3cfg mgr bucket k uploadId etags let Just vid = cmurVersionId resp bs <- runResourceT $ do
tests/Sqs/Main.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module: Main@@ -35,8 +36,9 @@ import Data.IORef import qualified Data.List as L-import Data.Monoid import qualified Data.Text as T+import Data.Monoid+import Prelude import qualified Network.HTTP.Client as HTTP @@ -82,7 +84,7 @@ , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , ""- , "In order to actually excute the tests in this test-suite you must"+ , "In order to actually execute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials"@@ -296,7 +298,7 @@ -- | Checks that long polling is actually enabled. We add a delay to the messages -- and immediately make a receive request with a polling wait time that is larger -- than the delay. Note that even though polling forces consistent reads, messages--- will become available with some (small) offset. Therefor we request only a single+-- will become available with some (small) offset. Therefore we request only a single -- message at a time. -- prop_sendReceiveDeleteMessageLongPolling1@@ -353,8 +355,8 @@ ref <- newIORef (0 :: Int) -- Use a single manager for all HTTP requests- void . HTTP.withManager (managerSettings ref) $ \manager -> runExceptT $-+ manager <- HTTP.newManager (managerSettings ref)+ void $ runExceptT $ flip catchE (error . T.unpack) . replicateM_ 3 $ do void . sqsT cfg manager $ SQS.ListQueues Nothing mustFail . sqsT cfg manager $
tests/Utils.hs view
@@ -38,7 +38,6 @@ , prop_jsonRoundtrip ) where -import Control.Applicative import Control.Concurrent (threadDelay) import qualified Control.Exception.Lifted as LE import Control.Error hiding (syncIO)@@ -47,10 +46,12 @@ import Control.Monad.IO.Class import Control.Monad.Base import Control.Monad.Trans.Control+import Control.Applicative+import Data.Monoid+import Prelude import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode) import Data.Dynamic (Dynamic)-import Data.Monoid import Data.Proxy import Data.String import qualified Data.Text as T