diff --git a/Aws.hs b/Aws.hs --- a/Aws.hs +++ b/Aws.hs @@ -58,6 +58,7 @@ , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault +, anonymousCredentials ) where diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -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) diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -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 diff --git a/Aws/DynamoDb/Commands/BatchWriteItem.hs b/Aws/DynamoDb/Commands/BatchWriteItem.hs --- a/Aws/DynamoDb/Commands/BatchWriteItem.hs +++ b/Aws/DynamoDb/Commands/BatchWriteItem.hs @@ -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" diff --git a/Aws/DynamoDb/Commands/DeleteItem.hs b/Aws/DynamoDb/Commands/DeleteItem.hs --- a/Aws/DynamoDb/Commands/DeleteItem.hs +++ b/Aws/DynamoDb/Commands/DeleteItem.hs @@ -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 diff --git a/Aws/DynamoDb/Commands/PutItem.hs b/Aws/DynamoDb/Commands/PutItem.hs --- a/Aws/DynamoDb/Commands/PutItem.hs +++ b/Aws/DynamoDb/Commands/PutItem.hs @@ -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 diff --git a/Aws/DynamoDb/Commands/Table.hs b/Aws/DynamoDb/Commands/Table.hs --- a/Aws/DynamoDb/Commands/Table.hs +++ b/Aws/DynamoDb/Commands/Table.hs @@ -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'" diff --git a/Aws/DynamoDb/Commands/UpdateItem.hs b/Aws/DynamoDb/Commands/UpdateItem.hs --- a/Aws/DynamoDb/Commands/UpdateItem.hs +++ b/Aws/DynamoDb/Commands/UpdateItem.hs @@ -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) diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -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!") ------------------------------------------------------------------------------- diff --git a/Aws/Iam/Commands.hs b/Aws/Iam/Commands.hs --- a/Aws/Iam/Commands.hs +++ b/Aws/Iam/Commands.hs @@ -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 diff --git a/Aws/Iam/Commands/AddUserToGroup.hs b/Aws/Iam/Commands/AddUserToGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/AddUserToGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/CreateGroup.hs b/Aws/Iam/Commands/CreateGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/CreateGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteGroup.hs b/Aws/Iam/Commands/DeleteGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteGroupPolicy.hs b/Aws/Iam/Commands/DeleteGroupPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteGroupPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/GetGroupPolicy.hs b/Aws/Iam/Commands/GetGroupPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/GetGroupPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/GetUser.hs b/Aws/Iam/Commands/GetUser.hs --- a/Aws/Iam/Commands/GetUser.hs +++ b/Aws/Iam/Commands/GetUser.hs @@ -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. diff --git a/Aws/Iam/Commands/GetUserPolicy.hs b/Aws/Iam/Commands/GetUserPolicy.hs --- a/Aws/Iam/Commands/GetUserPolicy.hs +++ b/Aws/Iam/Commands/GetUserPolicy.hs @@ -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. -- -- data GetUserPolicy diff --git a/Aws/Iam/Commands/ListGroupPolicies.hs b/Aws/Iam/Commands/ListGroupPolicies.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListGroupPolicies.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/ListGroups.hs b/Aws/Iam/Commands/ListGroups.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListGroups.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/PutGroupPolicy.hs b/Aws/Iam/Commands/PutGroupPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/PutGroupPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/RemoveUserFromGroup.hs b/Aws/Iam/Commands/RemoveUserFromGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/RemoveUserFromGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/UpdateGroup.hs b/Aws/Iam/Commands/UpdateGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/UpdateGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Core.hs b/Aws/Iam/Core.hs --- a/Aws/Iam/Core.hs +++ b/Aws/Iam/Core.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Internal.hs b/Aws/Iam/Internal.hs --- a/Aws/Iam/Internal.hs +++ b/Aws/Iam/Internal.hs @@ -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 diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -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 diff --git a/Aws/S3/Commands/DeleteObjects.hs b/Aws/S3/Commands/DeleteObjects.hs --- a/Aws/S3/Commands/DeleteObjects.hs +++ b/Aws/S3/Commands/DeleteObjects.hs @@ -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 { diff --git a/Aws/S3/Commands/GetBucketVersioning.hs b/Aws/S3/Commands/GetBucketVersioning.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/GetBucketVersioning.hs @@ -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 diff --git a/Aws/S3/Commands/GetObject.hs b/Aws/S3/Commands/GetObject.hs --- a/Aws/S3/Commands/GetObject.hs +++ b/Aws/S3/Commands/GetObject.hs @@ -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) diff --git a/Aws/S3/Commands/HeadObject.hs b/Aws/S3/Commands/HeadObject.hs --- a/Aws/S3/Commands/HeadObject.hs +++ b/Aws/S3/Commands/HeadObject.hs @@ -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 diff --git a/Aws/S3/Commands/Multipart.hs b/Aws/S3/Commands/Multipart.hs --- a/Aws/S3/Commands/Multipart.hs +++ b/Aws/S3/Commands/Multipart.hs @@ -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 diff --git a/Aws/S3/Commands/PutBucketVersioning.hs b/Aws/S3/Commands/PutBucketVersioning.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/PutBucketVersioning.hs @@ -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 diff --git a/Aws/S3/Commands/PutObject.hs b/Aws/S3/Commands/PutObject.hs --- a/Aws/S3/Commands/PutObject.hs +++ b/Aws/S3/Commands/PutObject.hs @@ -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 diff --git a/Aws/S3/Commands/RestoreObject.hs b/Aws/S3/Commands/RestoreObject.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/RestoreObject.hs @@ -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 diff --git a/Aws/S3/Core.hs b/Aws/S3/Core.hs --- a/Aws/S3/Core.hs +++ b/Aws/S3/Core.hs @@ -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 -- * @@ -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 @@ -399,7 +420,10 @@ renderItem (k, Just v) = s3UriEncode True k Sem.<> "=" Sem.<> s3UriEncode True v renderItem (k, Nothing) = s3UriEncode True k Sem.<> "=" --- | see: +-- | 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: +-- 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 diff --git a/Aws/Ses/Commands/GetIdentityDkimAttributes.hs b/Aws/Ses/Commands/GetIdentityDkimAttributes.hs --- a/Aws/Ses/Commands/GetIdentityDkimAttributes.hs +++ b/Aws/Ses/Commands/GetIdentityDkimAttributes.hs @@ -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 diff --git a/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs b/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs --- a/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs +++ b/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs @@ -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 diff --git a/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs b/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs --- a/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs +++ b/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs @@ -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 diff --git a/Aws/Ses/Commands/ListIdentities.hs b/Aws/Ses/Commands/ListIdentities.hs --- a/Aws/Ses/Commands/ListIdentities.hs +++ b/Aws/Ses/Commands/ListIdentities.hs @@ -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 diff --git a/Aws/Ses/Commands/SendRawEmail.hs b/Aws/Ses/Commands/SendRawEmail.hs --- a/Aws/Ses/Commands/SendRawEmail.hs +++ b/Aws/Ses/Commands/SendRawEmail.hs @@ -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 diff --git a/Aws/Ses/Commands/SetIdentityNotificationTopic.hs b/Aws/Ses/Commands/SetIdentityNotificationTopic.hs --- a/Aws/Ses/Commands/SetIdentityNotificationTopic.hs +++ b/Aws/Ses/Commands/SetIdentityNotificationTopic.hs @@ -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 diff --git a/Aws/Sqs/Commands/Message.hs b/Aws/Sqs/Commands/Message.hs --- a/Aws/Sqs/Commands/Message.hs +++ b/Aws/Sqs/Commands/Message.hs @@ -19,7 +19,7 @@ , ReceiveMessage(..) , ReceiveMessageResponse(..) --- * Change Message Visiblity +-- * Change Message Visibility , ChangeMessageVisibility(..) , ChangeMessageVisibilityResponse(..) ) where @@ -426,7 +426,7 @@ -- -- 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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/Examples/DynamoDb.hs b/Examples/DynamoDb.hs --- a/Examples/DynamoDb.hs +++ b/Examples/DynamoDb.hs @@ -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") diff --git a/Examples/MultipartUpload.hs b/Examples/MultipartUpload.hs --- a/Examples/MultipartUpload.hs +++ b/Examples/MultipartUpload.hs @@ -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) diff --git a/Examples/NukeBucket.hs b/Examples/NukeBucket.hs --- a/Examples/NukeBucket.hs +++ b/Examples/NukeBucket.hs @@ -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 () diff --git a/Examples/Sqs.hs b/Examples/Sqs.hs --- a/Examples/Sqs.hs +++ b/Examples/Sqs.hs @@ -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_ diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -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 . -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 . +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, diff --git a/tests/DynamoDb/Main.hs b/tests/DynamoDb/Main.hs --- a/tests/DynamoDb/Main.hs +++ b/tests/DynamoDb/Main.hs @@ -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 "____" diff --git a/tests/DynamoDb/Utils.hs b/tests/DynamoDb/Utils.hs --- a/tests/DynamoDb/Utils.hs +++ b/tests/DynamoDb/Utils.hs @@ -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) diff --git a/tests/S3/Main.hs b/tests/S3/Main.hs --- a/tests/S3/Main.hs +++ b/tests/S3/Main.hs @@ -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 diff --git a/tests/Sqs/Main.hs b/tests/Sqs/Main.hs --- a/tests/Sqs/Main.hs +++ b/tests/Sqs/Main.hs @@ -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 $ diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -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