├── .ghci ├── .gitignore ├── .travis.yml ├── Aws.hs ├── Aws ├── Aws.hs ├── Core.hs ├── DynamoDb.hs ├── DynamoDb │ ├── Commands.hs │ ├── Commands │ │ ├── BatchGetItem.hs │ │ ├── BatchWriteItem.hs │ │ ├── DeleteItem.hs │ │ ├── GetItem.hs │ │ ├── PutItem.hs │ │ ├── Query.hs │ │ ├── Scan.hs │ │ ├── Table.hs │ │ └── UpdateItem.hs │ └── Core.hs ├── Ec2 │ └── InstanceMetadata.hs ├── Iam.hs ├── Iam │ ├── Commands.hs │ ├── Commands │ │ ├── AddUserToGroup.hs │ │ ├── CreateAccessKey.hs │ │ ├── CreateGroup.hs │ │ ├── CreateUser.hs │ │ ├── DeleteAccessKey.hs │ │ ├── DeleteGroup.hs │ │ ├── DeleteGroupPolicy.hs │ │ ├── DeleteUser.hs │ │ ├── DeleteUserPolicy.hs │ │ ├── GetGroup.hs │ │ ├── GetGroupPolicy.hs │ │ ├── GetUser.hs │ │ ├── GetUserPolicy.hs │ │ ├── ListAccessKeys.hs │ │ ├── ListGroupPolicies.hs │ │ ├── ListGroups.hs │ │ ├── ListMfaDevices.hs │ │ ├── ListUserPolicies.hs │ │ ├── ListUsers.hs │ │ ├── PutGroupPolicy.hs │ │ ├── PutUserPolicy.hs │ │ ├── RemoveUserFromGroup.hs │ │ ├── UpdateAccessKey.hs │ │ ├── UpdateGroup.hs │ │ └── UpdateUser.hs │ ├── Core.hs │ └── Internal.hs ├── Network.hs ├── S3.hs ├── S3 │ ├── Commands.hs │ ├── Commands │ │ ├── CopyObject.hs │ │ ├── DeleteBucket.hs │ │ ├── DeleteObject.hs │ │ ├── DeleteObjectVersion.hs │ │ ├── DeleteObjects.hs │ │ ├── GetBucket.hs │ │ ├── GetBucketLocation.hs │ │ ├── GetBucketObjectVersions.hs │ │ ├── GetBucketVersioning.hs │ │ ├── GetObject.hs │ │ ├── GetService.hs │ │ ├── HeadObject.hs │ │ ├── Multipart.hs │ │ ├── PutBucket.hs │ │ ├── PutBucketVersioning.hs │ │ └── PutObject.hs │ └── Core.hs ├── Ses.hs ├── Ses │ ├── Commands.hs │ ├── Commands │ │ ├── DeleteIdentity.hs │ │ ├── GetIdentityDkimAttributes.hs │ │ ├── GetIdentityNotificationAttributes.hs │ │ ├── GetIdentityVerificationAttributes.hs │ │ ├── ListIdentities.hs │ │ ├── SendRawEmail.hs │ │ ├── SetIdentityDkimEnabled.hs │ │ ├── SetIdentityFeedbackForwardingEnabled.hs │ │ ├── SetIdentityNotificationTopic.hs │ │ ├── VerifyDomainDkim.hs │ │ ├── VerifyDomainIdentity.hs │ │ └── VerifyEmailIdentity.hs │ └── Core.hs ├── SimpleDb.hs ├── SimpleDb │ ├── Commands.hs │ ├── Commands │ │ ├── Attributes.hs │ │ ├── Domain.hs │ │ └── Select.hs │ └── Core.hs ├── Sqs.hs └── Sqs │ ├── Commands.hs │ ├── Commands │ ├── Message.hs │ ├── Permission.hs │ ├── Queue.hs │ └── QueueAttributes.hs │ └── Core.hs ├── CHANGELOG.md ├── Examples ├── DynamoDb.hs ├── GetObject.hs ├── GetObjectGoogle.hs ├── GetObjectV4.hs ├── MultipartTransfer.hs ├── MultipartUpload.hs ├── NukeBucket.hs ├── PutBucketNearLine.hs ├── PutObjectIA.hs ├── SimpleDb.hs └── Sqs.hs ├── LICENSE ├── README.md ├── Setup.hs ├── VERSIONING ├── aws.cabal ├── default.nix ├── ghci.hs ├── shell.nix ├── stack.yaml └── tests ├── DynamoDb ├── Main.hs └── Utils.hs ├── S3 └── Main.hs ├── Sqs └── Main.hs └── Utils.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -XRecordWildCards 2 | :set -XTypeFamilies 3 | :set -XMultiParamTypeClasses 4 | :set -XFlexibleContexts 5 | :set -XFlexibleInstances 6 | :set -XFunctionalDependencies 7 | :set -XDataKinds 8 | :set -XKindSignatures 9 | :set -XDeriveFunctor 10 | :set -XDeriveDataTypeable 11 | :set -XOverloadedStrings 12 | :set -XTupleSections 13 | :set -XScopedTypeVariables 14 | :set -XRank2Types -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist/* 3 | *.swp 4 | /.cabal-sandbox 5 | /cabal.sandbox.config 6 | cloud-remote.pdf 7 | /.stack-work/ 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | addons: 3 | apt: 4 | sources: 5 | - hvr-ghc 6 | packages: 7 | - libgmp-dev 8 | - ghc-8.0.1 9 | - cabal-install-1.24 10 | install: 11 | - export PATH=/opt/cabal/1.24/bin:/opt/ghc/8.0.1/bin:$PATH 12 | - travis_retry cabal update 13 | - cabal install --only-dependencies -fexamples --enable-tests 14 | script: 15 | - cabal configure -fexamples --enable-tests && cabal build 16 | -------------------------------------------------------------------------------- /Aws.hs: -------------------------------------------------------------------------------- 1 | module Aws 2 | ( -- * Logging 3 | LogLevel(..) 4 | , Logger 5 | , defaultLog 6 | -- * Configuration 7 | , Configuration(..) 8 | , baseConfiguration 9 | , dbgConfiguration 10 | -- * Transaction runners 11 | -- ** Safe runners 12 | , aws 13 | , awsRef 14 | , pureAws 15 | , simpleAws 16 | -- ** Unsafe runners 17 | , unsafeAws 18 | , unsafeAwsRef 19 | -- ** URI runners 20 | , awsUri 21 | -- ** Iterated runners 22 | --, awsIteratedAll 23 | , awsIteratedSource 24 | , awsIteratedList 25 | -- * Response 26 | -- ** Full HTTP response 27 | , HTTPResponseConsumer 28 | -- ** Metadata in responses 29 | , Response(..) 30 | , readResponse 31 | , readResponseIO 32 | , ResponseMetadata 33 | -- ** Memory responses 34 | , AsMemoryResponse(..) 35 | -- ** Exception types 36 | , XmlException(..) 37 | , HeaderException(..) 38 | , FormException(..) 39 | -- * Query 40 | -- ** Service configuration 41 | , ServiceConfiguration 42 | , DefaultServiceConfiguration(..) 43 | , NormalQuery 44 | , UriOnlyQuery 45 | -- ** Expiration 46 | , TimeInfo(..) 47 | -- * Transactions 48 | , Transaction 49 | , IteratedTransaction 50 | -- * Credentials 51 | , Credentials(..) 52 | , makeCredentials 53 | , credentialsDefaultFile 54 | , credentialsDefaultKey 55 | , loadCredentialsFromFile 56 | , loadCredentialsFromEnv 57 | , loadCredentialsFromInstanceMetadata 58 | , loadCredentialsFromEnvOrFile 59 | , loadCredentialsFromEnvOrFileOrInstanceMetadata 60 | , loadCredentialsDefault 61 | , anonymousCredentials 62 | ) 63 | where 64 | 65 | import Aws.Aws 66 | import Aws.Core 67 | -------------------------------------------------------------------------------- /Aws/DynamoDb.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Aws.DynaboDb 4 | -- Copyright : Ozgun Ataman, Soostone Inc. 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Ozgun Ataman 8 | -- Stability : experimental 9 | -- 10 | ---------------------------------------------------------------------------- 11 | 12 | module Aws.DynamoDb 13 | ( module Aws.DynamoDb.Core 14 | , module Aws.DynamoDb.Commands 15 | ) where 16 | 17 | ------------------------------------------------------------------------------- 18 | import Aws.DynamoDb.Commands 19 | import Aws.DynamoDb.Core 20 | ------------------------------------------------------------------------------- 21 | -------------------------------------------------------------------------------- /Aws/DynamoDb/Commands.hs: -------------------------------------------------------------------------------- 1 | module Aws.DynamoDb.Commands 2 | ( module Aws.DynamoDb.Commands.BatchGetItem 3 | , module Aws.DynamoDb.Commands.BatchWriteItem 4 | , module Aws.DynamoDb.Commands.DeleteItem 5 | , module Aws.DynamoDb.Commands.GetItem 6 | , module Aws.DynamoDb.Commands.PutItem 7 | , module Aws.DynamoDb.Commands.Query 8 | , module Aws.DynamoDb.Commands.Scan 9 | , module Aws.DynamoDb.Commands.Table 10 | , module Aws.DynamoDb.Commands.UpdateItem 11 | ) where 12 | 13 | ------------------------------------------------------------------------------- 14 | import Aws.DynamoDb.Commands.BatchGetItem 15 | import Aws.DynamoDb.Commands.BatchWriteItem 16 | import Aws.DynamoDb.Commands.DeleteItem 17 | import Aws.DynamoDb.Commands.GetItem 18 | import Aws.DynamoDb.Commands.PutItem 19 | import Aws.DynamoDb.Commands.Query 20 | import Aws.DynamoDb.Commands.Scan 21 | import Aws.DynamoDb.Commands.Table 22 | import Aws.DynamoDb.Commands.UpdateItem 23 | ------------------------------------------------------------------------------- 24 | -------------------------------------------------------------------------------- /Aws/DynamoDb/Commands/BatchWriteItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Aws.DynamoDb.Commands.BatchWriteItem 13 | -- Copyright : Soostone Inc 14 | -- License : BSD3 15 | -- 16 | -- Maintainer : Justin Dawson 17 | -- Stability : experimental 18 | -- 19 | -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchWriteItem.html@ 20 | ---------------------------------------------------------------------------- 21 | 22 | module Aws.DynamoDb.Commands.BatchWriteItem where 23 | 24 | ------------------------------------------------------------------------------- 25 | import Control.Applicative 26 | import Data.Aeson 27 | import Data.Default 28 | import Data.Foldable (asum) 29 | import qualified Data.HashMap.Strict as HM 30 | import qualified Data.Text as T 31 | import Prelude 32 | ------------------------------------------------------------------------------- 33 | import Aws.Core 34 | import Aws.DynamoDb.Core 35 | import Aws.DynamoDb.Commands.PutItem 36 | import Aws.DynamoDb.Commands.DeleteItem 37 | ------------------------------------------------------------------------------- 38 | 39 | 40 | data Request = PutRequest { prItem :: Item } 41 | | DeleteRequest {drKey :: PrimaryKey} 42 | deriving (Eq,Show,Read,Ord) 43 | 44 | data BatchWriteItem = BatchWriteItem { 45 | bwRequests :: [(T.Text,[Request])] 46 | -- ^ Put or Delete Requests for a specified table 47 | , bwRetCons :: ReturnConsumption 48 | , bwRetMet :: ReturnItemCollectionMetrics 49 | } deriving (Eq,Show,Read,Ord) 50 | 51 | 52 | ------------------------------------------------------------------------------- 53 | 54 | toBatchWrite :: [PutItem] 55 | -> [DeleteItem] 56 | -> BatchWriteItem 57 | toBatchWrite ps ds =BatchWriteItem maps def def 58 | where 59 | maps :: [(T.Text,[Request])] 60 | maps = let pMap = foldl (\acc p -> let key = piTable p 61 | in HM.insert key (PutRequest (piItem p) : (HM.lookupDefault [] key acc)) acc) HM.empty ps 62 | totalMap = foldl (\acc d -> let key = diTable d 63 | in HM.insert key (DeleteRequest (diKey d) : (HM.lookupDefault [] key acc)) acc) pMap ds 64 | in HM.toList totalMap 65 | -- | Construct a BatchWriteItem 66 | batchWriteItem :: [(T.Text,[Request])] 67 | -> BatchWriteItem 68 | batchWriteItem reqs = BatchWriteItem reqs def def 69 | 70 | 71 | instance ToJSON Request where 72 | toJSON PutRequest{..} = 73 | object $ 74 | [ "PutRequest" .= (object $ ["Item" .= prItem]) 75 | ] 76 | toJSON DeleteRequest{..} = 77 | object $ 78 | [ "DeleteRequest" .= (object $ ["Key" .= drKey]) 79 | ] 80 | 81 | instance ToJSON BatchWriteItem where 82 | toJSON BatchWriteItem{..} = 83 | object $ 84 | [ "RequestItems" .= HM.fromList bwRequests 85 | , "ReturnConsumedCapacity" .= bwRetCons 86 | , "ReturnItemCollectionMetrics" .= bwRetMet 87 | ] 88 | 89 | instance FromJSON Request where 90 | parseJSON = withObject "PutRequest or DeleteRequest" $ \o -> 91 | 92 | asum [ 93 | do 94 | pr <- o .: "PutRequest" 95 | i <- pr .: "Item" 96 | return $ PutRequest i , 97 | do 98 | dr <- o .: "DeleteRequest" 99 | pk <- dr .: "Key" 100 | return $ DeleteRequest pk 101 | ] 102 | 103 | data BatchWriteItemResponse = BatchWriteItemResponse { 104 | bwUnprocessed :: [(T.Text,[Request])] 105 | -- ^ Unprocessed Requests on failure 106 | , bwConsumed :: Maybe ConsumedCapacity 107 | -- ^ Amount of capacity consumed 108 | , bwColMet :: Maybe ItemCollectionMetrics 109 | -- ^ Collection metrics for tables affected by BatchWriteItem. 110 | } deriving (Eq,Show,Read,Ord) 111 | 112 | 113 | 114 | instance Transaction BatchWriteItem BatchWriteItemResponse 115 | 116 | 117 | instance SignQuery BatchWriteItem where 118 | type ServiceConfiguration BatchWriteItem = DdbConfiguration 119 | signQuery gi = ddbSignQuery "BatchWriteItem" gi 120 | 121 | 122 | instance FromJSON BatchWriteItemResponse where 123 | parseJSON (Object v) = BatchWriteItemResponse 124 | <$> HM.toList <$> (v .: "UnprocessedItems") 125 | <*> v .:? "ConsumedCapacity" 126 | <*> v .:? "ItemCollectionMetrics" 127 | parseJSON _ = fail "BatchWriteItemResponse must be an object." 128 | 129 | 130 | instance ResponseConsumer r BatchWriteItemResponse where 131 | type ResponseMetadata BatchWriteItemResponse = DdbResponse 132 | responseConsumer _ _ ref resp = ddbResponseConsumer ref resp 133 | 134 | 135 | instance AsMemoryResponse BatchWriteItemResponse where 136 | type MemoryResponse BatchWriteItemResponse = BatchWriteItemResponse 137 | loadToMemory = return 138 | -------------------------------------------------------------------------------- /Aws/DynamoDb/Commands/DeleteItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Aws.DynamoDb.Commands.DeleteItem 13 | -- Copyright : Soostone Inc 14 | -- License : BSD3 15 | -- 16 | -- Maintainer : Ozgun Ataman 17 | -- Stability : experimental 18 | -- 19 | -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_DeleteItem.html@ 20 | ---------------------------------------------------------------------------- 21 | 22 | module Aws.DynamoDb.Commands.DeleteItem where 23 | 24 | ------------------------------------------------------------------------------- 25 | import Control.Applicative 26 | import Data.Aeson 27 | import Data.Default 28 | import qualified Data.Text as T 29 | import Prelude 30 | ------------------------------------------------------------------------------- 31 | import Aws.Core 32 | import Aws.DynamoDb.Core 33 | ------------------------------------------------------------------------------- 34 | 35 | 36 | data DeleteItem = DeleteItem { 37 | diTable :: T.Text 38 | -- ^ Target table 39 | , diKey :: PrimaryKey 40 | -- ^ The item to delete. 41 | , diExpect :: Conditions 42 | -- ^ (Possible) set of expections for a conditional Put 43 | , diReturn :: UpdateReturn 44 | -- ^ What to return from this query. 45 | , diRetCons :: ReturnConsumption 46 | , diRetMet :: ReturnItemCollectionMetrics 47 | } deriving (Eq,Show,Read,Ord) 48 | 49 | 50 | ------------------------------------------------------------------------------- 51 | -- | Construct a minimal 'DeleteItem' request. 52 | deleteItem :: T.Text 53 | -- ^ A Dynamo table name 54 | -> PrimaryKey 55 | -- ^ Item to be saved 56 | -> DeleteItem 57 | deleteItem tn key = DeleteItem tn key def def def def 58 | 59 | 60 | instance ToJSON DeleteItem where 61 | toJSON DeleteItem{..} = 62 | object $ expectsJson diExpect ++ 63 | [ "TableName" .= diTable 64 | , "Key" .= diKey 65 | , "ReturnValues" .= diReturn 66 | , "ReturnConsumedCapacity" .= diRetCons 67 | , "ReturnItemCollectionMetrics" .= diRetMet 68 | ] 69 | 70 | 71 | 72 | data DeleteItemResponse = DeleteItemResponse { 73 | dirAttrs :: Maybe Item 74 | -- ^ Old attributes, if requested 75 | , dirConsumed :: Maybe ConsumedCapacity 76 | -- ^ Amount of capacity consumed 77 | , dirColMet :: Maybe ItemCollectionMetrics 78 | -- ^ Collection metrics if they have been requested. 79 | } deriving (Eq,Show,Read,Ord) 80 | 81 | 82 | 83 | instance Transaction DeleteItem DeleteItemResponse 84 | 85 | 86 | instance SignQuery DeleteItem where 87 | type ServiceConfiguration DeleteItem = DdbConfiguration 88 | signQuery gi = ddbSignQuery "DeleteItem" gi 89 | 90 | 91 | instance FromJSON DeleteItemResponse where 92 | parseJSON (Object v) = DeleteItemResponse 93 | <$> v .:? "Attributes" 94 | <*> v .:? "ConsumedCapacity" 95 | <*> v .:? "ItemCollectionMetrics" 96 | parseJSON _ = fail "DeleteItemResponse must be an object." 97 | 98 | 99 | instance ResponseConsumer r DeleteItemResponse where 100 | type ResponseMetadata DeleteItemResponse = DdbResponse 101 | responseConsumer _ _ ref resp = ddbResponseConsumer ref resp 102 | 103 | 104 | instance AsMemoryResponse DeleteItemResponse where 105 | type MemoryResponse DeleteItemResponse = DeleteItemResponse 106 | loadToMemory = return 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | -------------------------------------------------------------------------------- /Aws/DynamoDb/Commands/GetItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Aws.DynamoDb.Commands.GetItem 6 | -- Copyright : Soostone Inc 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : Ozgun Ataman 10 | -- Stability : experimental 11 | -- 12 | -- 13 | ---------------------------------------------------------------------------- 14 | 15 | module Aws.DynamoDb.Commands.GetItem where 16 | 17 | ------------------------------------------------------------------------------- 18 | import Control.Applicative 19 | import Data.Aeson 20 | import Data.Default 21 | import qualified Data.Text as T 22 | import Prelude 23 | ------------------------------------------------------------------------------- 24 | import Aws.Core 25 | import Aws.DynamoDb.Core 26 | ------------------------------------------------------------------------------- 27 | 28 | 29 | -- | A GetItem query that fetches a specific object from DDB. 30 | -- 31 | -- See: @http://docs.aws.amazon.com/amazondynamodb/latest/developerguide/API_GetItem.html@ 32 | data GetItem = GetItem { 33 | giTableName :: T.Text 34 | , giKey :: PrimaryKey 35 | , giAttrs :: Maybe [T.Text] 36 | -- ^ Attributes to get. 'Nothing' grabs everything. 37 | , giConsistent :: Bool 38 | -- ^ Whether to issue a consistent read. 39 | , giRetCons :: ReturnConsumption 40 | -- ^ Whether to return consumption stats. 41 | } deriving (Eq,Show,Read,Ord) 42 | 43 | 44 | ------------------------------------------------------------------------------- 45 | -- | Construct a minimal 'GetItem' request. 46 | getItem 47 | :: T.Text -- ^ Table name 48 | -> PrimaryKey -- ^ Primary key 49 | -> GetItem 50 | getItem tn k = GetItem tn k Nothing False def 51 | 52 | 53 | -- | Response to a 'GetItem' query. 54 | data GetItemResponse = GetItemResponse { 55 | girItem :: Maybe Item 56 | , girConsumed :: Maybe ConsumedCapacity 57 | } deriving (Eq,Show,Read,Ord) 58 | 59 | 60 | instance Transaction GetItem GetItemResponse 61 | 62 | 63 | instance ToJSON GetItem where 64 | toJSON GetItem{..} = object $ 65 | maybe [] (return . ("AttributesToGet" .=)) giAttrs ++ 66 | [ "TableName" .= giTableName 67 | , "Key" .= giKey 68 | , "ConsistentRead" .= giConsistent 69 | , "ReturnConsumedCapacity" .= giRetCons 70 | ] 71 | 72 | 73 | instance SignQuery GetItem where 74 | type ServiceConfiguration GetItem = DdbConfiguration 75 | signQuery gi = ddbSignQuery "GetItem" gi 76 | 77 | 78 | 79 | instance FromJSON GetItemResponse where 80 | parseJSON (Object v) = GetItemResponse 81 | <$> v .:? "Item" 82 | <*> v .:? "ConsumedCapacity" 83 | parseJSON _ = fail "GetItemResponse must be an object." 84 | 85 | 86 | instance ResponseConsumer r GetItemResponse where 87 | type ResponseMetadata GetItemResponse = DdbResponse 88 | responseConsumer _ _ ref resp = ddbResponseConsumer ref resp 89 | 90 | 91 | instance AsMemoryResponse GetItemResponse where 92 | type MemoryResponse GetItemResponse = GetItemResponse 93 | loadToMemory = return 94 | -------------------------------------------------------------------------------- /Aws/DynamoDb/Commands/PutItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Aws.DynamoDb.Commands.GetItem 13 | -- Copyright : Soostone Inc 14 | -- License : BSD3 15 | -- 16 | -- Maintainer : Ozgun Ataman 17 | -- Stability : experimental 18 | -- 19 | -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_PutItem.html@ 20 | ---------------------------------------------------------------------------- 21 | 22 | module Aws.DynamoDb.Commands.PutItem where 23 | 24 | ------------------------------------------------------------------------------- 25 | import Control.Applicative 26 | import Data.Aeson 27 | import Data.Default 28 | import qualified Data.Text as T 29 | import Prelude 30 | ------------------------------------------------------------------------------- 31 | import Aws.Core 32 | import Aws.DynamoDb.Core 33 | ------------------------------------------------------------------------------- 34 | 35 | 36 | data PutItem = PutItem { 37 | piTable :: T.Text 38 | -- ^ Target table 39 | , piItem :: Item 40 | -- ^ An item to Put. Attributes here will replace what maybe under 41 | -- the key on DDB. 42 | , piExpect :: Conditions 43 | -- ^ (Possible) set of expections for a conditional Put 44 | , piReturn :: UpdateReturn 45 | -- ^ What to return from this query. 46 | , piRetCons :: ReturnConsumption 47 | , piRetMet :: ReturnItemCollectionMetrics 48 | } deriving (Eq,Show,Read,Ord) 49 | 50 | 51 | ------------------------------------------------------------------------------- 52 | -- | Construct a minimal 'PutItem' request. 53 | putItem :: T.Text 54 | -- ^ A Dynamo table name 55 | -> Item 56 | -- ^ Item to be saved 57 | -> PutItem 58 | putItem tn it = PutItem tn it def def def def 59 | 60 | 61 | instance ToJSON PutItem where 62 | toJSON PutItem{..} = 63 | object $ expectsJson piExpect ++ 64 | [ "TableName" .= piTable 65 | , "Item" .= piItem 66 | , "ReturnValues" .= piReturn 67 | , "ReturnConsumedCapacity" .= piRetCons 68 | , "ReturnItemCollectionMetrics" .= piRetMet 69 | ] 70 | 71 | 72 | 73 | data PutItemResponse = PutItemResponse { 74 | pirAttrs :: Maybe Item 75 | -- ^ Old attributes, if requested 76 | , pirConsumed :: Maybe ConsumedCapacity 77 | -- ^ Amount of capacity consumed 78 | , pirColMet :: Maybe ItemCollectionMetrics 79 | -- ^ Collection metrics if they have been requested. 80 | } deriving (Eq,Show,Read,Ord) 81 | 82 | 83 | 84 | instance Transaction PutItem PutItemResponse 85 | 86 | 87 | instance SignQuery PutItem where 88 | type ServiceConfiguration PutItem = DdbConfiguration 89 | signQuery gi = ddbSignQuery "PutItem" gi 90 | 91 | 92 | instance FromJSON PutItemResponse where 93 | parseJSON (Object v) = PutItemResponse 94 | <$> v .:? "Attributes" 95 | <*> v .:? "ConsumedCapacity" 96 | <*> v .:? "ItemCollectionMetrics" 97 | parseJSON _ = fail "PutItemResponse must be an object." 98 | 99 | 100 | instance ResponseConsumer r PutItemResponse where 101 | type ResponseMetadata PutItemResponse = DdbResponse 102 | responseConsumer _ _ ref resp = ddbResponseConsumer ref resp 103 | 104 | 105 | instance AsMemoryResponse PutItemResponse where 106 | type MemoryResponse PutItemResponse = PutItemResponse 107 | loadToMemory = return 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | -------------------------------------------------------------------------------- /Aws/DynamoDb/Commands/Scan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Aws.DynamoDb.Commands.Scan 6 | -- Copyright : Soostone Inc 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : Ozgun Ataman 10 | -- Stability : experimental 11 | -- 12 | -- Implementation of Amazon DynamoDb Scan command. 13 | -- 14 | -- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Scan.html@ 15 | ---------------------------------------------------------------------------- 16 | 17 | module Aws.DynamoDb.Commands.Scan 18 | ( Scan (..) 19 | , scan 20 | , ScanResponse (..) 21 | ) where 22 | 23 | ------------------------------------------------------------------------------- 24 | import Control.Applicative 25 | import Data.Aeson 26 | import Data.Default 27 | import Data.Maybe 28 | import qualified Data.Text as T 29 | import Data.Typeable 30 | import qualified Data.Vector as V 31 | ------------------------------------------------------------------------------- 32 | import Aws.Core 33 | import Aws.DynamoDb.Core 34 | ------------------------------------------------------------------------------- 35 | 36 | 37 | -- | A Scan command that uses primary keys for an expedient scan. 38 | data Scan = Scan { 39 | sTableName :: T.Text 40 | -- ^ Required. 41 | , sConsistentRead :: Bool 42 | -- ^ Whether to require a consistent read 43 | , sFilter :: Conditions 44 | -- ^ Whether to filter results before returning to client 45 | , sStartKey :: Maybe [Attribute] 46 | -- ^ Exclusive start key to resume a previous query. 47 | , sLimit :: Maybe Int 48 | -- ^ Whether to limit result set size 49 | , sIndex :: Maybe T.Text 50 | -- ^ Optional. Index to 'Scan' 51 | , sSelect :: QuerySelect 52 | -- ^ What to return from 'Scan' 53 | , sRetCons :: ReturnConsumption 54 | , sSegment :: Int 55 | -- ^ Segment number, starting at 0, for parallel queries. 56 | , sTotalSegments :: Int 57 | -- ^ Total number of parallel segments. 1 means sequential scan. 58 | } deriving (Eq,Show,Read,Ord,Typeable) 59 | 60 | 61 | -- | Construct a minimal 'Scan' request. 62 | scan :: T.Text -- ^ Table name 63 | -> Scan 64 | scan tn = Scan tn False def Nothing Nothing Nothing def def 0 1 65 | 66 | 67 | -- | Response to a 'Scan' query. 68 | data ScanResponse = ScanResponse { 69 | srItems :: V.Vector Item 70 | , srLastKey :: Maybe [Attribute] 71 | , srCount :: Int 72 | , srScanned :: Int 73 | , srConsumed :: Maybe ConsumedCapacity 74 | } deriving (Eq,Show,Read,Ord) 75 | 76 | 77 | ------------------------------------------------------------------------------- 78 | instance ToJSON Scan where 79 | toJSON Scan{..} = object $ 80 | catMaybes 81 | [ (("ExclusiveStartKey" .= ) . attributesJson) <$> sStartKey 82 | , ("Limit" .= ) <$> sLimit 83 | , ("IndexName" .= ) <$> sIndex 84 | ] ++ 85 | conditionsJson "ScanFilter" sFilter ++ 86 | querySelectJson sSelect ++ 87 | [ "TableName".= sTableName 88 | , "ReturnConsumedCapacity" .= sRetCons 89 | , "Segment" .= sSegment 90 | , "TotalSegments" .= sTotalSegments 91 | , "ConsistentRead" .= sConsistentRead 92 | ] 93 | 94 | 95 | instance FromJSON ScanResponse where 96 | parseJSON (Object v) = ScanResponse 97 | <$> v .:? "Items" .!= V.empty 98 | <*> ((do o <- v .: "LastEvaluatedKey" 99 | Just <$> parseAttributeJson o) 100 | <|> pure Nothing) 101 | <*> v .: "Count" 102 | <*> v .: "ScannedCount" 103 | <*> v .:? "ConsumedCapacity" 104 | parseJSON _ = fail "ScanResponse must be an object." 105 | 106 | 107 | instance Transaction Scan ScanResponse 108 | 109 | 110 | instance SignQuery Scan where 111 | type ServiceConfiguration Scan = DdbConfiguration 112 | signQuery gi = ddbSignQuery "Scan" gi 113 | 114 | 115 | instance ResponseConsumer r ScanResponse where 116 | type ResponseMetadata ScanResponse = DdbResponse 117 | responseConsumer _ _ ref resp = ddbResponseConsumer ref resp 118 | 119 | 120 | instance AsMemoryResponse ScanResponse where 121 | type MemoryResponse ScanResponse = ScanResponse 122 | loadToMemory = return 123 | 124 | instance ListResponse ScanResponse Item where 125 | listResponse = V.toList . srItems 126 | 127 | instance IteratedTransaction Scan ScanResponse where 128 | nextIteratedRequest request response = 129 | case srLastKey response of 130 | Nothing -> Nothing 131 | key -> Just request { sStartKey = key } 132 | -------------------------------------------------------------------------------- /Aws/Ec2/InstanceMetadata.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ec2.InstanceMetadata where 2 | 3 | import Control.Applicative 4 | import Control.Exception 5 | import Control.Monad.Trans.Resource (throwM) 6 | import qualified Data.ByteString.Lazy as L 7 | import qualified Data.ByteString.Lazy.Char8 as B8 8 | import Data.ByteString.Lazy.UTF8 as BU 9 | import Data.Typeable 10 | import qualified Network.HTTP.Conduit as HTTP 11 | import Prelude 12 | 13 | data InstanceMetadataException 14 | = MetadataNotFound String 15 | deriving (Show, Typeable) 16 | 17 | instance Exception InstanceMetadataException 18 | 19 | getInstanceMetadata :: HTTP.Manager -> String -> String -> IO L.ByteString 20 | getInstanceMetadata mgr p x = do 21 | req <- HTTP.parseUrlThrow ("http://169.254.169.254/" ++ p ++ '/' : x) 22 | HTTP.responseBody <$> HTTP.httpLbs req mgr 23 | 24 | getInstanceMetadataListing :: HTTP.Manager -> String -> IO [String] 25 | getInstanceMetadataListing mgr p = map BU.toString . B8.split '\n' <$> getInstanceMetadata mgr p "" 26 | 27 | getInstanceMetadataFirst :: HTTP.Manager -> String -> IO L.ByteString 28 | getInstanceMetadataFirst mgr p = do listing <- getInstanceMetadataListing mgr p 29 | case listing of 30 | [] -> throwM (MetadataNotFound p) 31 | (x:_) -> getInstanceMetadata mgr p x 32 | 33 | getInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> IO L.ByteString 34 | getInstanceMetadataOrFirst mgr p (Just x) = getInstanceMetadata mgr p x 35 | getInstanceMetadataOrFirst mgr p Nothing = getInstanceMetadataFirst mgr p 36 | -------------------------------------------------------------------------------- /Aws/Iam.hs: -------------------------------------------------------------------------------- 1 | module Aws.Iam 2 | ( module Aws.Iam.Commands 3 | , module Aws.Iam.Core 4 | ) where 5 | 6 | import Aws.Iam.Commands 7 | import Aws.Iam.Core 8 | -------------------------------------------------------------------------------- /Aws/Iam/Commands.hs: -------------------------------------------------------------------------------- 1 | module Aws.Iam.Commands 2 | ( module Aws.Iam.Commands.AddUserToGroup 3 | , module Aws.Iam.Commands.CreateAccessKey 4 | , module Aws.Iam.Commands.CreateGroup 5 | , module Aws.Iam.Commands.CreateUser 6 | , module Aws.Iam.Commands.DeleteAccessKey 7 | , module Aws.Iam.Commands.DeleteGroup 8 | , module Aws.Iam.Commands.DeleteGroupPolicy 9 | , module Aws.Iam.Commands.DeleteUser 10 | , module Aws.Iam.Commands.DeleteUserPolicy 11 | , module Aws.Iam.Commands.GetGroupPolicy 12 | , module Aws.Iam.Commands.GetUser 13 | , module Aws.Iam.Commands.GetUserPolicy 14 | , module Aws.Iam.Commands.ListAccessKeys 15 | , module Aws.Iam.Commands.ListMfaDevices 16 | , module Aws.Iam.Commands.ListGroupPolicies 17 | , module Aws.Iam.Commands.ListGroups 18 | , module Aws.Iam.Commands.ListUserPolicies 19 | , module Aws.Iam.Commands.ListUsers 20 | , module Aws.Iam.Commands.PutGroupPolicy 21 | , module Aws.Iam.Commands.PutUserPolicy 22 | , module Aws.Iam.Commands.RemoveUserFromGroup 23 | , module Aws.Iam.Commands.UpdateAccessKey 24 | , module Aws.Iam.Commands.UpdateGroup 25 | , module Aws.Iam.Commands.UpdateUser 26 | ) where 27 | 28 | import Aws.Iam.Commands.AddUserToGroup 29 | import Aws.Iam.Commands.CreateAccessKey 30 | import Aws.Iam.Commands.CreateGroup 31 | import Aws.Iam.Commands.CreateUser 32 | import Aws.Iam.Commands.DeleteAccessKey 33 | import Aws.Iam.Commands.DeleteGroup 34 | import Aws.Iam.Commands.DeleteGroupPolicy 35 | import Aws.Iam.Commands.DeleteUser 36 | import Aws.Iam.Commands.DeleteUserPolicy 37 | import Aws.Iam.Commands.GetGroupPolicy 38 | import Aws.Iam.Commands.GetUser 39 | import Aws.Iam.Commands.GetUserPolicy 40 | import Aws.Iam.Commands.ListAccessKeys 41 | import Aws.Iam.Commands.ListMfaDevices 42 | import Aws.Iam.Commands.ListGroupPolicies 43 | import Aws.Iam.Commands.ListGroups 44 | import Aws.Iam.Commands.ListUserPolicies 45 | import Aws.Iam.Commands.ListUsers 46 | import Aws.Iam.Commands.PutGroupPolicy 47 | import Aws.Iam.Commands.PutUserPolicy 48 | import Aws.Iam.Commands.RemoveUserFromGroup 49 | import Aws.Iam.Commands.UpdateAccessKey 50 | import Aws.Iam.Commands.UpdateGroup 51 | import Aws.Iam.Commands.UpdateUser 52 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/AddUserToGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.AddUserToGroup 5 | ( AddUserToGroup(..) 6 | , AddUserToGroupResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Data.Text (Text) 13 | import Data.Typeable 14 | 15 | -- | Adds the specified user to the specified group. 16 | -- 17 | -- 18 | data AddUserToGroup 19 | = AddUserToGroup { 20 | autgGroupName :: Text 21 | -- ^ Name of the group to update. 22 | , autgUserName :: Text 23 | -- ^ The of the user to add. 24 | } 25 | deriving (Eq, Ord, Show, Typeable) 26 | 27 | instance SignQuery AddUserToGroup where 28 | type ServiceConfiguration AddUserToGroup = IamConfiguration 29 | signQuery AddUserToGroup{..} 30 | = iamAction "AddUserToGroup" [ 31 | ("GroupName" , autgGroupName) 32 | , ("UserName" , autgUserName) 33 | ] 34 | 35 | data AddUserToGroupResponse = AddUserToGroupResponse 36 | deriving (Eq, Ord, Show, Typeable) 37 | 38 | instance ResponseConsumer AddUserToGroup AddUserToGroupResponse where 39 | type ResponseMetadata AddUserToGroupResponse = IamMetadata 40 | responseConsumer _ _ 41 | = iamResponseConsumer (const $ return AddUserToGroupResponse) 42 | 43 | instance Transaction AddUserToGroup AddUserToGroupResponse 44 | 45 | instance AsMemoryResponse AddUserToGroupResponse where 46 | type MemoryResponse AddUserToGroupResponse = AddUserToGroupResponse 47 | loadToMemory = return 48 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/CreateAccessKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.CreateAccessKey 6 | ( CreateAccessKey(..) 7 | , CreateAccessKeyResponse(..) 8 | , AccessKey(..) 9 | ) where 10 | 11 | import Aws.Core 12 | import Aws.Iam.Core 13 | import Aws.Iam.Internal 14 | import Control.Applicative 15 | import Data.Text (Text) 16 | import qualified Data.Text as Text 17 | import Data.Time 18 | import Data.Typeable 19 | import Prelude 20 | import Text.XML.Cursor (($//)) 21 | 22 | -- | Creates a new AWS secret access key and corresponding AWS access key ID 23 | -- for the given user name. 24 | -- 25 | -- If a user name is not provided, IAM will determine the user name based on 26 | -- the access key signing the request. 27 | -- 28 | -- 29 | data CreateAccessKey = CreateAccessKey (Maybe Text) 30 | deriving (Eq, Ord, Show, Typeable) 31 | 32 | instance SignQuery CreateAccessKey where 33 | type ServiceConfiguration CreateAccessKey = IamConfiguration 34 | signQuery (CreateAccessKey user) 35 | = iamAction' "CreateAccessKey" [("UserName",) <$> user] 36 | 37 | -- | Represents the IAM @AccessKey@ data type. 38 | -- 39 | -- 40 | data AccessKey 41 | = AccessKey { 42 | akAccessKeyId :: Text 43 | -- ^ The Access Key ID. 44 | , akCreateDate :: Maybe UTCTime 45 | -- ^ Date and time at which the access key was created. 46 | , akSecretAccessKey :: Text 47 | -- ^ Secret key used to sign requests. The secret key is accessible only 48 | -- during key creation. 49 | , akStatus :: AccessKeyStatus 50 | -- ^ Whether the access key is active or not. 51 | , akUserName :: Text 52 | -- ^ The user name for which this key is defined. 53 | } 54 | deriving (Eq, Ord, Show, Typeable) 55 | 56 | data CreateAccessKeyResponse 57 | = CreateAccessKeyResponse AccessKey 58 | deriving (Eq, Ord, Show, Typeable) 59 | 60 | instance ResponseConsumer CreateAccessKey CreateAccessKeyResponse where 61 | type ResponseMetadata CreateAccessKeyResponse = IamMetadata 62 | responseConsumer _ _ 63 | = iamResponseConsumer $ \cursor -> do 64 | let attr name = force ("Missing " ++ Text.unpack name) $ 65 | cursor $// elContent name 66 | akAccessKeyId <- attr "AccessKeyId" 67 | akSecretAccessKey <- attr "SecretAccessKey" 68 | akStatus <- readAccessKeyStatus <$> attr "Status" 69 | akUserName <- attr "UserName" 70 | akCreateDate <- readDate cursor 71 | return $ CreateAccessKeyResponse AccessKey{..} 72 | where 73 | readDate c = case c $// elCont "CreateDate" of 74 | (x:_) -> Just <$> parseDateTime x 75 | _ -> return Nothing 76 | readAccessKeyStatus s 77 | | Text.toCaseFold s == "Active" = AccessKeyActive 78 | | otherwise = AccessKeyInactive 79 | 80 | 81 | instance Transaction CreateAccessKey CreateAccessKeyResponse 82 | 83 | instance AsMemoryResponse CreateAccessKeyResponse where 84 | type MemoryResponse CreateAccessKeyResponse = CreateAccessKeyResponse 85 | loadToMemory = return 86 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/CreateGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.CreateGroup 6 | ( CreateGroup(..) 7 | , CreateGroupResponse(..) 8 | , Group(..) 9 | ) where 10 | 11 | import Aws.Core 12 | import Aws.Iam.Core 13 | import Aws.Iam.Internal 14 | import Control.Applicative 15 | import Data.Text (Text) 16 | import Data.Typeable 17 | import Prelude 18 | 19 | -- | Creates a new group. 20 | -- 21 | -- 22 | data CreateGroup 23 | = CreateGroup { 24 | cgGroupName :: Text 25 | -- ^ Name of the new group 26 | , cgPath :: Maybe Text 27 | -- ^ Path under which the group will be created. Defaults to @/@ if 28 | -- omitted. 29 | } 30 | deriving (Eq, Ord, Show, Typeable) 31 | 32 | instance SignQuery CreateGroup where 33 | type ServiceConfiguration CreateGroup = IamConfiguration 34 | signQuery CreateGroup{..} 35 | = iamAction' "CreateGroup" [ 36 | Just ("GroupName", cgGroupName) 37 | , ("Path",) <$> cgPath 38 | ] 39 | 40 | data CreateGroupResponse = CreateGroupResponse Group 41 | deriving (Eq, Ord, Show, Typeable) 42 | 43 | instance ResponseConsumer CreateGroup CreateGroupResponse where 44 | type ResponseMetadata CreateGroupResponse = IamMetadata 45 | responseConsumer _ _ 46 | = iamResponseConsumer $ 47 | fmap CreateGroupResponse . parseGroup 48 | 49 | instance Transaction CreateGroup CreateGroupResponse 50 | 51 | instance AsMemoryResponse CreateGroupResponse where 52 | type MemoryResponse CreateGroupResponse = CreateGroupResponse 53 | loadToMemory = return 54 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/CreateUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.CreateUser 6 | ( CreateUser(..) 7 | , CreateUserResponse(..) 8 | , User(..) 9 | ) where 10 | 11 | import Aws.Core 12 | import Aws.Iam.Core 13 | import Aws.Iam.Internal 14 | import Control.Applicative 15 | import Data.Text (Text) 16 | import Data.Typeable 17 | import Prelude 18 | 19 | -- | Creates a new user. 20 | -- 21 | -- 22 | data CreateUser 23 | = CreateUser { 24 | cuUserName :: Text 25 | -- ^ Name of the new user 26 | , cuPath :: Maybe Text 27 | -- ^ Path under which the user will be created. Defaults to @/@ if 28 | -- omitted. 29 | } 30 | deriving (Eq, Ord, Show, Typeable) 31 | 32 | instance SignQuery CreateUser where 33 | type ServiceConfiguration CreateUser = IamConfiguration 34 | signQuery CreateUser{..} 35 | = iamAction' "CreateUser" [ 36 | Just ("UserName", cuUserName) 37 | , ("Path",) <$> cuPath 38 | ] 39 | 40 | data CreateUserResponse = CreateUserResponse User 41 | deriving (Eq, Ord, Show, Typeable) 42 | 43 | instance ResponseConsumer CreateUser CreateUserResponse where 44 | type ResponseMetadata CreateUserResponse = IamMetadata 45 | responseConsumer _ _ 46 | = iamResponseConsumer $ 47 | fmap CreateUserResponse . parseUser 48 | 49 | instance Transaction CreateUser CreateUserResponse 50 | 51 | instance AsMemoryResponse CreateUserResponse where 52 | type MemoryResponse CreateUserResponse = CreateUserResponse 53 | loadToMemory = return 54 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/DeleteAccessKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.DeleteAccessKey 6 | ( DeleteAccessKey(..) 7 | , DeleteAccessKeyResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Prelude 17 | 18 | -- | Deletes the access key associated with the specified user. 19 | -- 20 | -- 21 | data DeleteAccessKey 22 | = DeleteAccessKey { 23 | dakAccessKeyId :: Text 24 | -- ^ ID of the access key to be deleted. 25 | , dakUserName :: Maybe Text 26 | -- ^ User name with which the access key is associated. 27 | } 28 | deriving (Eq, Ord, Show, Typeable) 29 | 30 | instance SignQuery DeleteAccessKey where 31 | type ServiceConfiguration DeleteAccessKey = IamConfiguration 32 | signQuery DeleteAccessKey{..} 33 | = iamAction' "DeleteAccessKey" [ 34 | Just ("AccessKeyId", dakAccessKeyId) 35 | , ("UserName",) <$> dakUserName 36 | ] 37 | 38 | data DeleteAccessKeyResponse = DeleteAccessKeyResponse 39 | deriving (Eq, Ord, Show, Typeable) 40 | 41 | instance ResponseConsumer DeleteAccessKey DeleteAccessKeyResponse where 42 | type ResponseMetadata DeleteAccessKeyResponse = IamMetadata 43 | responseConsumer _ _ 44 | = iamResponseConsumer (const $ return DeleteAccessKeyResponse) 45 | 46 | instance Transaction DeleteAccessKey DeleteAccessKeyResponse 47 | 48 | instance AsMemoryResponse DeleteAccessKeyResponse where 49 | type MemoryResponse DeleteAccessKeyResponse = DeleteAccessKeyResponse 50 | loadToMemory = return 51 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/DeleteGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Aws.Iam.Commands.DeleteGroup 4 | ( DeleteGroup(..) 5 | , DeleteGroupResponse(..) 6 | ) where 7 | 8 | import Aws.Core 9 | import Aws.Iam.Core 10 | import Aws.Iam.Internal 11 | import Data.Text (Text) 12 | import Data.Typeable 13 | 14 | -- | Deletes the specified group. 15 | -- 16 | -- 17 | data DeleteGroup = DeleteGroup Text 18 | deriving (Eq, Ord, Show, Typeable) 19 | 20 | instance SignQuery DeleteGroup where 21 | type ServiceConfiguration DeleteGroup = IamConfiguration 22 | signQuery (DeleteGroup groupName) 23 | = iamAction "DeleteGroup" [("GroupName", groupName)] 24 | 25 | data DeleteGroupResponse = DeleteGroupResponse 26 | deriving (Eq, Ord, Show, Typeable) 27 | 28 | instance ResponseConsumer DeleteGroup DeleteGroupResponse where 29 | type ResponseMetadata DeleteGroupResponse = IamMetadata 30 | responseConsumer _ _ 31 | = iamResponseConsumer (const $ return DeleteGroupResponse) 32 | 33 | instance Transaction DeleteGroup DeleteGroupResponse 34 | 35 | instance AsMemoryResponse DeleteGroupResponse where 36 | type MemoryResponse DeleteGroupResponse = DeleteGroupResponse 37 | loadToMemory = return 38 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/DeleteGroupPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.DeleteGroupPolicy 5 | ( DeleteGroupPolicy(..) 6 | , DeleteGroupPolicyResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Data.Text (Text) 13 | import Data.Typeable 14 | 15 | -- | Deletes the specified policy associated with the specified group. 16 | -- 17 | -- 18 | data DeleteGroupPolicy 19 | = DeleteGroupPolicy { 20 | dgpPolicyName :: Text 21 | -- ^ Name of the policy to be deleted. 22 | , dgpGroupName :: Text 23 | -- ^ Name of the group with whom the policy is associated. 24 | } 25 | deriving (Eq, Ord, Show, Typeable) 26 | 27 | instance SignQuery DeleteGroupPolicy where 28 | type ServiceConfiguration DeleteGroupPolicy = IamConfiguration 29 | signQuery DeleteGroupPolicy{..} 30 | = iamAction "DeleteGroupPolicy" [ 31 | ("PolicyName", dgpPolicyName) 32 | , ("GroupName", dgpGroupName) 33 | ] 34 | 35 | data DeleteGroupPolicyResponse = DeleteGroupPolicyResponse 36 | deriving (Eq, Ord, Show, Typeable) 37 | 38 | instance ResponseConsumer DeleteGroupPolicy DeleteGroupPolicyResponse where 39 | type ResponseMetadata DeleteGroupPolicyResponse = IamMetadata 40 | responseConsumer _ _ = 41 | iamResponseConsumer (const $ return DeleteGroupPolicyResponse) 42 | 43 | instance Transaction DeleteGroupPolicy DeleteGroupPolicyResponse 44 | 45 | instance AsMemoryResponse DeleteGroupPolicyResponse where 46 | type MemoryResponse DeleteGroupPolicyResponse = DeleteGroupPolicyResponse 47 | loadToMemory = return 48 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/DeleteUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Aws.Iam.Commands.DeleteUser 4 | ( DeleteUser(..) 5 | , DeleteUserResponse(..) 6 | ) where 7 | 8 | import Aws.Core 9 | import Aws.Iam.Core 10 | import Aws.Iam.Internal 11 | import Data.Text (Text) 12 | import Data.Typeable 13 | 14 | -- | Deletes the specified user. 15 | -- 16 | -- 17 | data DeleteUser = DeleteUser Text 18 | deriving (Eq, Ord, Show, Typeable) 19 | 20 | instance SignQuery DeleteUser where 21 | type ServiceConfiguration DeleteUser = IamConfiguration 22 | signQuery (DeleteUser userName) 23 | = iamAction "DeleteUser" [("UserName", userName)] 24 | 25 | data DeleteUserResponse = DeleteUserResponse 26 | deriving (Eq, Ord, Show, Typeable) 27 | 28 | instance ResponseConsumer DeleteUser DeleteUserResponse where 29 | type ResponseMetadata DeleteUserResponse = IamMetadata 30 | responseConsumer _ _ 31 | = iamResponseConsumer (const $ return DeleteUserResponse) 32 | 33 | instance Transaction DeleteUser DeleteUserResponse 34 | 35 | instance AsMemoryResponse DeleteUserResponse where 36 | type MemoryResponse DeleteUserResponse = DeleteUserResponse 37 | loadToMemory = return 38 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/DeleteUserPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.DeleteUserPolicy 5 | ( DeleteUserPolicy(..) 6 | , DeleteUserPolicyResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Data.Text (Text) 13 | import Data.Typeable 14 | 15 | -- | Deletes the specified policy associated with the specified user. 16 | -- 17 | -- 18 | data DeleteUserPolicy 19 | = DeleteUserPolicy { 20 | dupPolicyName :: Text 21 | -- ^ Name of the policy to be deleted. 22 | , dupUserName :: Text 23 | -- ^ Name of the user with whom the policy is associated. 24 | } 25 | deriving (Eq, Ord, Show, Typeable) 26 | 27 | instance SignQuery DeleteUserPolicy where 28 | type ServiceConfiguration DeleteUserPolicy = IamConfiguration 29 | signQuery DeleteUserPolicy{..} 30 | = iamAction "DeleteUserPolicy" [ 31 | ("PolicyName", dupPolicyName) 32 | , ("UserName", dupUserName) 33 | ] 34 | 35 | data DeleteUserPolicyResponse = DeleteUserPolicyResponse 36 | deriving (Eq, Ord, Show, Typeable) 37 | 38 | instance ResponseConsumer DeleteUserPolicy DeleteUserPolicyResponse where 39 | type ResponseMetadata DeleteUserPolicyResponse = IamMetadata 40 | responseConsumer _ _ = 41 | iamResponseConsumer (const $ return DeleteUserPolicyResponse) 42 | 43 | instance Transaction DeleteUserPolicy DeleteUserPolicyResponse 44 | 45 | instance AsMemoryResponse DeleteUserPolicyResponse where 46 | type MemoryResponse DeleteUserPolicyResponse = DeleteUserPolicyResponse 47 | loadToMemory = return 48 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/GetGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.GetUser 5 | ( GetUser(..) 6 | , GetUserResponse(..) 7 | , User(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Prelude 17 | 18 | -- | Retreives information about the given user. 19 | -- 20 | -- If a user name is not given, IAM determines the user name based on the 21 | -- access key signing the request. 22 | -- 23 | -- 24 | data GetUser = GetUser (Maybe Text) 25 | deriving (Eq, Ord, Show, Typeable) 26 | 27 | instance SignQuery GetUser where 28 | type ServiceConfiguration GetUser = IamConfiguration 29 | signQuery (GetUser user) 30 | = iamAction' "GetUser" [("UserName",) <$> user] 31 | 32 | data GetUserResponse = GetUserResponse User 33 | deriving (Eq, Ord, Show, Typeable) 34 | 35 | instance ResponseConsumer GetUser GetUserResponse where 36 | type ResponseMetadata GetUserResponse = IamMetadata 37 | responseConsumer _ _ = iamResponseConsumer $ 38 | fmap GetUserResponse . parseUser 39 | 40 | instance Transaction GetUser GetUserResponse 41 | 42 | instance AsMemoryResponse GetUserResponse where 43 | type MemoryResponse GetUserResponse = GetUserResponse 44 | loadToMemory = return 45 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/GetGroupPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.GetGroupPolicy 5 | ( GetGroupPolicy(..) 6 | , GetGroupPolicyResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Control.Applicative 13 | import Data.Text (Text) 14 | import qualified Data.Text as Text 15 | import qualified Data.Text.Encoding as Text 16 | import Data.Typeable 17 | import qualified Network.HTTP.Types as HTTP 18 | import Text.XML.Cursor (($//)) 19 | import Prelude 20 | 21 | -- | Retreives the specified policy document for the specified group. 22 | -- 23 | -- 24 | data GetGroupPolicy 25 | = GetGroupPolicy { 26 | ggpPolicyName :: Text 27 | -- ^ Name of the policy. 28 | , ggpGroupName :: Text 29 | -- ^ Name of the group with whom the policy is associated. 30 | } 31 | deriving (Eq, Ord, Show, Typeable) 32 | 33 | instance SignQuery GetGroupPolicy where 34 | type ServiceConfiguration GetGroupPolicy = IamConfiguration 35 | signQuery GetGroupPolicy{..} 36 | = iamAction "GetGroupPolicy" [ 37 | ("PolicyName", ggpPolicyName) 38 | , ("GroupName", ggpGroupName) 39 | ] 40 | 41 | data GetGroupPolicyResponse 42 | = GetGroupPolicyResponse { 43 | ggprPolicyDocument :: Text 44 | -- ^ The policy document. 45 | , ggprPolicyName :: Text 46 | -- ^ Name of the policy. 47 | , ggprGroupName :: Text 48 | -- ^ Name of the group with whom the policy is associated. 49 | } 50 | deriving (Eq, Ord, Show, Typeable) 51 | 52 | instance ResponseConsumer GetGroupPolicy GetGroupPolicyResponse where 53 | type ResponseMetadata GetGroupPolicyResponse = IamMetadata 54 | responseConsumer _ _ 55 | = iamResponseConsumer $ \cursor -> do 56 | let attr name = force ("Missing " ++ Text.unpack name) $ 57 | cursor $// elContent name 58 | ggprPolicyDocument <- decodePolicy <$> 59 | attr "PolicyDocument" 60 | ggprPolicyName <- attr "PolicyName" 61 | ggprGroupName <- attr "GroupName" 62 | return GetGroupPolicyResponse{..} 63 | where 64 | decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False 65 | . Text.encodeUtf8 66 | 67 | 68 | instance Transaction GetGroupPolicy GetGroupPolicyResponse 69 | 70 | instance AsMemoryResponse GetGroupPolicyResponse where 71 | type MemoryResponse GetGroupPolicyResponse = GetGroupPolicyResponse 72 | loadToMemory = return 73 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/GetUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.GetUser 5 | ( GetUser(..) 6 | , GetUserResponse(..) 7 | , User(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Prelude 17 | 18 | -- | Retreives information about the given user. 19 | -- 20 | -- If a user name is not given, IAM determines the user name based on the 21 | -- access key signing the request. 22 | -- 23 | -- 24 | data GetUser = GetUser (Maybe Text) 25 | deriving (Eq, Ord, Show, Typeable) 26 | 27 | instance SignQuery GetUser where 28 | type ServiceConfiguration GetUser = IamConfiguration 29 | signQuery (GetUser user) 30 | = iamAction' "GetUser" [("UserName",) <$> user] 31 | 32 | data GetUserResponse = GetUserResponse User 33 | deriving (Eq, Ord, Show, Typeable) 34 | 35 | instance ResponseConsumer GetUser GetUserResponse where 36 | type ResponseMetadata GetUserResponse = IamMetadata 37 | responseConsumer _ _ = iamResponseConsumer $ 38 | fmap GetUserResponse . parseUser 39 | 40 | instance Transaction GetUser GetUserResponse 41 | 42 | instance AsMemoryResponse GetUserResponse where 43 | type MemoryResponse GetUserResponse = GetUserResponse 44 | loadToMemory = return 45 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/GetUserPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.GetUserPolicy 5 | ( GetUserPolicy(..) 6 | , GetUserPolicyResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Control.Applicative 13 | import Data.Text (Text) 14 | import qualified Data.Text as Text 15 | import qualified Data.Text.Encoding as Text 16 | import Data.Typeable 17 | import qualified Network.HTTP.Types as HTTP 18 | import Text.XML.Cursor (($//)) 19 | import Prelude 20 | 21 | -- | Retreives the specified policy document for the specified user. 22 | -- 23 | -- 24 | data GetUserPolicy 25 | = GetUserPolicy { 26 | gupPolicyName :: Text 27 | -- ^ Name of the policy. 28 | , gupUserName :: Text 29 | -- ^ Name of the user with whom the policy is associated. 30 | } 31 | deriving (Eq, Ord, Show, Typeable) 32 | 33 | instance SignQuery GetUserPolicy where 34 | type ServiceConfiguration GetUserPolicy = IamConfiguration 35 | signQuery GetUserPolicy{..} 36 | = iamAction "GetUserPolicy" [ 37 | ("PolicyName", gupPolicyName) 38 | , ("UserName", gupUserName) 39 | ] 40 | 41 | data GetUserPolicyResponse 42 | = GetUserPolicyResponse { 43 | guprPolicyDocument :: Text 44 | -- ^ The policy document. 45 | , guprPolicyName :: Text 46 | -- ^ Name of the policy. 47 | , guprUserName :: Text 48 | -- ^ Name of the user with whom the policy is associated. 49 | } 50 | deriving (Eq, Ord, Show, Typeable) 51 | 52 | instance ResponseConsumer GetUserPolicy GetUserPolicyResponse where 53 | type ResponseMetadata GetUserPolicyResponse = IamMetadata 54 | responseConsumer _ _ 55 | = iamResponseConsumer $ \cursor -> do 56 | let attr name = force ("Missing " ++ Text.unpack name) $ 57 | cursor $// elContent name 58 | guprPolicyDocument <- decodePolicy <$> 59 | attr "PolicyDocument" 60 | guprPolicyName <- attr "PolicyName" 61 | guprUserName <- attr "UserName" 62 | return GetUserPolicyResponse{..} 63 | where 64 | decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False 65 | . Text.encodeUtf8 66 | 67 | 68 | instance Transaction GetUserPolicy GetUserPolicyResponse 69 | 70 | instance AsMemoryResponse GetUserPolicyResponse where 71 | type MemoryResponse GetUserPolicyResponse = GetUserPolicyResponse 72 | loadToMemory = return 73 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/ListAccessKeys.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.ListAccessKeys 6 | ( ListAccessKeys(..) 7 | , ListAccessKeysResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Time 16 | import Data.Typeable 17 | import Prelude 18 | import Text.XML.Cursor (laxElement, ($/), ($//), (&|)) 19 | 20 | -- | Returns the access keys associated with the specified user. 21 | -- 22 | -- 23 | data ListAccessKeys 24 | = ListAccessKeys { 25 | lakUserName :: Maybe Text 26 | -- ^ Name of the user. If the user name is not specified, IAM will 27 | -- determine the user based on the key sigining the request. 28 | , lakMarker :: Maybe Text 29 | -- ^ Used for paginating requests. Marks the position of the last 30 | -- request. 31 | , lakMaxItems :: Maybe Integer 32 | -- ^ Used for paginating requests. Specifies the maximum number of items 33 | -- to return in the response. Defaults to 100. 34 | } 35 | deriving (Eq, Ord, Show, Typeable) 36 | 37 | instance SignQuery ListAccessKeys where 38 | type ServiceConfiguration ListAccessKeys = IamConfiguration 39 | signQuery ListAccessKeys{..} 40 | = iamAction' "ListAccessKeys" $ [ 41 | ("UserName",) <$> lakUserName 42 | ] <> markedIter lakMarker lakMaxItems 43 | 44 | -- | Represents the IAM @AccessKeyMetadata@ data type. 45 | -- 46 | -- 47 | data AccessKeyMetadata 48 | = AccessKeyMetadata { 49 | akmAccessKeyId :: Maybe Text 50 | -- ^ ID of the access key. 51 | , akmCreateDate :: Maybe UTCTime 52 | -- ^ Date and time at which the access key was created. 53 | , akmStatus :: Maybe Text 54 | -- ^ Whether the access key is active. 55 | , akmUserName :: Maybe Text 56 | -- ^ Name of the user with whom the access key is associated. 57 | } 58 | deriving (Eq, Ord, Show, Typeable) 59 | 60 | data ListAccessKeysResponse 61 | = ListAccessKeysResponse { 62 | lakrAccessKeyMetadata :: [AccessKeyMetadata] 63 | -- ^ List of 'AccessKeyMetadata' objects 64 | , lakrIsTruncated :: Bool 65 | -- ^ @True@ if the request was truncated because of too many items. 66 | , lakrMarker :: Maybe Text 67 | -- ^ Marks the position at which the request was truncated. This value 68 | -- must be passed with the next request to continue listing from the 69 | -- last position. 70 | } 71 | deriving (Eq, Ord, Show, Typeable) 72 | 73 | instance ResponseConsumer ListAccessKeys ListAccessKeysResponse where 74 | type ResponseMetadata ListAccessKeysResponse = IamMetadata 75 | responseConsumer _ _ 76 | = iamResponseConsumer $ \cursor -> do 77 | (lakrIsTruncated, lakrMarker) <- markedIterResponse cursor 78 | lakrAccessKeyMetadata <- sequence $ 79 | cursor $// laxElement "member" &| buildAKM 80 | return ListAccessKeysResponse{..} 81 | where 82 | buildAKM m = do 83 | let mattr name = mhead $ m $/ elContent name 84 | let akmAccessKeyId = mattr "AccessKeyId" 85 | akmStatus = mattr "Status" 86 | akmUserName = mattr "UserName" 87 | akmCreateDate <- case m $/ elCont "CreateDate" of 88 | (x:_) -> Just <$> parseDateTime x 89 | _ -> return Nothing 90 | return AccessKeyMetadata{..} 91 | 92 | mhead (x:_) = Just x 93 | mhead _ = Nothing 94 | 95 | instance Transaction ListAccessKeys ListAccessKeysResponse 96 | 97 | instance IteratedTransaction ListAccessKeys ListAccessKeysResponse where 98 | nextIteratedRequest request response 99 | = case lakrMarker response of 100 | Nothing -> Nothing 101 | Just marker -> Just $ request { lakMarker = Just marker } 102 | 103 | instance AsMemoryResponse ListAccessKeysResponse where 104 | type MemoryResponse ListAccessKeysResponse = ListAccessKeysResponse 105 | loadToMemory = return 106 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/ListGroupPolicies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.ListGroupPolicies 6 | ( ListGroupPolicies(..) 7 | , ListGroupPoliciesResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Data.Text (Text) 14 | import Data.Typeable 15 | import Text.XML.Cursor (content, laxElement, ($//), (&/)) 16 | 17 | -- | Lists the group policies associated with the specified group. 18 | -- 19 | -- 20 | data ListGroupPolicies 21 | = ListGroupPolicies { 22 | lgpGroupName :: Text 23 | -- ^ Policies associated with this group will be listed. 24 | , lgpMarker :: Maybe Text 25 | -- ^ Used for paginating requests. Marks the position of the last 26 | -- request. 27 | , lgpMaxItems :: Maybe Integer 28 | -- ^ Used for paginating requests. Specifies the maximum number of items 29 | -- to return in the response. Defaults to 100. 30 | } 31 | deriving (Eq, Ord, Show, Typeable) 32 | 33 | instance SignQuery ListGroupPolicies where 34 | type ServiceConfiguration ListGroupPolicies = IamConfiguration 35 | signQuery ListGroupPolicies{..} 36 | = iamAction' "ListGroupPolicies" $ [ 37 | Just ("GroupName", lgpGroupName) 38 | ] <> markedIter lgpMarker lgpMaxItems 39 | 40 | data ListGroupPoliciesResponse 41 | = ListGroupPoliciesResponse { 42 | lgprPolicyNames :: [Text] 43 | -- ^ List of policy names. 44 | , lgprIsTruncated :: Bool 45 | -- ^ @True@ if the request was truncated because of too many items. 46 | , lgprMarker :: Maybe Text 47 | -- ^ Marks the position at which the request was truncated. This value 48 | -- must be passed with the next request to continue listing from the 49 | -- last position. 50 | } 51 | deriving (Eq, Ord, Show, Typeable) 52 | 53 | instance ResponseConsumer ListGroupPolicies ListGroupPoliciesResponse where 54 | type ResponseMetadata ListGroupPoliciesResponse = IamMetadata 55 | responseConsumer _ _ 56 | = iamResponseConsumer $ \cursor -> do 57 | (lgprIsTruncated, lgprMarker) <- markedIterResponse cursor 58 | let lgprPolicyNames = cursor $// laxElement "member" &/ content 59 | return ListGroupPoliciesResponse{..} 60 | 61 | instance Transaction ListGroupPolicies ListGroupPoliciesResponse 62 | 63 | instance IteratedTransaction ListGroupPolicies ListGroupPoliciesResponse where 64 | nextIteratedRequest request response 65 | = case lgprMarker response of 66 | Nothing -> Nothing 67 | Just marker -> Just $ request { lgpMarker = Just marker } 68 | 69 | instance AsMemoryResponse ListGroupPoliciesResponse where 70 | type MemoryResponse ListGroupPoliciesResponse = ListGroupPoliciesResponse 71 | loadToMemory = return 72 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/ListGroups.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.ListGroups 6 | ( ListGroups(..) 7 | , ListGroupsResponse(..) 8 | , Group(..) 9 | ) where 10 | 11 | import Aws.Core 12 | import Aws.Iam.Core 13 | import Aws.Iam.Internal 14 | import Control.Applicative 15 | import Data.Text (Text) 16 | import Data.Typeable 17 | import Prelude 18 | import Text.XML.Cursor (laxElement, ($//), (&|)) 19 | 20 | -- | Lists groups that have the specified path prefix. 21 | -- 22 | -- 23 | data ListGroups 24 | = ListGroups { 25 | lgPathPrefix :: Maybe Text 26 | -- ^ Groups defined under this path will be listed. If omitted, defaults 27 | -- to @/@, which lists all groups. 28 | , lgMarker :: Maybe Text 29 | -- ^ Used for paginating requests. Marks the position of the last 30 | -- request. 31 | , lgMaxItems :: Maybe Integer 32 | -- ^ Used for paginating requests. Specifies the maximum number of items 33 | -- to return in the response. Defaults to 100. 34 | } 35 | deriving (Eq, Ord, Show, Typeable) 36 | 37 | instance SignQuery ListGroups where 38 | type ServiceConfiguration ListGroups = IamConfiguration 39 | signQuery ListGroups{..} 40 | = iamAction' "ListGroups" $ [ 41 | ("PathPrefix",) <$> lgPathPrefix 42 | ] <> markedIter lgMarker lgMaxItems 43 | 44 | data ListGroupsResponse 45 | = ListGroupsResponse { 46 | lgrGroups :: [Group] 47 | -- ^ List of 'Group's. 48 | , lgrIsTruncated :: Bool 49 | -- ^ @True@ if the request was truncated because of too many items. 50 | , lgrMarker :: Maybe Text 51 | -- ^ Marks the position at which the request was truncated. This value 52 | -- must be passed with the next request to continue listing from the 53 | -- last position. 54 | } 55 | deriving (Eq, Ord, Show, Typeable) 56 | 57 | instance ResponseConsumer ListGroups ListGroupsResponse where 58 | type ResponseMetadata ListGroupsResponse = IamMetadata 59 | responseConsumer _ _ 60 | = iamResponseConsumer $ \cursor -> do 61 | (lgrIsTruncated, lgrMarker) <- markedIterResponse cursor 62 | lgrGroups <- sequence $ 63 | cursor $// laxElement "member" &| parseGroup 64 | return ListGroupsResponse{..} 65 | 66 | instance Transaction ListGroups ListGroupsResponse 67 | 68 | instance IteratedTransaction ListGroups ListGroupsResponse where 69 | nextIteratedRequest request response 70 | = case lgrMarker response of 71 | Nothing -> Nothing 72 | Just marker -> Just $ request { lgMarker = Just marker } 73 | 74 | instance AsMemoryResponse ListGroupsResponse where 75 | type MemoryResponse ListGroupsResponse = ListGroupsResponse 76 | loadToMemory = return 77 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/ListMfaDevices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Aws.Iam.Commands.ListMfaDevices 5 | ( ListMfaDevices(..) 6 | , ListMfaDevicesResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Control.Applicative 13 | import Data.Text (Text) 14 | import Data.Typeable 15 | import Prelude 16 | import Text.XML.Cursor (laxElement, ($//), (&|)) 17 | -- | Lists the MFA devices. If the request includes the user name, 18 | -- then this action lists all the MFA devices associated with the 19 | -- specified user name. If you do not specify a user name, IAM 20 | -- determines the user name implicitly based on the AWS access key ID 21 | -- signing the request. 22 | -- 23 | -- 24 | 25 | data ListMfaDevices = ListMfaDevices 26 | { lmfaUserName :: Maybe Text 27 | -- ^ The name of the user whose MFA devices 28 | -- you want to list. If you do not specify a 29 | -- user name, IAM determines the user name 30 | -- implicitly based on the AWS access key ID 31 | -- signing the request 32 | , lmfaMarker :: Maybe Text 33 | -- ^ Used for paginating requests. Marks the 34 | -- position of the last request. 35 | , lmfaMaxItems :: Maybe Integer 36 | -- ^ Used for paginating requests. Specifies 37 | -- the maximum number of items to return in 38 | -- the response. Defaults to 100. 39 | } deriving (Eq, Ord, Show, Typeable) 40 | 41 | instance SignQuery ListMfaDevices where 42 | type ServiceConfiguration ListMfaDevices = IamConfiguration 43 | signQuery ListMfaDevices{..} = iamAction' "ListMFADevices" 44 | ([ ("UserName",) <$> lmfaUserName ] 45 | <> markedIter lmfaMarker lmfaMaxItems) 46 | 47 | data ListMfaDevicesResponse = ListMfaDevicesResponse 48 | { lmfarMfaDevices :: [MfaDevice] 49 | -- ^ List of 'MFA Device's. 50 | , lmfarIsTruncated :: Bool 51 | -- ^ @True@ if the request was 52 | -- truncated because of too many 53 | -- items. 54 | , lmfarMarker :: Maybe Text 55 | -- ^ Marks the position at which the 56 | -- request was truncated. This value 57 | -- must be passed with the next 58 | -- request to continue listing from 59 | -- the last position. 60 | } deriving (Eq, Ord, Show, Typeable) 61 | 62 | instance ResponseConsumer ListMfaDevices ListMfaDevicesResponse where 63 | type ResponseMetadata ListMfaDevicesResponse = IamMetadata 64 | responseConsumer _ _req = 65 | iamResponseConsumer $ \ cursor -> do 66 | (lmfarIsTruncated, lmfarMarker) <- markedIterResponse cursor 67 | lmfarMfaDevices <- 68 | sequence $ cursor $// laxElement "member" &| parseMfaDevice 69 | return ListMfaDevicesResponse{..} 70 | 71 | instance Transaction ListMfaDevices ListMfaDevicesResponse 72 | 73 | instance IteratedTransaction ListMfaDevices ListMfaDevicesResponse where 74 | nextIteratedRequest request response 75 | = case lmfarMarker response of 76 | Nothing -> Nothing 77 | Just marker -> Just $ request { lmfaMarker = Just marker } 78 | 79 | instance AsMemoryResponse ListMfaDevicesResponse where 80 | type MemoryResponse ListMfaDevicesResponse = ListMfaDevicesResponse 81 | loadToMemory = return 82 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/ListUserPolicies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.ListUserPolicies 6 | ( ListUserPolicies(..) 7 | , ListUserPoliciesResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Data.Text (Text) 14 | import Data.Typeable 15 | import Text.XML.Cursor (content, laxElement, ($//), (&/)) 16 | 17 | -- | Lists the user policies associated with the specified user. 18 | -- 19 | -- 20 | data ListUserPolicies 21 | = ListUserPolicies { 22 | lupUserName :: Text 23 | -- ^ Policies associated with this user will be listed. 24 | , lupMarker :: Maybe Text 25 | -- ^ Used for paginating requests. Marks the position of the last 26 | -- request. 27 | , lupMaxItems :: Maybe Integer 28 | -- ^ Used for paginating requests. Specifies the maximum number of items 29 | -- to return in the response. Defaults to 100. 30 | } 31 | deriving (Eq, Ord, Show, Typeable) 32 | 33 | instance SignQuery ListUserPolicies where 34 | type ServiceConfiguration ListUserPolicies = IamConfiguration 35 | signQuery ListUserPolicies{..} 36 | = iamAction' "ListUserPolicies" $ [ 37 | Just ("UserName", lupUserName) 38 | ] <> markedIter lupMarker lupMaxItems 39 | 40 | data ListUserPoliciesResponse 41 | = ListUserPoliciesResponse { 42 | luprPolicyNames :: [Text] 43 | -- ^ List of policy names. 44 | , luprIsTruncated :: Bool 45 | -- ^ @True@ if the request was truncated because of too many items. 46 | , luprMarker :: Maybe Text 47 | -- ^ Marks the position at which the request was truncated. This value 48 | -- must be passed with the next request to continue listing from the 49 | -- last position. 50 | } 51 | deriving (Eq, Ord, Show, Typeable) 52 | 53 | instance ResponseConsumer ListUserPolicies ListUserPoliciesResponse where 54 | type ResponseMetadata ListUserPoliciesResponse = IamMetadata 55 | responseConsumer _ _ 56 | = iamResponseConsumer $ \cursor -> do 57 | (luprIsTruncated, luprMarker) <- markedIterResponse cursor 58 | let luprPolicyNames = cursor $// laxElement "member" &/ content 59 | return ListUserPoliciesResponse{..} 60 | 61 | instance Transaction ListUserPolicies ListUserPoliciesResponse 62 | 63 | instance IteratedTransaction ListUserPolicies ListUserPoliciesResponse where 64 | nextIteratedRequest request response 65 | = case luprMarker response of 66 | Nothing -> Nothing 67 | Just marker -> Just $ request { lupMarker = Just marker } 68 | 69 | instance AsMemoryResponse ListUserPoliciesResponse where 70 | type MemoryResponse ListUserPoliciesResponse = ListUserPoliciesResponse 71 | loadToMemory = return 72 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/ListUsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.ListUsers 6 | ( ListUsers(..) 7 | , ListUsersResponse(..) 8 | , User(..) 9 | ) where 10 | 11 | import Aws.Core 12 | import Aws.Iam.Core 13 | import Aws.Iam.Internal 14 | import Control.Applicative 15 | import Data.Text (Text) 16 | import Data.Typeable 17 | import Prelude 18 | import Text.XML.Cursor (laxElement, ($//), (&|)) 19 | 20 | -- | Lists users that have the specified path prefix. 21 | -- 22 | -- 23 | data ListUsers 24 | = ListUsers { 25 | luPathPrefix :: Maybe Text 26 | -- ^ Users defined under this path will be listed. If omitted, defaults 27 | -- to @/@, which lists all users. 28 | , luMarker :: Maybe Text 29 | -- ^ Used for paginating requests. Marks the position of the last 30 | -- request. 31 | , luMaxItems :: Maybe Integer 32 | -- ^ Used for paginating requests. Specifies the maximum number of items 33 | -- to return in the response. Defaults to 100. 34 | } 35 | deriving (Eq, Ord, Show, Typeable) 36 | 37 | instance SignQuery ListUsers where 38 | type ServiceConfiguration ListUsers = IamConfiguration 39 | signQuery ListUsers{..} 40 | = iamAction' "ListUsers" $ [ 41 | ("PathPrefix",) <$> luPathPrefix 42 | ] <> markedIter luMarker luMaxItems 43 | 44 | data ListUsersResponse 45 | = ListUsersResponse { 46 | lurUsers :: [User] 47 | -- ^ List of 'User's. 48 | , lurIsTruncated :: Bool 49 | -- ^ @True@ if the request was truncated because of too many items. 50 | , lurMarker :: Maybe Text 51 | -- ^ Marks the position at which the request was truncated. This value 52 | -- must be passed with the next request to continue listing from the 53 | -- last position. 54 | } 55 | deriving (Eq, Ord, Show, Typeable) 56 | 57 | instance ResponseConsumer ListUsers ListUsersResponse where 58 | type ResponseMetadata ListUsersResponse = IamMetadata 59 | responseConsumer _ _ 60 | = iamResponseConsumer $ \cursor -> do 61 | (lurIsTruncated, lurMarker) <- markedIterResponse cursor 62 | lurUsers <- sequence $ 63 | cursor $// laxElement "member" &| parseUser 64 | return ListUsersResponse{..} 65 | 66 | instance Transaction ListUsers ListUsersResponse 67 | 68 | instance IteratedTransaction ListUsers ListUsersResponse where 69 | nextIteratedRequest request response 70 | = case lurMarker response of 71 | Nothing -> Nothing 72 | Just marker -> Just $ request { luMarker = Just marker } 73 | 74 | instance AsMemoryResponse ListUsersResponse where 75 | type MemoryResponse ListUsersResponse = ListUsersResponse 76 | loadToMemory = return 77 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/PutGroupPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.PutGroupPolicy 5 | ( PutGroupPolicy(..) 6 | , PutGroupPolicyResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Data.Text (Text) 13 | import Data.Typeable 14 | 15 | -- | Adds a policy document with the specified name, associated with the 16 | -- specified group. 17 | -- 18 | -- 19 | data PutGroupPolicy 20 | = PutGroupPolicy { 21 | pgpPolicyDocument :: Text 22 | -- ^ The policy document. 23 | , pgpPolicyName :: Text 24 | -- ^ Name of the policy. 25 | , pgpGroupName :: Text 26 | -- ^ Name of the group with whom this policy is associated. 27 | } 28 | deriving (Eq, Ord, Show, Typeable) 29 | 30 | instance SignQuery PutGroupPolicy where 31 | type ServiceConfiguration PutGroupPolicy = IamConfiguration 32 | signQuery PutGroupPolicy{..} 33 | = iamAction "PutGroupPolicy" [ 34 | ("PolicyDocument", pgpPolicyDocument) 35 | , ("PolicyName" , pgpPolicyName) 36 | , ("GroupName" , pgpGroupName) 37 | ] 38 | 39 | data PutGroupPolicyResponse = PutGroupPolicyResponse 40 | deriving (Eq, Ord, Show, Typeable) 41 | 42 | instance ResponseConsumer PutGroupPolicy PutGroupPolicyResponse where 43 | type ResponseMetadata PutGroupPolicyResponse = IamMetadata 44 | responseConsumer _ _ 45 | = iamResponseConsumer (const $ return PutGroupPolicyResponse) 46 | 47 | instance Transaction PutGroupPolicy PutGroupPolicyResponse 48 | 49 | instance AsMemoryResponse PutGroupPolicyResponse where 50 | type MemoryResponse PutGroupPolicyResponse = PutGroupPolicyResponse 51 | loadToMemory = return 52 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/PutUserPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.PutUserPolicy 5 | ( PutUserPolicy(..) 6 | , PutUserPolicyResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Data.Text (Text) 13 | import Data.Typeable 14 | 15 | -- | Adds a policy document with the specified name, associated with the 16 | -- specified user. 17 | -- 18 | -- 19 | data PutUserPolicy 20 | = PutUserPolicy { 21 | pupPolicyDocument :: Text 22 | -- ^ The policy document. 23 | , pupPolicyName :: Text 24 | -- ^ Name of the policy. 25 | , pupUserName :: Text 26 | -- ^ Name of the user with whom this policy is associated. 27 | } 28 | deriving (Eq, Ord, Show, Typeable) 29 | 30 | instance SignQuery PutUserPolicy where 31 | type ServiceConfiguration PutUserPolicy = IamConfiguration 32 | signQuery PutUserPolicy{..} 33 | = iamAction "PutUserPolicy" [ 34 | ("PolicyDocument", pupPolicyDocument) 35 | , ("PolicyName" , pupPolicyName) 36 | , ("UserName" , pupUserName) 37 | ] 38 | 39 | data PutUserPolicyResponse = PutUserPolicyResponse 40 | deriving (Eq, Ord, Show, Typeable) 41 | 42 | instance ResponseConsumer PutUserPolicy PutUserPolicyResponse where 43 | type ResponseMetadata PutUserPolicyResponse = IamMetadata 44 | responseConsumer _ _ 45 | = iamResponseConsumer (const $ return PutUserPolicyResponse) 46 | 47 | instance Transaction PutUserPolicy PutUserPolicyResponse 48 | 49 | instance AsMemoryResponse PutUserPolicyResponse where 50 | type MemoryResponse PutUserPolicyResponse = PutUserPolicyResponse 51 | loadToMemory = return 52 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/RemoveUserFromGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Aws.Iam.Commands.RemoveUserFromGroup 5 | ( RemoveUserFromGroup(..) 6 | , RemoveUserFromGroupResponse(..) 7 | ) where 8 | 9 | import Aws.Core 10 | import Aws.Iam.Core 11 | import Aws.Iam.Internal 12 | import Data.Text (Text) 13 | import Data.Typeable 14 | 15 | -- | Removes the specified user from the specified group. 16 | -- 17 | -- 18 | data RemoveUserFromGroup 19 | = RemoveUserFromGroup { 20 | rufgGroupName :: Text 21 | -- ^ Name of the group to update. 22 | , rufgUserName :: Text 23 | -- ^ The of the user to add. 24 | } 25 | deriving (Eq, Ord, Show, Typeable) 26 | 27 | instance SignQuery RemoveUserFromGroup where 28 | type ServiceConfiguration RemoveUserFromGroup = IamConfiguration 29 | signQuery RemoveUserFromGroup{..} 30 | = iamAction "RemoveUserFromGroup" [ 31 | ("GroupName" , rufgGroupName) 32 | , ("UserName" , rufgUserName) 33 | ] 34 | 35 | data RemoveUserFromGroupResponse = RemoveUserFromGroupResponse 36 | deriving (Eq, Ord, Show, Typeable) 37 | 38 | instance ResponseConsumer RemoveUserFromGroup RemoveUserFromGroupResponse where 39 | type ResponseMetadata RemoveUserFromGroupResponse = IamMetadata 40 | responseConsumer _ _ 41 | = iamResponseConsumer (const $ return RemoveUserFromGroupResponse) 42 | 43 | instance Transaction RemoveUserFromGroup RemoveUserFromGroupResponse 44 | 45 | instance AsMemoryResponse RemoveUserFromGroupResponse where 46 | type MemoryResponse RemoveUserFromGroupResponse = RemoveUserFromGroupResponse 47 | loadToMemory = return 48 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/UpdateAccessKey.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.UpdateAccessKey 6 | ( UpdateAccessKey(..) 7 | , UpdateAccessKeyResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Prelude 17 | 18 | -- | Changes the status of the specified access key. 19 | -- 20 | -- 21 | data UpdateAccessKey 22 | = UpdateAccessKey { 23 | uakAccessKeyId :: Text 24 | -- ^ ID of the access key to update. 25 | , uakStatus :: AccessKeyStatus 26 | -- ^ New status of the access key. 27 | , uakUserName :: Maybe Text 28 | -- ^ Name of the user to whom the access key belongs. If omitted, the 29 | -- user will be determined based on the access key used to sign the 30 | -- request. 31 | } 32 | deriving (Eq, Ord, Show, Typeable) 33 | 34 | instance SignQuery UpdateAccessKey where 35 | type ServiceConfiguration UpdateAccessKey = IamConfiguration 36 | signQuery UpdateAccessKey{..} 37 | = iamAction' "UpdateAccessKey" [ 38 | Just ("AccessKeyId", uakAccessKeyId) 39 | , Just ("Status", showStatus uakStatus) 40 | , ("UserName",) <$> uakUserName 41 | ] 42 | where 43 | showStatus AccessKeyActive = "Active" 44 | showStatus _ = "Inactive" 45 | 46 | data UpdateAccessKeyResponse = UpdateAccessKeyResponse 47 | deriving (Eq, Ord, Show, Typeable) 48 | 49 | instance ResponseConsumer UpdateAccessKey UpdateAccessKeyResponse where 50 | type ResponseMetadata UpdateAccessKeyResponse = IamMetadata 51 | responseConsumer _ _ 52 | = iamResponseConsumer (const $ return UpdateAccessKeyResponse) 53 | 54 | instance Transaction UpdateAccessKey UpdateAccessKeyResponse 55 | 56 | instance AsMemoryResponse UpdateAccessKeyResponse where 57 | type MemoryResponse UpdateAccessKeyResponse = UpdateAccessKeyResponse 58 | loadToMemory = return 59 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/UpdateGroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.UpdateGroup 6 | ( UpdateGroup(..) 7 | , UpdateGroupResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Prelude 17 | 18 | -- | Updates the name and/or path of the specified group. 19 | -- 20 | -- 21 | data UpdateGroup 22 | = UpdateGroup { 23 | ugGroupName :: Text 24 | -- ^ Name of the group to be updated. 25 | , ugNewGroupName :: Maybe Text 26 | -- ^ New name for the group. 27 | , ugNewPath :: Maybe Text 28 | -- ^ New path to which the group will be moved. 29 | } 30 | deriving (Eq, Ord, Show, Typeable) 31 | 32 | instance SignQuery UpdateGroup where 33 | type ServiceConfiguration UpdateGroup = IamConfiguration 34 | signQuery UpdateGroup{..} 35 | = iamAction' "UpdateGroup" [ 36 | Just ("GroupName", ugGroupName) 37 | , ("NewGroupName",) <$> ugNewGroupName 38 | , ("NewPath",) <$> ugNewPath 39 | ] 40 | 41 | data UpdateGroupResponse = UpdateGroupResponse 42 | deriving (Eq, Ord, Show, Typeable) 43 | 44 | instance ResponseConsumer UpdateGroup UpdateGroupResponse where 45 | type ResponseMetadata UpdateGroupResponse = IamMetadata 46 | responseConsumer _ _ 47 | = iamResponseConsumer (const $ return UpdateGroupResponse) 48 | 49 | instance Transaction UpdateGroup UpdateGroupResponse 50 | 51 | instance AsMemoryResponse UpdateGroupResponse where 52 | type MemoryResponse UpdateGroupResponse = UpdateGroupResponse 53 | loadToMemory = return 54 | -------------------------------------------------------------------------------- /Aws/Iam/Commands/UpdateUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Aws.Iam.Commands.UpdateUser 6 | ( UpdateUser(..) 7 | , UpdateUserResponse(..) 8 | ) where 9 | 10 | import Aws.Core 11 | import Aws.Iam.Core 12 | import Aws.Iam.Internal 13 | import Control.Applicative 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Prelude 17 | 18 | -- | Updates the name and/or path of the specified user. 19 | -- 20 | -- 21 | data UpdateUser 22 | = UpdateUser { 23 | uuUserName :: Text 24 | -- ^ Name of the user to be updated. 25 | , uuNewUserName :: Maybe Text 26 | -- ^ New name for the user. 27 | , uuNewPath :: Maybe Text 28 | -- ^ New path to which the user will be moved. 29 | } 30 | deriving (Eq, Ord, Show, Typeable) 31 | 32 | instance SignQuery UpdateUser where 33 | type ServiceConfiguration UpdateUser = IamConfiguration 34 | signQuery UpdateUser{..} 35 | = iamAction' "UpdateUser" [ 36 | Just ("UserName", uuUserName) 37 | , ("NewUserName",) <$> uuNewUserName 38 | , ("NewPath",) <$> uuNewPath 39 | ] 40 | 41 | data UpdateUserResponse = UpdateUserResponse 42 | deriving (Eq, Ord, Show, Typeable) 43 | 44 | instance ResponseConsumer UpdateUser UpdateUserResponse where 45 | type ResponseMetadata UpdateUserResponse = IamMetadata 46 | responseConsumer _ _ 47 | = iamResponseConsumer (const $ return UpdateUserResponse) 48 | 49 | instance Transaction UpdateUser UpdateUserResponse 50 | 51 | instance AsMemoryResponse UpdateUserResponse where 52 | type MemoryResponse UpdateUserResponse = UpdateUserResponse 53 | loadToMemory = return 54 | -------------------------------------------------------------------------------- /Aws/Iam/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TupleSections #-} 4 | module Aws.Iam.Internal 5 | ( iamAction 6 | , iamAction' 7 | , markedIter 8 | , markedIterResponse 9 | 10 | -- * Re-exports 11 | , (<>) 12 | ) where 13 | 14 | import Aws.Core 15 | import Aws.Iam.Core 16 | import Control.Applicative 17 | import Control.Arrow (second) 18 | import Control.Monad 19 | import Control.Monad.Trans.Resource (MonadThrow) 20 | import Data.ByteString (ByteString) 21 | import Data.Maybe 22 | import Data.Monoid 23 | import Prelude 24 | import Data.Text (Text) 25 | import qualified Data.Text as Text 26 | import qualified Data.Text.Encoding as Text 27 | import Text.XML.Cursor (($//)) 28 | import qualified Text.XML.Cursor as Cu 29 | 30 | -- | Similar to 'iamSignQuery'. Accepts parameters in @Text@ form and UTF-8 31 | -- encodes them. Accepts the @Action@ parameter separately since it's always 32 | -- required. 33 | iamAction 34 | :: ByteString 35 | -> [(ByteString, Text)] 36 | -> IamConfiguration qt 37 | -> SignatureData 38 | -> SignedQuery 39 | iamAction action = iamSignQuery 40 | . (:) ("Action", action) 41 | . map (second Text.encodeUtf8) 42 | 43 | -- | Similar to 'iamAction'. Accepts parameter list with @Maybe@ parameters. 44 | -- Ignores @Nothing@s. 45 | iamAction' 46 | :: ByteString 47 | -> [Maybe (ByteString, Text)] 48 | -> IamConfiguration qt 49 | -> SignatureData 50 | -> SignedQuery 51 | iamAction' action = iamAction action . catMaybes 52 | 53 | -- | Returns the parameters @Marker@ and @MaxItems@ that are present in all 54 | -- IAM data pagination requests. 55 | markedIter :: Maybe Text -> Maybe Integer -> [Maybe (ByteString, Text)] 56 | markedIter marker maxItems 57 | = [ ("Marker" ,) <$> marker 58 | , ("MaxItems",) . encodeInteger <$> maxItems 59 | ] 60 | where 61 | encodeInteger = Text.pack . show 62 | 63 | -- | Reads and returns the @IsTruncated@ and @Marker@ attributes present in 64 | -- all IAM data pagination responses. 65 | markedIterResponse 66 | :: MonadThrow m 67 | => Cu.Cursor 68 | -> m (Bool, Maybe Text) 69 | markedIterResponse cursor = do 70 | isTruncated <- (Text.toCaseFold "true" ==) `liftM` attr "IsTruncated" 71 | marker <- if isTruncated 72 | then Just `liftM` attr "Marker" 73 | else return Nothing 74 | return (isTruncated, marker) 75 | where 76 | attr name = force ("Missing " ++ Text.unpack name) $ 77 | cursor $// elContent name 78 | -------------------------------------------------------------------------------- /Aws/Network.hs: -------------------------------------------------------------------------------- 1 | module Aws.Network where 2 | 3 | import Data.Maybe 4 | import Control.Exception 5 | import Network.BSD (getProtocolNumber) 6 | import Network.Socket 7 | import System.Timeout 8 | 9 | -- Make a good guess if a host is reachable. 10 | hostAvailable :: String -> IO Bool 11 | hostAvailable h = do 12 | sock <- getProtocolNumber "tcp" >>= socket AF_INET Stream 13 | addr <- (addrAddress . head) `fmap` getAddrInfo (Just (defaultHints { addrFlags = [ AI_PASSIVE ] } )) (Just h) (Just "80") 14 | case addr of 15 | remote@(SockAddrInet _ _) -> do 16 | v <- catch (timeout 100000 (connect sock remote) >>= return . isJust) 17 | (\(_ :: SomeException) -> return False) 18 | close sock 19 | return v 20 | _ -> return False 21 | -------------------------------------------------------------------------------- /Aws/S3.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3 2 | ( 3 | module Aws.S3.Commands 4 | , module Aws.S3.Core 5 | ) 6 | where 7 | 8 | import Aws.S3.Commands 9 | import Aws.S3.Core 10 | -------------------------------------------------------------------------------- /Aws/S3/Commands.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands 2 | ( 3 | module Aws.S3.Commands.CopyObject 4 | , module Aws.S3.Commands.DeleteBucket 5 | , module Aws.S3.Commands.DeleteObject 6 | , module Aws.S3.Commands.DeleteObjectVersion 7 | , module Aws.S3.Commands.DeleteObjects 8 | , module Aws.S3.Commands.GetBucket 9 | , module Aws.S3.Commands.GetBucketLocation 10 | , module Aws.S3.Commands.GetBucketObjectVersions 11 | , module Aws.S3.Commands.GetBucketVersioning 12 | , module Aws.S3.Commands.GetObject 13 | , module Aws.S3.Commands.GetService 14 | , module Aws.S3.Commands.HeadObject 15 | , module Aws.S3.Commands.PutBucket 16 | , module Aws.S3.Commands.PutBucketVersioning 17 | , module Aws.S3.Commands.PutObject 18 | , module Aws.S3.Commands.Multipart 19 | ) 20 | where 21 | 22 | import Aws.S3.Commands.CopyObject 23 | import Aws.S3.Commands.DeleteBucket 24 | import Aws.S3.Commands.DeleteObject 25 | import Aws.S3.Commands.DeleteObjectVersion 26 | import Aws.S3.Commands.DeleteObjects 27 | import Aws.S3.Commands.GetBucket 28 | import Aws.S3.Commands.GetBucketLocation 29 | import Aws.S3.Commands.GetBucketObjectVersions 30 | import Aws.S3.Commands.GetBucketVersioning 31 | import Aws.S3.Commands.GetObject 32 | import Aws.S3.Commands.GetService 33 | import Aws.S3.Commands.HeadObject 34 | import Aws.S3.Commands.PutBucket 35 | import Aws.S3.Commands.PutBucketVersioning 36 | import Aws.S3.Commands.PutObject 37 | import Aws.S3.Commands.Multipart 38 | -------------------------------------------------------------------------------- /Aws/S3/Commands/DeleteBucket.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.DeleteBucket 2 | where 3 | 4 | import Aws.Core 5 | import Aws.S3.Core 6 | import Data.ByteString.Char8 ({- IsString -}) 7 | import qualified Data.Text.Encoding as T 8 | 9 | data DeleteBucket = DeleteBucket { dbBucket :: Bucket } 10 | deriving (Show) 11 | 12 | data DeleteBucketResponse = DeleteBucketResponse {} 13 | deriving (Show) 14 | 15 | -- | ServiceConfiguration: 'S3Configuration' 16 | instance SignQuery DeleteBucket where 17 | type ServiceConfiguration DeleteBucket = S3Configuration 18 | signQuery DeleteBucket {..} = s3SignQuery S3Query { 19 | s3QMethod = Delete 20 | , s3QBucket = Just $ T.encodeUtf8 dbBucket 21 | , s3QSubresources = [] 22 | , s3QQuery = [] 23 | , s3QContentType = Nothing 24 | , s3QContentMd5 = Nothing 25 | , s3QAmzHeaders = [] 26 | , s3QOtherHeaders = [] 27 | , s3QRequestBody = Nothing 28 | , s3QObject = Nothing 29 | } 30 | 31 | instance ResponseConsumer DeleteBucket DeleteBucketResponse where 32 | type ResponseMetadata DeleteBucketResponse = S3Metadata 33 | responseConsumer _ _ = s3ResponseConsumer $ \_ -> return DeleteBucketResponse 34 | 35 | instance Transaction DeleteBucket DeleteBucketResponse 36 | 37 | instance AsMemoryResponse DeleteBucketResponse where 38 | type MemoryResponse DeleteBucketResponse = DeleteBucketResponse 39 | loadToMemory = return 40 | -------------------------------------------------------------------------------- /Aws/S3/Commands/DeleteObject.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.DeleteObject 2 | where 3 | 4 | import Aws.Core 5 | import Aws.S3.Core 6 | import Data.ByteString.Char8 ({- IsString -}) 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as T 9 | 10 | data DeleteObject = DeleteObject { 11 | doObjectName :: T.Text, 12 | doBucket :: Bucket 13 | } deriving (Show) 14 | 15 | data DeleteObjectResponse = DeleteObjectResponse{ 16 | } deriving (Show) 17 | 18 | -- | ServiceConfiguration: 'S3Configuration' 19 | instance SignQuery DeleteObject where 20 | type ServiceConfiguration DeleteObject = S3Configuration 21 | signQuery DeleteObject {..} = s3SignQuery S3Query { 22 | s3QMethod = Delete 23 | , s3QBucket = Just $ T.encodeUtf8 doBucket 24 | , s3QSubresources = [] 25 | , s3QQuery = [] 26 | , s3QContentType = Nothing 27 | , s3QContentMd5 = Nothing 28 | , s3QAmzHeaders = [] 29 | , s3QOtherHeaders = [] 30 | , s3QRequestBody = Nothing 31 | , s3QObject = Just $ T.encodeUtf8 doObjectName 32 | } 33 | 34 | instance ResponseConsumer DeleteObject DeleteObjectResponse where 35 | type ResponseMetadata DeleteObjectResponse = S3Metadata 36 | responseConsumer _ _ 37 | = s3ResponseConsumer $ \_ -> return DeleteObjectResponse 38 | 39 | instance Transaction DeleteObject DeleteObjectResponse 40 | 41 | instance AsMemoryResponse DeleteObjectResponse where 42 | type MemoryResponse DeleteObjectResponse = DeleteObjectResponse 43 | loadToMemory = return 44 | -------------------------------------------------------------------------------- /Aws/S3/Commands/DeleteObjectVersion.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.DeleteObjectVersion 2 | where 3 | 4 | import Aws.Core 5 | import Aws.S3.Core 6 | import Data.ByteString.Char8 ({- IsString -}) 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as T 9 | 10 | data DeleteObjectVersion = DeleteObjectVersion { 11 | dovObjectName :: T.Text, 12 | dovBucket :: Bucket, 13 | dovVersionId :: T.Text 14 | } deriving (Show) 15 | 16 | deleteObjectVersion :: Bucket -> T.Text -> T.Text -> DeleteObjectVersion 17 | deleteObjectVersion bucket object version 18 | = DeleteObjectVersion { 19 | dovObjectName = object 20 | , dovBucket = bucket 21 | , dovVersionId = version 22 | } 23 | 24 | data DeleteObjectVersionResponse = DeleteObjectVersionResponse { 25 | } deriving (Show) 26 | 27 | -- | ServiceConfiguration: 'S3Configuration' 28 | instance SignQuery DeleteObjectVersion where 29 | type ServiceConfiguration DeleteObjectVersion = S3Configuration 30 | signQuery DeleteObjectVersion {..} = s3SignQuery S3Query { 31 | s3QMethod = Delete 32 | , s3QBucket = Just $ T.encodeUtf8 dovBucket 33 | , s3QSubresources = [ ("versionId", Just $ T.encodeUtf8 dovVersionId) ] 34 | , s3QQuery = [] 35 | , s3QContentType = Nothing 36 | , s3QContentMd5 = Nothing 37 | , s3QAmzHeaders = [] 38 | , s3QOtherHeaders = [] 39 | , s3QRequestBody = Nothing 40 | , s3QObject = Just $ T.encodeUtf8 dovObjectName 41 | } 42 | 43 | instance ResponseConsumer DeleteObjectVersion DeleteObjectVersionResponse where 44 | type ResponseMetadata DeleteObjectVersionResponse = S3Metadata 45 | responseConsumer _ _ 46 | = s3ResponseConsumer $ \_ -> return DeleteObjectVersionResponse 47 | 48 | instance Transaction DeleteObjectVersion DeleteObjectVersionResponse 49 | 50 | instance AsMemoryResponse DeleteObjectVersionResponse where 51 | type MemoryResponse DeleteObjectVersionResponse = DeleteObjectVersionResponse 52 | loadToMemory = return 53 | -------------------------------------------------------------------------------- /Aws/S3/Commands/DeleteObjects.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.DeleteObjects where 2 | 3 | import Aws.Core 4 | import Aws.S3.Core 5 | import qualified Crypto.Hash as CH 6 | import qualified Data.Map as M 7 | import Data.Maybe 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as T 10 | import qualified Network.HTTP.Conduit as HTTP 11 | import qualified Network.HTTP.Types as HTTP 12 | import qualified Text.XML as XML 13 | import qualified Text.XML.Cursor as Cu 14 | import Text.XML.Cursor (($/), (&|)) 15 | import qualified Data.ByteString.Char8 as B 16 | import Data.ByteString.Char8 ({- IsString -}) 17 | import Control.Applicative 18 | import Prelude 19 | 20 | data DeleteObjects 21 | = DeleteObjects { 22 | dosBucket :: Bucket 23 | , dosObjects :: [(Object, Maybe T.Text)] -- snd is an optional versionId 24 | , dosQuiet :: Bool 25 | , dosMultiFactorAuthentication :: Maybe T.Text 26 | } 27 | deriving (Show) 28 | 29 | -- simple use case: neither mfa, nor version specified, quiet 30 | deleteObjects :: Bucket -> [T.Text] -> DeleteObjects 31 | deleteObjects bucket objs = 32 | DeleteObjects { 33 | dosBucket = bucket 34 | , dosObjects = zip objs $ repeat Nothing 35 | , dosQuiet = True 36 | , dosMultiFactorAuthentication = Nothing 37 | } 38 | 39 | data DeleteObjectsResponse 40 | = DeleteObjectsResponse { 41 | dorDeleted :: [DORDeleted] 42 | , dorErrors :: [DORErrors] 43 | } 44 | deriving (Show) 45 | 46 | --omitting DeleteMarker because it appears superfluous 47 | data DORDeleted 48 | = DORDeleted { 49 | ddKey :: T.Text 50 | , ddVersionId :: Maybe T.Text 51 | , ddDeleteMarkerVersionId :: Maybe T.Text 52 | } 53 | deriving (Show) 54 | 55 | data DORErrors 56 | = DORErrors { 57 | deKey :: T.Text 58 | , deCode :: T.Text 59 | , deMessage :: T.Text 60 | } 61 | deriving (Show) 62 | 63 | -- | ServiceConfiguration: 'S3Configuration' 64 | instance SignQuery DeleteObjects where 65 | type ServiceConfiguration DeleteObjects = S3Configuration 66 | 67 | signQuery DeleteObjects {..} = s3SignQuery S3Query 68 | { 69 | s3QMethod = Post 70 | , s3QBucket = Just $ T.encodeUtf8 dosBucket 71 | , s3QSubresources = HTTP.toQuery [("delete" :: B.ByteString, Nothing :: Maybe B.ByteString)] 72 | , s3QQuery = [] 73 | , s3QContentType = Nothing 74 | , s3QContentMd5 = Just $ CH.hashlazy dosBody 75 | , s3QObject = Nothing 76 | , s3QAmzHeaders = maybeToList $ (("x-amz-mfa", ) . T.encodeUtf8) <$> dosMultiFactorAuthentication 77 | , s3QOtherHeaders = [] 78 | , s3QRequestBody = Just $ HTTP.RequestBodyLBS dosBody 79 | } 80 | where dosBody = XML.renderLBS XML.def XML.Document { 81 | XML.documentPrologue = XML.Prologue [] Nothing [] 82 | , XML.documentRoot = root 83 | , XML.documentEpilogue = [] 84 | } 85 | root = XML.Element { 86 | XML.elementName = "Delete" 87 | , XML.elementAttributes = M.empty 88 | , XML.elementNodes = quietNode dosQuiet : (objectNode <$> dosObjects) 89 | } 90 | objectNode (obj, mbVersion) = XML.NodeElement XML.Element { 91 | XML.elementName = "Object" 92 | , XML.elementAttributes = M.empty 93 | , XML.elementNodes = keyNode obj : maybeToList (versionNode <$> mbVersion) 94 | } 95 | versionNode = toNode "VersionId" 96 | keyNode = toNode "Key" 97 | quietNode b = toNode "Quiet" $ if b then "true" else "false" 98 | toNode name content = XML.NodeElement XML.Element { 99 | XML.elementName = name 100 | , XML.elementAttributes = M.empty 101 | , XML.elementNodes = [XML.NodeContent content] 102 | } 103 | 104 | instance ResponseConsumer DeleteObjects DeleteObjectsResponse where 105 | type ResponseMetadata DeleteObjectsResponse = S3Metadata 106 | 107 | responseConsumer _ _ = s3XmlResponseConsumer parse 108 | where parse cursor = do 109 | dorDeleted <- sequence $ cursor $/ Cu.laxElement "Deleted" &| parseDeleted 110 | dorErrors <- sequence $ cursor $/ Cu.laxElement "Error" &| parseErrors 111 | return DeleteObjectsResponse {..} 112 | parseDeleted c = do 113 | ddKey <- force "Missing Key" $ c $/ elContent "Key" 114 | let ddVersionId = listToMaybe $ c $/ elContent "VersionId" 115 | ddDeleteMarkerVersionId = listToMaybe $ c $/ elContent "DeleteMarkerVersionId" 116 | return DORDeleted {..} 117 | parseErrors c = do 118 | deKey <- force "Missing Key" $ c $/ elContent "Key" 119 | deCode <- force "Missing Code" $ c $/ elContent "Code" 120 | deMessage <- force "Missing Message" $ c $/ elContent "Message" 121 | return DORErrors {..} 122 | 123 | instance Transaction DeleteObjects DeleteObjectsResponse 124 | 125 | instance AsMemoryResponse DeleteObjectsResponse where 126 | type MemoryResponse DeleteObjectsResponse = DeleteObjectsResponse 127 | loadToMemory = return 128 | -------------------------------------------------------------------------------- /Aws/S3/Commands/GetBucketLocation.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.GetBucketLocation 2 | where 3 | 4 | import Aws.Core 5 | import Aws.S3.Core 6 | 7 | import qualified Data.ByteString.Char8 as B8 8 | 9 | import qualified Data.Text as T 10 | import qualified Data.Text.Encoding as T 11 | import qualified Network.HTTP.Types as HTTP 12 | import Text.XML.Cursor (($.//)) 13 | 14 | data GetBucketLocation 15 | = GetBucketLocation { 16 | gblBucket :: Bucket 17 | } deriving Show 18 | 19 | getBucketLocation :: Bucket -> GetBucketLocation 20 | getBucketLocation bucket 21 | = GetBucketLocation { 22 | gblBucket = bucket 23 | } 24 | 25 | data GetBucketLocationResponse 26 | = GetBucketLocationResponse { gblrLocationConstraint :: LocationConstraint } 27 | deriving Show 28 | 29 | instance SignQuery GetBucketLocation where 30 | type ServiceConfiguration GetBucketLocation = S3Configuration 31 | signQuery GetBucketLocation {..} = s3SignQuery S3Query { 32 | s3QMethod = Get 33 | , s3QBucket = Just $ T.encodeUtf8 gblBucket 34 | , s3QObject = Nothing 35 | , s3QSubresources = [("location" :: B8.ByteString, Nothing :: Maybe B8.ByteString)] 36 | , s3QQuery = HTTP.toQuery ([] :: [(B8.ByteString, T.Text)]) 37 | , s3QContentType = Nothing 38 | , s3QContentMd5 = Nothing 39 | , s3QAmzHeaders = [] 40 | , s3QOtherHeaders = [] 41 | , s3QRequestBody = Nothing 42 | } 43 | 44 | instance ResponseConsumer r GetBucketLocationResponse where 45 | type ResponseMetadata GetBucketLocationResponse = S3Metadata 46 | 47 | responseConsumer _ _ = s3XmlResponseConsumer parse 48 | where parse cursor = do 49 | locationConstraint <- force "Missing Location" $ cursor $.// elContent "LocationConstraint" 50 | return GetBucketLocationResponse { gblrLocationConstraint = normaliseLocation locationConstraint } 51 | 52 | instance Transaction GetBucketLocation GetBucketLocationResponse 53 | 54 | instance AsMemoryResponse GetBucketLocationResponse where 55 | type MemoryResponse GetBucketLocationResponse = GetBucketLocationResponse 56 | loadToMemory = return 57 | -------------------------------------------------------------------------------- /Aws/S3/Commands/GetBucketVersioning.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.GetBucketVersioning 2 | ( 3 | module Aws.S3.Commands.GetBucketVersioning 4 | , VersioningState(..) 5 | ) where 6 | 7 | import Aws.Core 8 | import Aws.S3.Commands.PutBucketVersioning (VersioningState(..)) 9 | import Aws.S3.Core 10 | import Control.Monad.Trans.Resource (throwM) 11 | import Network.HTTP.Types (toQuery) 12 | import qualified Data.Text.Encoding as T 13 | import Text.XML.Cursor (($.//)) 14 | import qualified Data.ByteString.Lazy.Char8 as B8 15 | 16 | -- | Gets the versioning state of an existing bucket. 17 | data GetBucketVersioning 18 | = GetBucketVersioning 19 | { gbvBucket :: Bucket 20 | } 21 | deriving (Show) 22 | 23 | getBucketVersioning :: Bucket -> GetBucketVersioning 24 | getBucketVersioning = GetBucketVersioning 25 | 26 | data GetBucketVersioningResponse 27 | = GetBucketVersioningResponse 28 | { gbvVersioning :: Maybe VersioningState } 29 | -- ^ Nothing when the bucket is not versioned 30 | deriving (Show) 31 | 32 | -- | ServiceConfiguration: 'S3Configuration' 33 | instance SignQuery GetBucketVersioning where 34 | type ServiceConfiguration GetBucketVersioning = S3Configuration 35 | 36 | signQuery GetBucketVersioning{..} = s3SignQuery $ S3Query 37 | { s3QMethod = Get 38 | , s3QBucket = Just $ T.encodeUtf8 gbvBucket 39 | , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)] 40 | , s3QQuery = [] 41 | , s3QContentType = Nothing 42 | , s3QContentMd5 = Nothing 43 | , s3QObject = Nothing 44 | , s3QAmzHeaders = [] 45 | , s3QOtherHeaders = [] 46 | , s3QRequestBody = Nothing 47 | } 48 | 49 | instance ResponseConsumer r GetBucketVersioningResponse where 50 | type ResponseMetadata GetBucketVersioningResponse = S3Metadata 51 | 52 | responseConsumer _ _ = s3XmlResponseConsumer parse 53 | where parse cursor = do 54 | v <- case cursor $.// elContent "Status" of 55 | [] -> return Nothing 56 | ("Enabled":[]) -> return (Just VersioningEnabled) 57 | ("Suspended":[]) -> return (Just VersioningSuspended) 58 | _ -> throwM $ XmlException "Invalid Status" 59 | return GetBucketVersioningResponse { gbvVersioning = v } 60 | 61 | instance Transaction GetBucketVersioning GetBucketVersioningResponse 62 | 63 | instance AsMemoryResponse GetBucketVersioningResponse where 64 | type MemoryResponse GetBucketVersioningResponse = GetBucketVersioningResponse 65 | loadToMemory = return 66 | -------------------------------------------------------------------------------- /Aws/S3/Commands/GetObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Aws.S3.Commands.GetObject 4 | where 5 | 6 | import Aws.Core 7 | import Aws.S3.Core 8 | import Control.Applicative 9 | import Control.Monad.Trans.Resource (ResourceT) 10 | import Data.ByteString.Char8 ({- IsString -}) 11 | import qualified Data.ByteString.Char8 as B8 12 | import qualified Data.ByteString.Lazy as L 13 | import qualified Data.Conduit as C 14 | import Data.Conduit ((.|)) 15 | import qualified Data.Conduit.List as CL 16 | import Data.Maybe 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import Prelude 20 | import qualified Network.HTTP.Conduit as HTTP 21 | import qualified Network.HTTP.Types as HTTP 22 | 23 | data GetObject 24 | = GetObject { 25 | goBucket :: Bucket 26 | , goObjectName :: Object 27 | , goVersionId :: Maybe T.Text 28 | , goResponseContentType :: Maybe T.Text 29 | , goResponseContentLanguage :: Maybe T.Text 30 | , goResponseExpires :: Maybe T.Text 31 | , goResponseCacheControl :: Maybe T.Text 32 | , goResponseContentDisposition :: Maybe T.Text 33 | , goResponseContentEncoding :: Maybe T.Text 34 | , goResponseContentRange :: Maybe (Int,Int) 35 | , goIfMatch :: Maybe T.Text 36 | -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed. 37 | , goIfNoneMatch :: Maybe T.Text 38 | -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified. 39 | } 40 | deriving (Show) 41 | 42 | getObject :: Bucket -> T.Text -> GetObject 43 | getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 44 | 45 | data GetObjectResponse 46 | = GetObjectResponse { 47 | gorMetadata :: ObjectMetadata, 48 | gorResponse :: HTTP.Response (C.ConduitM () B8.ByteString (ResourceT IO) ()) 49 | } 50 | 51 | data GetObjectMemoryResponse 52 | = GetObjectMemoryResponse ObjectMetadata (HTTP.Response L.ByteString) 53 | deriving (Show) 54 | 55 | -- | ServiceConfiguration: 'S3Configuration' 56 | instance SignQuery GetObject where 57 | type ServiceConfiguration GetObject = S3Configuration 58 | signQuery GetObject {..} = s3SignQuery S3Query { 59 | s3QMethod = Get 60 | , s3QBucket = Just $ T.encodeUtf8 goBucket 61 | , s3QObject = Just $ T.encodeUtf8 goObjectName 62 | , s3QSubresources = HTTP.toQuery [ 63 | ("versionId" :: B8.ByteString,) <$> goVersionId 64 | , ("response-content-type" :: B8.ByteString,) <$> goResponseContentType 65 | , ("response-content-language",) <$> goResponseContentLanguage 66 | , ("response-expires",) <$> goResponseExpires 67 | , ("response-cache-control",) <$> goResponseCacheControl 68 | , ("response-content-disposition",) <$> goResponseContentDisposition 69 | , ("response-content-encoding",) <$> goResponseContentEncoding 70 | ] 71 | , s3QQuery = [] 72 | , s3QContentType = Nothing 73 | , s3QContentMd5 = Nothing 74 | , s3QAmzHeaders = [] 75 | , s3QOtherHeaders = catMaybes [ 76 | decodeRange <$> goResponseContentRange 77 | , ("if-match",) . T.encodeUtf8 <$> goIfMatch 78 | , ("if-none-match",) . T.encodeUtf8 <$> goIfNoneMatch 79 | ] 80 | , s3QRequestBody = Nothing 81 | } 82 | where decodeRange (pos,len) = ("range",B8.concat $ ["bytes=", B8.pack (show pos), "-", B8.pack (show len)]) 83 | 84 | instance ResponseConsumer GetObject GetObjectResponse where 85 | type ResponseMetadata GetObjectResponse = S3Metadata 86 | responseConsumer httpReq GetObject{} metadata resp 87 | | status == HTTP.status200 = do 88 | rsp <- s3BinaryResponseConsumer return metadata resp 89 | om <- parseObjectMetadata (HTTP.responseHeaders resp) 90 | return $ GetObjectResponse om rsp 91 | | otherwise = throwStatusCodeException httpReq resp 92 | where 93 | status = HTTP.responseStatus resp 94 | 95 | instance Transaction GetObject GetObjectResponse 96 | 97 | instance AsMemoryResponse GetObjectResponse where 98 | type MemoryResponse GetObjectResponse = GetObjectMemoryResponse 99 | loadToMemory (GetObjectResponse om x) = do 100 | bss <- C.runConduit $ HTTP.responseBody x .| CL.consume 101 | return $ GetObjectMemoryResponse om x 102 | { HTTP.responseBody = L.fromChunks bss 103 | } 104 | -------------------------------------------------------------------------------- /Aws/S3/Commands/GetService.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Aws.S3.Commands.GetService 3 | where 4 | 5 | import Aws.Core 6 | import Aws.S3.Core 7 | import Data.Maybe 8 | import Data.Time.Format 9 | #if !MIN_VERSION_time(1,5,0) 10 | import System.Locale 11 | #endif 12 | import Text.XML.Cursor (($/), ($//), (&|)) 13 | import qualified Data.Text as T 14 | import qualified Text.XML.Cursor as Cu 15 | 16 | data GetService = GetService deriving (Show) 17 | 18 | data GetServiceResponse 19 | = GetServiceResponse { 20 | gsrOwner :: UserInfo 21 | , gsrBuckets :: [BucketInfo] 22 | } 23 | deriving (Show) 24 | 25 | instance ResponseConsumer r GetServiceResponse where 26 | type ResponseMetadata GetServiceResponse = S3Metadata 27 | 28 | responseConsumer _ _ = s3XmlResponseConsumer parse 29 | where 30 | parse el = do 31 | owner <- forceM "Missing Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo 32 | buckets <- sequence $ el $// Cu.laxElement "Bucket" &| parseBucket 33 | return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets } 34 | 35 | parseBucket el = do 36 | name <- force "Missing owner Name" $ el $/ elContent "Name" 37 | creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack 38 | creationDate <- force "Invalid CreationDate" . maybeToList $ parseTimeM True defaultTimeLocale iso8601UtcDate creationDateString 39 | return BucketInfo { bucketName = name, bucketCreationDate = creationDate } 40 | 41 | -- | ServiceConfiguration: 'S3Configuration' 42 | instance SignQuery GetService where 43 | type ServiceConfiguration GetService = S3Configuration 44 | signQuery GetService = s3SignQuery S3Query { 45 | s3QMethod = Get 46 | , s3QBucket = Nothing 47 | , s3QObject = Nothing 48 | , s3QSubresources = [] 49 | , s3QQuery = [] 50 | , s3QContentType = Nothing 51 | , s3QContentMd5 = Nothing 52 | , s3QAmzHeaders = [] 53 | , s3QOtherHeaders = [] 54 | , s3QRequestBody = Nothing 55 | } 56 | 57 | instance Transaction GetService GetServiceResponse 58 | 59 | instance AsMemoryResponse GetServiceResponse where 60 | type MemoryResponse GetServiceResponse = GetServiceResponse 61 | loadToMemory = return 62 | -------------------------------------------------------------------------------- /Aws/S3/Commands/HeadObject.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.HeadObject 2 | where 3 | 4 | import Aws.Core 5 | import Aws.S3.Core 6 | import Control.Applicative 7 | import Data.ByteString.Char8 ({- IsString -}) 8 | import qualified Data.ByteString.Char8 as B8 9 | import Data.Maybe 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Encoding as T 12 | import Prelude 13 | import qualified Network.HTTP.Conduit as HTTP 14 | import qualified Network.HTTP.Types as HTTP 15 | 16 | data HeadObject 17 | = HeadObject { 18 | hoBucket :: Bucket 19 | , hoObjectName :: Object 20 | , hoVersionId :: Maybe T.Text 21 | , hoIfMatch :: Maybe T.Text 22 | -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed. 23 | , hoIfNoneMatch :: Maybe T.Text 24 | -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified. 25 | } 26 | deriving (Show) 27 | 28 | headObject :: Bucket -> T.Text -> HeadObject 29 | headObject b o = HeadObject b o Nothing Nothing Nothing 30 | 31 | data HeadObjectResponse 32 | = HeadObjectResponse { 33 | horMetadata :: Maybe ObjectMetadata 34 | } deriving (Show) 35 | 36 | data HeadObjectMemoryResponse 37 | = HeadObjectMemoryResponse (Maybe ObjectMetadata) 38 | deriving (Show) 39 | 40 | -- | ServiceConfiguration: 'S3Configuration' 41 | instance SignQuery HeadObject where 42 | type ServiceConfiguration HeadObject = S3Configuration 43 | signQuery HeadObject {..} = s3SignQuery S3Query { 44 | s3QMethod = Head 45 | , s3QBucket = Just $ T.encodeUtf8 hoBucket 46 | , s3QObject = Just $ T.encodeUtf8 hoObjectName 47 | , s3QSubresources = HTTP.toQuery [ 48 | ("versionId" :: B8.ByteString,) <$> hoVersionId 49 | ] 50 | , s3QQuery = [] 51 | , s3QContentType = Nothing 52 | , s3QContentMd5 = Nothing 53 | , s3QAmzHeaders = [] 54 | , s3QOtherHeaders = catMaybes [ 55 | ("if-match",) . T.encodeUtf8 <$> hoIfMatch 56 | , ("if-none-match",) . T.encodeUtf8 <$> hoIfNoneMatch 57 | ] 58 | , s3QRequestBody = Nothing 59 | } 60 | 61 | instance ResponseConsumer HeadObject HeadObjectResponse where 62 | type ResponseMetadata HeadObjectResponse = S3Metadata 63 | responseConsumer httpReq HeadObject{} _ resp 64 | | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers 65 | | status == HTTP.status404 = return $ HeadObjectResponse Nothing 66 | | otherwise = throwStatusCodeException httpReq resp 67 | where 68 | status = HTTP.responseStatus resp 69 | headers = HTTP.responseHeaders resp 70 | 71 | instance Transaction HeadObject HeadObjectResponse 72 | 73 | instance AsMemoryResponse HeadObjectResponse where 74 | type MemoryResponse HeadObjectResponse = HeadObjectMemoryResponse 75 | loadToMemory (HeadObjectResponse om) = return (HeadObjectMemoryResponse om) 76 | -------------------------------------------------------------------------------- /Aws/S3/Commands/PutBucket.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.PutBucket where 2 | 3 | import Aws.Core 4 | import Aws.S3.Core 5 | import Control.Monad 6 | import Data.Maybe 7 | import qualified Data.Map as M 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as T 10 | import qualified Network.HTTP.Conduit as HTTP 11 | import qualified Text.XML as XML 12 | 13 | data PutBucket 14 | = PutBucket { 15 | pbBucket :: Bucket 16 | , pbCannedAcl :: Maybe CannedAcl 17 | , pbLocationConstraint :: LocationConstraint 18 | , pbXStorageClass :: Maybe StorageClass -- ^ Google Cloud Storage S3 nonstandard extension 19 | } 20 | deriving (Show) 21 | 22 | putBucket :: Bucket -> PutBucket 23 | putBucket bucket = PutBucket bucket Nothing locationUsClassic Nothing 24 | 25 | data PutBucketResponse 26 | = PutBucketResponse 27 | deriving (Show) 28 | 29 | -- | ServiceConfiguration: 'S3Configuration' 30 | instance SignQuery PutBucket where 31 | type ServiceConfiguration PutBucket = S3Configuration 32 | 33 | signQuery PutBucket{..} = s3SignQuery (S3Query { 34 | s3QMethod = Put 35 | , s3QBucket = Just $ T.encodeUtf8 pbBucket 36 | , s3QSubresources = [] 37 | , s3QQuery = [] 38 | , s3QContentType = Nothing 39 | , s3QContentMd5 = Nothing 40 | , s3QObject = Nothing 41 | , s3QAmzHeaders = case pbCannedAcl of 42 | Nothing -> [] 43 | Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)] 44 | , s3QOtherHeaders = [] 45 | , s3QRequestBody 46 | = guard (not (null elts)) >> 47 | (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def) 48 | XML.Document { 49 | XML.documentPrologue = XML.Prologue [] Nothing [] 50 | , XML.documentRoot = root 51 | , XML.documentEpilogue = [] 52 | } 53 | }) 54 | where root = XML.Element { 55 | XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}CreateBucketConfiguration" 56 | , XML.elementAttributes = M.empty 57 | , XML.elementNodes = elts 58 | } 59 | elts = catMaybes 60 | [ if T.null pbLocationConstraint then Nothing else Just (locationconstraint pbLocationConstraint) 61 | , fmap storageclass pbXStorageClass 62 | ] 63 | locationconstraint c = XML.NodeElement (XML.Element { 64 | XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint" 65 | , XML.elementAttributes = M.empty 66 | , XML.elementNodes = [XML.NodeContent c] 67 | }) 68 | storageclass c = XML.NodeElement (XML.Element { 69 | XML.elementName = "StorageClass" 70 | , XML.elementAttributes = M.empty 71 | , XML.elementNodes = [XML.NodeContent (writeStorageClass c)] 72 | }) 73 | 74 | instance ResponseConsumer r PutBucketResponse where 75 | type ResponseMetadata PutBucketResponse = S3Metadata 76 | 77 | responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketResponse 78 | 79 | instance Transaction PutBucket PutBucketResponse 80 | 81 | instance AsMemoryResponse PutBucketResponse where 82 | type MemoryResponse PutBucketResponse = PutBucketResponse 83 | loadToMemory = return 84 | -------------------------------------------------------------------------------- /Aws/S3/Commands/PutBucketVersioning.hs: -------------------------------------------------------------------------------- 1 | module Aws.S3.Commands.PutBucketVersioning where 2 | 3 | import Aws.Core 4 | import Aws.S3.Core 5 | import Network.HTTP.Types (toQuery) 6 | import qualified Data.Map as M 7 | import qualified Data.Text.Encoding as T 8 | import qualified Network.HTTP.Conduit as HTTP 9 | import qualified Text.XML as XML 10 | import qualified Data.ByteString.Lazy.Char8 as B8 11 | 12 | data VersioningState = VersioningSuspended | VersioningEnabled 13 | deriving (Show) 14 | 15 | -- | Sets the versioning state of an existing bucket. 16 | data PutBucketVersioning 17 | = PutBucketVersioning 18 | { pbvBucket :: Bucket 19 | , pbvVersioningConfiguration :: VersioningState 20 | } 21 | deriving (Show) 22 | 23 | putBucketVersioning :: Bucket -> VersioningState -> PutBucketVersioning 24 | putBucketVersioning = PutBucketVersioning 25 | 26 | data PutBucketVersioningResponse 27 | = PutBucketVersioningResponse 28 | deriving (Show) 29 | 30 | -- | ServiceConfiguration: 'S3Configuration' 31 | instance SignQuery PutBucketVersioning where 32 | type ServiceConfiguration PutBucketVersioning = S3Configuration 33 | 34 | signQuery PutBucketVersioning{..} = s3SignQuery $ S3Query 35 | { s3QMethod = Put 36 | , s3QBucket = Just $ T.encodeUtf8 pbvBucket 37 | , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)] 38 | , s3QQuery = [] 39 | , s3QContentType = Nothing 40 | , s3QContentMd5 = Nothing 41 | , s3QObject = Nothing 42 | , s3QAmzHeaders = [] 43 | , s3QOtherHeaders = [] 44 | , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def) 45 | XML.Document 46 | { XML.documentPrologue = XML.Prologue [] Nothing [] 47 | , XML.documentRoot = XML.Element 48 | { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}VersioningConfiguration" 49 | , XML.elementAttributes = M.empty 50 | , XML.elementNodes = [ XML.NodeElement (XML.Element 51 | { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Status" 52 | , XML.elementAttributes = M.empty 53 | , XML.elementNodes = case pbvVersioningConfiguration of 54 | VersioningSuspended -> [XML.NodeContent "Suspended"] 55 | VersioningEnabled -> [XML.NodeContent "Enabled"] 56 | })] 57 | } 58 | , XML.documentEpilogue = [] 59 | } 60 | } 61 | 62 | instance ResponseConsumer r PutBucketVersioningResponse where 63 | type ResponseMetadata PutBucketVersioningResponse = S3Metadata 64 | 65 | responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketVersioningResponse 66 | 67 | instance Transaction PutBucketVersioning PutBucketVersioningResponse 68 | 69 | instance AsMemoryResponse PutBucketVersioningResponse where 70 | type MemoryResponse PutBucketVersioningResponse = PutBucketVersioningResponse 71 | loadToMemory = return 72 | -------------------------------------------------------------------------------- /Aws/S3/Commands/PutObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Aws.S3.Commands.PutObject 3 | where 4 | 5 | import Aws.Core 6 | import Aws.S3.Core 7 | import Control.Applicative 8 | import Control.Arrow (second) 9 | import qualified Crypto.Hash as CH 10 | import Data.ByteString.Char8 ({- IsString -}) 11 | import Data.Maybe 12 | import qualified Data.ByteString.Char8 as B 13 | import qualified Data.CaseInsensitive as CI 14 | import qualified Data.Text as T 15 | import qualified Data.Text.Encoding as T 16 | import Prelude 17 | import qualified Network.HTTP.Conduit as HTTP 18 | 19 | data PutObject = PutObject { 20 | poObjectName :: T.Text, 21 | poBucket :: Bucket, 22 | poContentType :: Maybe B.ByteString, 23 | poCacheControl :: Maybe T.Text, 24 | poContentDisposition :: Maybe T.Text, 25 | poContentEncoding :: Maybe T.Text, 26 | poContentMD5 :: Maybe (CH.Digest CH.MD5), 27 | poExpires :: Maybe Int, 28 | poAcl :: Maybe CannedAcl, 29 | poStorageClass :: Maybe StorageClass, 30 | poWebsiteRedirectLocation :: Maybe T.Text, 31 | poServerSideEncryption :: Maybe ServerSideEncryption, 32 | poRequestBody :: HTTP.RequestBody, 33 | poMetadata :: [(T.Text,T.Text)], 34 | poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension 35 | poExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10 36 | } 37 | 38 | putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject 39 | putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False 40 | 41 | data PutObjectResponse 42 | = PutObjectResponse 43 | { porVersionId :: Maybe T.Text 44 | , porETag :: T.Text 45 | } 46 | deriving (Show) 47 | 48 | -- | ServiceConfiguration: 'S3Configuration' 49 | instance SignQuery PutObject where 50 | type ServiceConfiguration PutObject = S3Configuration 51 | signQuery PutObject {..} = s3SignQuery S3Query { 52 | s3QMethod = Put 53 | , s3QBucket = Just $ T.encodeUtf8 poBucket 54 | , s3QSubresources = [] 55 | , s3QQuery = [] 56 | , s3QContentType = poContentType 57 | , s3QContentMd5 = poContentMD5 58 | , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [ 59 | ("x-amz-acl",) <$> writeCannedAcl <$> poAcl 60 | , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass 61 | , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation 62 | , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption 63 | , if poAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1") else Nothing 64 | ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata 65 | , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [ 66 | ("Expires",) . T.pack . show <$> poExpires 67 | , ("Cache-Control",) <$> poCacheControl 68 | , ("Content-Disposition",) <$> poContentDisposition 69 | , ("Content-Encoding",) <$> poContentEncoding 70 | , if poExpect100Continue 71 | then Just ("Expect", "100-continue") 72 | else Nothing 73 | ] 74 | , s3QRequestBody = Just poRequestBody 75 | , s3QObject = Just $ T.encodeUtf8 poObjectName 76 | } 77 | 78 | instance ResponseConsumer PutObject PutObjectResponse where 79 | type ResponseMetadata PutObjectResponse = S3Metadata 80 | responseConsumer _ _ = s3ResponseConsumer $ \resp -> do 81 | let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp) 82 | let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp) 83 | return $ PutObjectResponse vid etag 84 | 85 | instance Transaction PutObject PutObjectResponse 86 | 87 | instance AsMemoryResponse PutObjectResponse where 88 | type MemoryResponse PutObjectResponse = PutObjectResponse 89 | loadToMemory = return 90 | -------------------------------------------------------------------------------- /Aws/Ses.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses 2 | ( module Aws.Ses.Commands 3 | , module Aws.Ses.Core 4 | ) where 5 | 6 | import Aws.Ses.Commands 7 | import Aws.Ses.Core 8 | -------------------------------------------------------------------------------- /Aws/Ses/Commands.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands 2 | ( module Aws.Ses.Commands.SendRawEmail 3 | , module Aws.Ses.Commands.ListIdentities 4 | , module Aws.Ses.Commands.VerifyEmailIdentity 5 | , module Aws.Ses.Commands.VerifyDomainIdentity 6 | , module Aws.Ses.Commands.VerifyDomainDkim 7 | , module Aws.Ses.Commands.DeleteIdentity 8 | , module Aws.Ses.Commands.GetIdentityDkimAttributes 9 | , module Aws.Ses.Commands.GetIdentityNotificationAttributes 10 | , module Aws.Ses.Commands.GetIdentityVerificationAttributes 11 | , module Aws.Ses.Commands.SetIdentityNotificationTopic 12 | , module Aws.Ses.Commands.SetIdentityDkimEnabled 13 | , module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled 14 | ) where 15 | 16 | import Aws.Ses.Commands.SendRawEmail 17 | import Aws.Ses.Commands.ListIdentities 18 | import Aws.Ses.Commands.VerifyEmailIdentity 19 | import Aws.Ses.Commands.VerifyDomainIdentity 20 | import Aws.Ses.Commands.VerifyDomainDkim 21 | import Aws.Ses.Commands.DeleteIdentity 22 | import Aws.Ses.Commands.GetIdentityDkimAttributes 23 | import Aws.Ses.Commands.GetIdentityNotificationAttributes 24 | import Aws.Ses.Commands.GetIdentityVerificationAttributes 25 | import Aws.Ses.Commands.SetIdentityNotificationTopic 26 | import Aws.Ses.Commands.SetIdentityDkimEnabled 27 | import Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled 28 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/DeleteIdentity.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.DeleteIdentity 2 | ( DeleteIdentity(..) 3 | , DeleteIdentityResponse(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import Data.Text.Encoding as T (encodeUtf8) 8 | import Data.Typeable 9 | import Aws.Core 10 | import Aws.Ses.Core 11 | 12 | -- | Delete an email address or domain 13 | data DeleteIdentity = DeleteIdentity Text 14 | deriving (Eq, Ord, Show, Typeable) 15 | 16 | -- | ServiceConfiguration: 'SesConfiguration' 17 | instance SignQuery DeleteIdentity where 18 | type ServiceConfiguration DeleteIdentity = SesConfiguration 19 | signQuery (DeleteIdentity identity) = 20 | sesSignQuery [ ("Action", "DeleteIdentity") 21 | , ("Identity", T.encodeUtf8 identity) 22 | ] 23 | 24 | -- | The response sent back by Amazon SES after a 25 | -- 'DeleteIdentity' command. 26 | data DeleteIdentityResponse = DeleteIdentityResponse 27 | deriving (Eq, Ord, Show, Typeable) 28 | 29 | 30 | instance ResponseConsumer DeleteIdentity DeleteIdentityResponse where 31 | type ResponseMetadata DeleteIdentityResponse = SesMetadata 32 | responseConsumer _ _ 33 | = sesResponseConsumer $ \_ -> return DeleteIdentityResponse 34 | 35 | 36 | instance Transaction DeleteIdentity DeleteIdentityResponse where 37 | 38 | instance AsMemoryResponse DeleteIdentityResponse where 39 | type MemoryResponse DeleteIdentityResponse = DeleteIdentityResponse 40 | loadToMemory = return 41 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/GetIdentityDkimAttributes.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.GetIdentityDkimAttributes 2 | ( GetIdentityDkimAttributes(..) 3 | , GetIdentityDkimAttributesResponse(..) 4 | , IdentityDkimAttributes(..) 5 | ) where 6 | 7 | import qualified Data.ByteString.Char8 as BS 8 | import Data.Text (Text) 9 | import Data.Text as T (toCaseFold) 10 | import Data.Text.Encoding as T (encodeUtf8) 11 | import Data.Typeable 12 | import Text.XML.Cursor (laxElement, ($/), ($//), (&/), (&|)) 13 | import Control.Applicative 14 | import Prelude 15 | 16 | import Aws.Core 17 | import Aws.Ses.Core 18 | 19 | -- | Get notification settings for the given identities. 20 | data GetIdentityDkimAttributes = GetIdentityDkimAttributes [Text] 21 | deriving (Eq, Ord, Show, Typeable) 22 | 23 | -- | ServiceConfiguration: 'SesConfiguration' 24 | instance SignQuery GetIdentityDkimAttributes where 25 | type ServiceConfiguration GetIdentityDkimAttributes = SesConfiguration 26 | signQuery (GetIdentityDkimAttributes identities) = 27 | sesSignQuery $ ("Action", "GetIdentityDkimAttributes") 28 | : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities) 29 | where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n) 30 | 31 | 32 | data IdentityDkimAttributes = 33 | IdentityDkimAttributes 34 | { idIdentity :: Text 35 | , idDkimEnabled :: Bool 36 | , idDkimTokens :: [Text] 37 | , idDkimVerirficationStatus :: Text } 38 | deriving (Eq, Ord, Show, Typeable) 39 | 40 | -- | The response sent back by Amazon SES after a 41 | -- 'GetIdentityDkimAttributes' command. 42 | data GetIdentityDkimAttributesResponse = 43 | GetIdentityDkimAttributesResponse [IdentityDkimAttributes] 44 | deriving (Eq, Ord, Show, Typeable) 45 | 46 | instance ResponseConsumer GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where 47 | type ResponseMetadata GetIdentityDkimAttributesResponse = SesMetadata 48 | responseConsumer _ _ = sesResponseConsumer $ \cursor -> do 49 | let buildAttr e = do 50 | idIdentity <- force "Missing Key" $ e $/ elContent "key" 51 | enabled <- force "Missing DkimEnabled" $ e $// elContent "DkimEnabled" 52 | idDkimVerirficationStatus <- force "Missing status" $ 53 | e $// elContent "DkimVerificationStatus" 54 | let idDkimEnabled = T.toCaseFold enabled == T.toCaseFold "true" 55 | idDkimTokens = e $// laxElement "DkimTokens" &/ elContent "member" 56 | return IdentityDkimAttributes{..} 57 | attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr 58 | return $ GetIdentityDkimAttributesResponse attributes 59 | 60 | instance Transaction GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where 61 | 62 | instance AsMemoryResponse GetIdentityDkimAttributesResponse where 63 | type MemoryResponse GetIdentityDkimAttributesResponse = GetIdentityDkimAttributesResponse 64 | loadToMemory = return 65 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/GetIdentityNotificationAttributes.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.GetIdentityNotificationAttributes 2 | ( GetIdentityNotificationAttributes(..) 3 | , GetIdentityNotificationAttributesResponse(..) 4 | , IdentityNotificationAttributes(..) 5 | ) where 6 | 7 | import Data.Text (Text) 8 | import qualified Data.ByteString.Char8 as BS 9 | import Control.Applicative 10 | import Data.Text.Encoding as T (encodeUtf8) 11 | import Data.Text as T (toCaseFold) 12 | import Data.Typeable 13 | import Text.XML.Cursor (($//), ($/), (&|), laxElement) 14 | import Prelude 15 | 16 | import Aws.Core 17 | import Aws.Ses.Core 18 | 19 | -- | Get notification settings for the given identities. 20 | data GetIdentityNotificationAttributes = GetIdentityNotificationAttributes [Text] 21 | deriving (Eq, Ord, Show, Typeable) 22 | 23 | -- | ServiceConfiguration: 'SesConfiguration' 24 | instance SignQuery GetIdentityNotificationAttributes where 25 | type ServiceConfiguration GetIdentityNotificationAttributes = SesConfiguration 26 | signQuery (GetIdentityNotificationAttributes identities) = 27 | sesSignQuery $ ("Action", "GetIdentityNotificationAttributes") 28 | : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities) 29 | where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n) 30 | 31 | data IdentityNotificationAttributes = IdentityNotificationAttributes 32 | { inIdentity :: Text 33 | , inBounceTopic :: Maybe Text 34 | , inComplaintTopic :: Maybe Text 35 | , inForwardingEnabled :: Bool 36 | } 37 | deriving (Eq, Ord, Show, Typeable) 38 | 39 | -- | The response sent back by Amazon SES after a 40 | -- 'GetIdentityNotificationAttributes' command. 41 | data GetIdentityNotificationAttributesResponse = 42 | GetIdentityNotificationAttributesResponse [IdentityNotificationAttributes] 43 | deriving (Eq, Ord, Show, Typeable) 44 | 45 | instance ResponseConsumer GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where 46 | type ResponseMetadata GetIdentityNotificationAttributesResponse = SesMetadata 47 | responseConsumer _ _ = sesResponseConsumer $ \cursor -> do 48 | let buildAttr e = do 49 | inIdentity <- force "Missing Key" $ e $/ elContent "key" 50 | fwdText <- force "Missing ForwardingEnabled" $ e $// elContent "ForwardingEnabled" 51 | let inBounceTopic = headOrNothing (e $// elContent "BounceTopic") 52 | inComplaintTopic = headOrNothing (e $// elContent "ComplaintTopic") 53 | inForwardingEnabled = T.toCaseFold fwdText == T.toCaseFold "true" 54 | return IdentityNotificationAttributes{..} 55 | attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr 56 | return $ GetIdentityNotificationAttributesResponse attributes 57 | where 58 | headOrNothing (x:_) = Just x 59 | headOrNothing _ = Nothing 60 | 61 | instance Transaction GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where 62 | 63 | instance AsMemoryResponse GetIdentityNotificationAttributesResponse where 64 | type MemoryResponse GetIdentityNotificationAttributesResponse = GetIdentityNotificationAttributesResponse 65 | loadToMemory = return 66 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/GetIdentityVerificationAttributes.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.GetIdentityVerificationAttributes 2 | ( GetIdentityVerificationAttributes(..) 3 | , GetIdentityVerificationAttributesResponse(..) 4 | , IdentityVerificationAttributes(..) 5 | ) where 6 | 7 | import Data.Text (Text) 8 | import qualified Data.ByteString.Char8 as BS 9 | import Data.Maybe (listToMaybe) 10 | import Control.Applicative 11 | import Data.Text.Encoding as T (encodeUtf8) 12 | import Data.Typeable 13 | import Text.XML.Cursor (($//), ($/), (&|), laxElement) 14 | import Prelude 15 | 16 | import Aws.Core 17 | import Aws.Ses.Core 18 | 19 | -- | Get verification status for a list of email addresses and/or domains 20 | data GetIdentityVerificationAttributes = GetIdentityVerificationAttributes [Text] 21 | deriving (Eq, Ord, Show, Typeable) 22 | 23 | 24 | -- | ServiceConfiguration: 'SesConfiguration' 25 | instance SignQuery GetIdentityVerificationAttributes where 26 | type ServiceConfiguration GetIdentityVerificationAttributes = SesConfiguration 27 | signQuery (GetIdentityVerificationAttributes identities) = 28 | sesSignQuery $ ("Action", "GetIdentityVerificationAttributes") 29 | : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities) 30 | where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n) 31 | 32 | data IdentityVerificationAttributes = IdentityVerificationAttributes 33 | { ivIdentity :: Text 34 | , ivVerificationStatus :: Text 35 | , ivVerificationToken :: Maybe Text 36 | } 37 | deriving (Eq, Ord, Show, Typeable) 38 | 39 | 40 | -- | The response sent back by Amazon SES after a 41 | -- 'GetIdentityVerificationAttributes' command. 42 | data GetIdentityVerificationAttributesResponse = 43 | GetIdentityVerificationAttributesResponse [IdentityVerificationAttributes] 44 | deriving (Eq, Ord, Show, Typeable) 45 | 46 | 47 | instance ResponseConsumer GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where 48 | type ResponseMetadata GetIdentityVerificationAttributesResponse = SesMetadata 49 | responseConsumer _ _ = 50 | sesResponseConsumer $ \cursor -> do 51 | let buildAttr e = do 52 | ivIdentity <- force "Missing Key" $ e $/ elContent "key" 53 | ivVerificationStatus <- force "Missing Verification Status" $ e 54 | $// elContent "VerificationStatus" 55 | let ivVerificationToken = listToMaybe $ e $// elContent "VerificationToken" 56 | return IdentityVerificationAttributes {..} 57 | attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr 58 | return $ GetIdentityVerificationAttributesResponse attributes 59 | 60 | 61 | instance Transaction GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where 62 | 63 | instance AsMemoryResponse GetIdentityVerificationAttributesResponse where 64 | type MemoryResponse GetIdentityVerificationAttributesResponse = GetIdentityVerificationAttributesResponse 65 | loadToMemory = return 66 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/ListIdentities.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.ListIdentities 2 | ( ListIdentities(..) 3 | , ListIdentitiesResponse(..) 4 | , IdentityType(..) 5 | ) where 6 | 7 | import Data.Text (Text) 8 | import qualified Data.ByteString.Char8 as BS 9 | import Data.Maybe (catMaybes) 10 | import Control.Applicative 11 | import Data.Text.Encoding as T (encodeUtf8) 12 | import Data.Typeable 13 | import Text.XML.Cursor (($//), (&/), laxElement) 14 | import Prelude 15 | 16 | import Aws.Core 17 | import Aws.Ses.Core 18 | 19 | -- | List email addresses and/or domains 20 | data ListIdentities = 21 | ListIdentities 22 | { liIdentityType :: Maybe IdentityType 23 | , liMaxItems :: Maybe Int -- valid range is 1..100 24 | , liNextToken :: Maybe Text 25 | } 26 | deriving (Eq, Ord, Show, Typeable) 27 | 28 | data IdentityType = EmailAddress | Domain 29 | deriving (Eq, Ord, Show, Typeable) 30 | 31 | -- | ServiceConfiguration: 'SesConfiguration' 32 | instance SignQuery ListIdentities where 33 | type ServiceConfiguration ListIdentities = SesConfiguration 34 | signQuery ListIdentities {..} = 35 | let it = case liIdentityType of 36 | Just EmailAddress -> Just "EmailAddress" 37 | Just Domain -> Just "Domain" 38 | Nothing -> Nothing 39 | in sesSignQuery $ ("Action", "ListIdentities") 40 | : catMaybes 41 | [ ("IdentityType",) <$> it 42 | , ("MaxItems",) . BS.pack . show <$> liMaxItems 43 | , ("NextToken",) . T.encodeUtf8 <$> liNextToken 44 | ] 45 | 46 | -- | The response sent back by Amazon SES after a 47 | -- 'ListIdentities' command. 48 | data ListIdentitiesResponse = ListIdentitiesResponse [Text] 49 | deriving (Eq, Ord, Show, Typeable) 50 | 51 | 52 | instance ResponseConsumer ListIdentities ListIdentitiesResponse where 53 | type ResponseMetadata ListIdentitiesResponse = SesMetadata 54 | responseConsumer _ _ = 55 | sesResponseConsumer $ \cursor -> do 56 | let ids = cursor $// laxElement "Identities" &/ elContent "member" 57 | return $ ListIdentitiesResponse ids 58 | 59 | 60 | instance Transaction ListIdentities ListIdentitiesResponse where 61 | 62 | instance AsMemoryResponse ListIdentitiesResponse where 63 | type MemoryResponse ListIdentitiesResponse = ListIdentitiesResponse 64 | loadToMemory = return 65 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/SendRawEmail.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.SendRawEmail 2 | ( SendRawEmail(..) 3 | , SendRawEmailResponse(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import Data.Typeable 8 | import Control.Applicative 9 | import qualified Data.ByteString.Char8 as BS 10 | import Text.XML.Cursor (($//)) 11 | import qualified Data.Text.Encoding as T 12 | import Prelude 13 | 14 | import Aws.Core 15 | import Aws.Ses.Core 16 | 17 | -- | Send a raw e-mail message. 18 | data SendRawEmail = 19 | SendRawEmail 20 | { srmDestinations :: [EmailAddress] 21 | , srmRawMessage :: RawMessage 22 | , srmSource :: Maybe Sender 23 | } 24 | deriving (Eq, Ord, Show, Typeable) 25 | 26 | -- | ServiceConfiguration: 'SesConfiguration' 27 | instance SignQuery SendRawEmail where 28 | type ServiceConfiguration SendRawEmail = SesConfiguration 29 | signQuery SendRawEmail {..} = 30 | sesSignQuery $ ("Action", "SendRawEmail") : 31 | concat [ destinations 32 | , sesAsQuery srmRawMessage 33 | , sesAsQuery srmSource 34 | ] 35 | where 36 | destinations = zip (enumMember <$> ([1..] :: [Int])) 37 | (T.encodeUtf8 <$> srmDestinations) 38 | enumMember = BS.append "Destinations.member." . BS.pack . show 39 | 40 | -- | The response sent back by Amazon SES after a 41 | -- 'SendRawEmail' command. 42 | data SendRawEmailResponse = 43 | SendRawEmailResponse { srmrMessageId :: Text } 44 | deriving (Eq, Ord, Show, Typeable) 45 | 46 | 47 | instance ResponseConsumer SendRawEmail SendRawEmailResponse where 48 | type ResponseMetadata SendRawEmailResponse = SesMetadata 49 | responseConsumer _ _ = 50 | sesResponseConsumer $ \cursor -> do 51 | messageId <- force "MessageId not found" $ cursor $// elContent "MessageId" 52 | return (SendRawEmailResponse messageId) 53 | 54 | 55 | instance Transaction SendRawEmail SendRawEmailResponse where 56 | 57 | instance AsMemoryResponse SendRawEmailResponse where 58 | type MemoryResponse SendRawEmailResponse = SendRawEmailResponse 59 | loadToMemory = return 60 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/SetIdentityDkimEnabled.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.SetIdentityDkimEnabled 2 | ( SetIdentityDkimEnabled(..) 3 | , SetIdentityDkimEnabledResponse(..) 4 | ) where 5 | 6 | import Aws.Core 7 | import Aws.Ses.Core 8 | import Data.Text (Text) 9 | import Data.Text.Encoding as T 10 | import Data.Typeable 11 | 12 | -- | Change whether bounces and complaints for the given identity will be 13 | -- DKIM signed. 14 | data SetIdentityDkimEnabled = SetIdentityDkimEnabled 15 | { sdDkimEnabled :: Bool 16 | , sdIdentity :: Text 17 | } 18 | deriving (Eq, Ord, Show, Typeable) 19 | 20 | -- | ServiceConfiguration: 'SesConfiguration' 21 | instance SignQuery SetIdentityDkimEnabled where 22 | type ServiceConfiguration SetIdentityDkimEnabled = SesConfiguration 23 | signQuery SetIdentityDkimEnabled{..} = 24 | sesSignQuery [ ("Action", "SetIdentityDkimEnabled") 25 | , ("Identity", T.encodeUtf8 sdIdentity) 26 | , ("DkimEnabled", awsBool sdDkimEnabled) 27 | ] 28 | 29 | -- | The response sent back by SES after the 'SetIdentityDkimEnabled' command. 30 | data SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse 31 | deriving (Eq, Ord, Show, Typeable) 32 | 33 | instance ResponseConsumer SetIdentityDkimEnabled SetIdentityDkimEnabledResponse where 34 | type ResponseMetadata SetIdentityDkimEnabledResponse = SesMetadata 35 | responseConsumer _ _ 36 | = sesResponseConsumer $ \_ -> return SetIdentityDkimEnabledResponse 37 | 38 | instance Transaction SetIdentityDkimEnabled SetIdentityDkimEnabledResponse 39 | 40 | instance AsMemoryResponse SetIdentityDkimEnabledResponse where 41 | type MemoryResponse SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse 42 | loadToMemory = return 43 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled 2 | ( SetIdentityFeedbackForwardingEnabled(..) 3 | , SetIdentityFeedbackForwardingEnabledResponse(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import Data.Text.Encoding as T (encodeUtf8) 8 | import Data.Typeable 9 | import Aws.Core 10 | import Aws.Ses.Core 11 | 12 | -- | Change whether bounces and complaints for the given identity will be 13 | -- forwarded as email. 14 | data SetIdentityFeedbackForwardingEnabled = 15 | SetIdentityFeedbackForwardingEnabled 16 | { sffForwardingEnabled :: Bool 17 | , sffIdentity :: Text 18 | } 19 | deriving (Eq, Ord, Show, Typeable) 20 | 21 | -- | ServiceConfiguration: 'SesConfiguration' 22 | instance SignQuery SetIdentityFeedbackForwardingEnabled where 23 | type ServiceConfiguration SetIdentityFeedbackForwardingEnabled = SesConfiguration 24 | signQuery SetIdentityFeedbackForwardingEnabled{..} = 25 | sesSignQuery [ ("Action", "SetIdentityFeedbackForwardingEnabled") 26 | , ("Identity", T.encodeUtf8 sffIdentity) 27 | , ("ForwardingEnabled", awsBool sffForwardingEnabled) 28 | ] 29 | 30 | -- | The response sent back by SES after the 31 | -- 'SetIdentityFeedbackForwardingEnabled' command. 32 | data SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse 33 | deriving (Eq, Ord, Show, Typeable) 34 | 35 | instance ResponseConsumer SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse where 36 | type ResponseMetadata SetIdentityFeedbackForwardingEnabledResponse = SesMetadata 37 | responseConsumer _ _ 38 | = sesResponseConsumer $ \_ -> return SetIdentityFeedbackForwardingEnabledResponse 39 | 40 | instance Transaction SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse 41 | 42 | instance AsMemoryResponse SetIdentityFeedbackForwardingEnabledResponse where 43 | type MemoryResponse SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse 44 | loadToMemory = return 45 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/SetIdentityNotificationTopic.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.SetIdentityNotificationTopic 2 | ( SetIdentityNotificationTopic(..) 3 | , SetIdentityNotificationTopicResponse(..) 4 | , NotificationType(..) 5 | ) where 6 | 7 | import Data.Text (Text) 8 | import Control.Applicative 9 | import Data.Maybe (maybeToList) 10 | import Data.Text.Encoding as T (encodeUtf8) 11 | import Data.Typeable 12 | import Prelude 13 | import Aws.Core 14 | import Aws.Ses.Core 15 | 16 | data NotificationType = Bounce | Complaint 17 | deriving (Eq, Ord, Show, Typeable) 18 | 19 | -- | Change or remove the Amazon SNS notification topic to which notification 20 | -- of the given type are published. 21 | data SetIdentityNotificationTopic = 22 | SetIdentityNotificationTopic 23 | { sntIdentity :: Text 24 | -- ^ The identity for which the SNS topic will be changed. 25 | , sntNotificationType :: NotificationType 26 | -- ^ The type of notifications that will be published to the topic. 27 | , sntSnsTopic :: Maybe Text 28 | -- ^ @Just@ the ARN of the SNS topic or @Nothing@ to unset the topic. 29 | } 30 | deriving (Eq, Ord, Show, Typeable) 31 | 32 | -- | ServiceConfiguration: 'SesConfiguration' 33 | instance SignQuery SetIdentityNotificationTopic where 34 | type ServiceConfiguration SetIdentityNotificationTopic = SesConfiguration 35 | signQuery SetIdentityNotificationTopic{..} = 36 | let notificationType = case sntNotificationType of 37 | Bounce -> "Bounce" 38 | Complaint -> "Complaint" 39 | snsTopic = ("SnsTopic",) . T.encodeUtf8 <$> sntSnsTopic 40 | in sesSignQuery $ [ ("Action", "SetIdentityNotificationTopic") 41 | , ("Identity", T.encodeUtf8 sntIdentity) 42 | , ("NotificationType", notificationType) 43 | ] ++ maybeToList snsTopic 44 | 45 | -- | The response sent back by SES after the 'SetIdentityNotificationTopic' 46 | -- command. 47 | data SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse 48 | deriving (Eq, Ord, Show, Typeable) 49 | 50 | instance ResponseConsumer SetIdentityNotificationTopic SetIdentityNotificationTopicResponse where 51 | type ResponseMetadata SetIdentityNotificationTopicResponse = SesMetadata 52 | responseConsumer _ _ 53 | = sesResponseConsumer $ \_ -> return SetIdentityNotificationTopicResponse 54 | 55 | instance Transaction SetIdentityNotificationTopic SetIdentityNotificationTopicResponse 56 | 57 | instance AsMemoryResponse SetIdentityNotificationTopicResponse where 58 | type MemoryResponse SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse 59 | loadToMemory = return 60 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/VerifyDomainDkim.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.VerifyDomainDkim 2 | ( VerifyDomainDkim(..) 3 | , VerifyDomainDkimResponse(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import Data.Text.Encoding as T (encodeUtf8) 8 | import Data.Typeable 9 | import Aws.Core 10 | import Aws.Ses.Core 11 | import Text.XML.Cursor (($//), laxElement, (&/)) 12 | 13 | -- | Verify ownership of a domain. 14 | data VerifyDomainDkim = VerifyDomainDkim Text 15 | deriving (Eq, Ord, Show, Typeable) 16 | 17 | -- | ServiceConfiguration: 'SesConfiguration' 18 | instance SignQuery VerifyDomainDkim where 19 | type ServiceConfiguration VerifyDomainDkim = SesConfiguration 20 | signQuery (VerifyDomainDkim domain) = 21 | sesSignQuery [ ("Action", "VerifyDomainDkim") 22 | , ("Domain", T.encodeUtf8 domain) 23 | ] 24 | 25 | -- | The response sent back by Amazon SES after a 'VerifyDomainDkim' command. 26 | data VerifyDomainDkimResponse = VerifyDomainDkimResponse [Text] 27 | deriving (Eq, Ord, Show, Typeable) 28 | 29 | instance ResponseConsumer VerifyDomainDkim VerifyDomainDkimResponse where 30 | type ResponseMetadata VerifyDomainDkimResponse = SesMetadata 31 | responseConsumer _ _ = 32 | sesResponseConsumer $ \cursor -> do 33 | let tokens = cursor $// laxElement "DkimTokens" &/ elContent "member" 34 | return (VerifyDomainDkimResponse tokens) 35 | 36 | instance Transaction VerifyDomainDkim VerifyDomainDkimResponse where 37 | 38 | instance AsMemoryResponse VerifyDomainDkimResponse where 39 | type MemoryResponse VerifyDomainDkimResponse = VerifyDomainDkimResponse 40 | loadToMemory = return 41 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/VerifyDomainIdentity.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.VerifyDomainIdentity 2 | ( VerifyDomainIdentity(..) 3 | , VerifyDomainIdentityResponse(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import Data.Text.Encoding as T (encodeUtf8) 8 | import Data.Typeable 9 | import Aws.Core 10 | import Aws.Ses.Core 11 | import Text.XML.Cursor (($//)) 12 | 13 | -- | Verify ownership of a domain. 14 | data VerifyDomainIdentity = VerifyDomainIdentity Text 15 | deriving (Eq, Ord, Show, Typeable) 16 | 17 | -- | ServiceConfiguration: 'SesConfiguration' 18 | instance SignQuery VerifyDomainIdentity where 19 | type ServiceConfiguration VerifyDomainIdentity = SesConfiguration 20 | signQuery (VerifyDomainIdentity domain) = 21 | sesSignQuery [ ("Action", "VerifyDomainIdentity") 22 | , ("Domain", T.encodeUtf8 domain) 23 | ] 24 | 25 | -- | The response sent back by Amazon SES after a 26 | -- 'VerifyDomainIdentity' command. 27 | data VerifyDomainIdentityResponse = VerifyDomainIdentityResponse Text 28 | deriving (Eq, Ord, Show, Typeable) 29 | 30 | instance ResponseConsumer VerifyDomainIdentity VerifyDomainIdentityResponse where 31 | type ResponseMetadata VerifyDomainIdentityResponse = SesMetadata 32 | responseConsumer _ _ = 33 | sesResponseConsumer $ \cursor -> do 34 | token <- force "Verification token not found" $ cursor $// elContent "VerificationToken" 35 | return (VerifyDomainIdentityResponse token) 36 | 37 | instance Transaction VerifyDomainIdentity VerifyDomainIdentityResponse where 38 | 39 | instance AsMemoryResponse VerifyDomainIdentityResponse where 40 | type MemoryResponse VerifyDomainIdentityResponse = VerifyDomainIdentityResponse 41 | loadToMemory = return 42 | -------------------------------------------------------------------------------- /Aws/Ses/Commands/VerifyEmailIdentity.hs: -------------------------------------------------------------------------------- 1 | module Aws.Ses.Commands.VerifyEmailIdentity 2 | ( VerifyEmailIdentity(..) 3 | , VerifyEmailIdentityResponse(..) 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import Data.Text.Encoding as T (encodeUtf8) 8 | import Data.Typeable 9 | import Aws.Core 10 | import Aws.Ses.Core 11 | 12 | -- | List email addresses and/or domains 13 | data VerifyEmailIdentity = VerifyEmailIdentity Text 14 | deriving (Eq, Ord, Show, Typeable) 15 | 16 | -- | ServiceConfiguration: 'SesConfiguration' 17 | instance SignQuery VerifyEmailIdentity where 18 | type ServiceConfiguration VerifyEmailIdentity = SesConfiguration 19 | signQuery (VerifyEmailIdentity address) = 20 | sesSignQuery [ ("Action", "VerifyEmailIdentity") 21 | , ("EmailAddress", T.encodeUtf8 address) 22 | ] 23 | 24 | -- | The response sent back by Amazon SES after a 25 | -- 'VerifyEmailIdentity' command. 26 | data VerifyEmailIdentityResponse = VerifyEmailIdentityResponse 27 | deriving (Eq, Ord, Show, Typeable) 28 | 29 | 30 | instance ResponseConsumer VerifyEmailIdentity VerifyEmailIdentityResponse where 31 | type ResponseMetadata VerifyEmailIdentityResponse = SesMetadata 32 | responseConsumer _ _ 33 | = sesResponseConsumer $ \_ -> return VerifyEmailIdentityResponse 34 | 35 | 36 | instance Transaction VerifyEmailIdentity VerifyEmailIdentityResponse where 37 | 38 | instance AsMemoryResponse VerifyEmailIdentityResponse where 39 | type MemoryResponse VerifyEmailIdentityResponse = VerifyEmailIdentityResponse 40 | loadToMemory = return 41 | -------------------------------------------------------------------------------- /Aws/SimpleDb.hs: -------------------------------------------------------------------------------- 1 | module Aws.SimpleDb 2 | ( 3 | module Aws.SimpleDb.Commands 4 | , module Aws.SimpleDb.Core 5 | ) 6 | where 7 | 8 | import Aws.SimpleDb.Commands 9 | import Aws.SimpleDb.Core 10 | -------------------------------------------------------------------------------- /Aws/SimpleDb/Commands.hs: -------------------------------------------------------------------------------- 1 | module Aws.SimpleDb.Commands 2 | ( 3 | module Aws.SimpleDb.Commands.Attributes 4 | , module Aws.SimpleDb.Commands.Domain 5 | , module Aws.SimpleDb.Commands.Select 6 | ) 7 | where 8 | 9 | import Aws.SimpleDb.Commands.Attributes 10 | import Aws.SimpleDb.Commands.Domain 11 | import Aws.SimpleDb.Commands.Select 12 | -------------------------------------------------------------------------------- /Aws/SimpleDb/Commands/Select.hs: -------------------------------------------------------------------------------- 1 | module Aws.SimpleDb.Commands.Select 2 | where 3 | 4 | import Aws.Core 5 | import Aws.SimpleDb.Core 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.Maybe 9 | import Prelude 10 | import Text.XML.Cursor (($//), (&|)) 11 | import qualified Data.Text as T 12 | import qualified Data.Text.Encoding as T 13 | import qualified Text.XML.Cursor as Cu 14 | 15 | data Select 16 | = Select { 17 | sSelectExpression :: T.Text 18 | , sConsistentRead :: Bool 19 | , sNextToken :: Maybe T.Text 20 | } 21 | deriving (Show) 22 | 23 | data SelectResponse 24 | = SelectResponse { 25 | srItems :: [Item [Attribute T.Text]] 26 | , srNextToken :: Maybe T.Text 27 | } 28 | deriving (Show) 29 | 30 | select :: T.Text -> Select 31 | select expr = Select { sSelectExpression = expr, sConsistentRead = False, sNextToken = Nothing } 32 | 33 | -- | ServiceConfiguration: 'SdbConfiguration' 34 | instance SignQuery Select where 35 | type ServiceConfiguration Select = SdbConfiguration 36 | signQuery Select{..} 37 | = sdbSignQuery . catMaybes $ 38 | [ Just ("Action", "Select") 39 | , Just ("SelectExpression", T.encodeUtf8 sSelectExpression) 40 | , ("ConsistentRead", awsTrue) <$ guard sConsistentRead 41 | , (("NextToken",) . T.encodeUtf8) <$> sNextToken 42 | ] 43 | 44 | instance ResponseConsumer r SelectResponse where 45 | type ResponseMetadata SelectResponse = SdbMetadata 46 | responseConsumer _ _ = sdbResponseConsumer parse 47 | where parse cursor = do 48 | sdbCheckResponseType () "SelectResponse" cursor 49 | items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem 50 | let nextToken = listToMaybe $ cursor $// elContent "NextToken" 51 | return $ SelectResponse items nextToken 52 | 53 | instance Transaction Select SelectResponse 54 | 55 | instance AsMemoryResponse SelectResponse where 56 | type MemoryResponse SelectResponse = SelectResponse 57 | loadToMemory = return 58 | 59 | instance ListResponse SelectResponse (Item [Attribute T.Text]) where 60 | listResponse = srItems 61 | 62 | instance IteratedTransaction Select SelectResponse where 63 | nextIteratedRequest req SelectResponse{srNextToken=nt} = req{sNextToken=nt} <$ nt 64 | -- combineIteratedResponse (SelectResponse s1 _) (SelectResponse s2 nt2) = SelectResponse (s1 ++ s2) nt2 65 | -------------------------------------------------------------------------------- /Aws/Sqs.hs: -------------------------------------------------------------------------------- 1 | module Aws.Sqs 2 | ( 3 | module Aws.Sqs.Commands 4 | , module Aws.Sqs.Core 5 | ) 6 | where 7 | 8 | import Aws.Sqs.Commands 9 | import Aws.Sqs.Core 10 | -------------------------------------------------------------------------------- /Aws/Sqs/Commands.hs: -------------------------------------------------------------------------------- 1 | module Aws.Sqs.Commands ( 2 | module Aws.Sqs.Commands.Message, 3 | module Aws.Sqs.Commands.Permission, 4 | module Aws.Sqs.Commands.Queue, 5 | module Aws.Sqs.Commands.QueueAttributes 6 | ) where 7 | 8 | import Aws.Sqs.Commands.Message 9 | import Aws.Sqs.Commands.Permission 10 | import Aws.Sqs.Commands.Queue 11 | import Aws.Sqs.Commands.QueueAttributes 12 | -------------------------------------------------------------------------------- /Aws/Sqs/Commands/Permission.hs: -------------------------------------------------------------------------------- 1 | 2 | module Aws.Sqs.Commands.Permission where 3 | 4 | import Aws.Core 5 | import Aws.Sqs.Core 6 | import qualified Data.ByteString.Char8 as B 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as TE 9 | import qualified Network.HTTP.Types as HTTP 10 | 11 | data AddPermission = AddPermission { 12 | apLabel :: T.Text, 13 | apPermissions :: [(T.Text,SqsPermission)], 14 | apQueueName :: QueueName 15 | } deriving (Show) 16 | 17 | data AddPermissionResponse = AddPermissionResponse 18 | deriving (Show) 19 | 20 | 21 | formatPermissions :: [(T.Text,SqsPermission)] -> [HTTP.QueryItem] 22 | formatPermissions perms = 23 | concat $ zipWith(\ x y -> [(B.pack $ "AwsAccountId." ++ show y, Just $ B.pack $ T.unpack $ fst x), 24 | (B.pack $ "ActionName." ++ show y, Just $ B.pack $ T.unpack $ printPermission $ snd x)]) perms [1 :: Integer ..] 25 | 26 | instance ResponseConsumer r AddPermissionResponse where 27 | type ResponseMetadata AddPermissionResponse = SqsMetadata 28 | responseConsumer _ _ = sqsXmlResponseConsumer parse 29 | where 30 | parse _ = do 31 | return AddPermissionResponse {} 32 | 33 | -- | ServiceConfiguration: 'SqsConfiguration' 34 | instance SignQuery AddPermission where 35 | type ServiceConfiguration AddPermission = SqsConfiguration 36 | signQuery AddPermission {..} = sqsSignQuery SqsQuery { 37 | sqsQueueName = Just apQueueName, 38 | sqsQuery = [("Action", Just "AddPermission"), 39 | ("QueueName", Just $ B.pack $ T.unpack $ printQueueName apQueueName), 40 | ("Label", Just $ B.pack $ T.unpack apLabel)] ++ formatPermissions apPermissions} 41 | 42 | instance Transaction AddPermission AddPermissionResponse 43 | 44 | instance AsMemoryResponse AddPermissionResponse where 45 | type MemoryResponse AddPermissionResponse = AddPermissionResponse 46 | loadToMemory = return 47 | 48 | data RemovePermission = RemovePermission { 49 | rpLabel :: T.Text, 50 | rpQueueName :: QueueName 51 | } deriving (Show) 52 | 53 | data RemovePermissionResponse = RemovePermissionResponse 54 | deriving (Show) 55 | 56 | instance ResponseConsumer r RemovePermissionResponse where 57 | type ResponseMetadata RemovePermissionResponse = SqsMetadata 58 | responseConsumer _ _ = sqsXmlResponseConsumer parse 59 | where 60 | parse _ = do 61 | return RemovePermissionResponse {} 62 | 63 | -- | ServiceConfiguration: 'SqsConfiguration' 64 | instance SignQuery RemovePermission where 65 | type ServiceConfiguration RemovePermission = SqsConfiguration 66 | signQuery RemovePermission {..} = sqsSignQuery SqsQuery { 67 | sqsQueueName = Just rpQueueName, 68 | sqsQuery = [("Action", Just "RemovePermission"), 69 | ("Label", Just $ TE.encodeUtf8 rpLabel )]} 70 | 71 | instance Transaction RemovePermission RemovePermissionResponse 72 | 73 | instance AsMemoryResponse RemovePermissionResponse where 74 | type MemoryResponse RemovePermissionResponse = RemovePermissionResponse 75 | loadToMemory = return 76 | -------------------------------------------------------------------------------- /Aws/Sqs/Commands/Queue.hs: -------------------------------------------------------------------------------- 1 | 2 | module Aws.Sqs.Commands.Queue where 3 | 4 | import Aws.Core 5 | import Aws.Sqs.Core 6 | import Control.Applicative 7 | import Data.Maybe 8 | import Prelude 9 | import Text.XML.Cursor (($//), (&/)) 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Encoding as TE 12 | import qualified Text.XML.Cursor as Cu 13 | import qualified Data.ByteString.Char8 as B 14 | 15 | data CreateQueue = CreateQueue { 16 | cqDefaultVisibilityTimeout :: Maybe Int, 17 | cqQueueName :: T.Text 18 | } deriving (Show) 19 | 20 | data CreateQueueResponse = CreateQueueResponse { 21 | cqrQueueUrl :: T.Text 22 | } deriving (Show) 23 | 24 | 25 | instance ResponseConsumer r CreateQueueResponse where 26 | type ResponseMetadata CreateQueueResponse = SqsMetadata 27 | responseConsumer _ _ = sqsXmlResponseConsumer parse 28 | where 29 | parse el = do 30 | url <- force "Missing Queue Url" $ el $// Cu.laxElement "QueueUrl" &/ Cu.content 31 | return CreateQueueResponse{ cqrQueueUrl = url} 32 | 33 | -- | ServiceConfiguration: 'SqsConfiguration' 34 | instance SignQuery CreateQueue where 35 | type ServiceConfiguration CreateQueue = SqsConfiguration 36 | signQuery CreateQueue {..} = sqsSignQuery SqsQuery { 37 | sqsQueueName = Nothing, 38 | sqsQuery = [("Action", Just "CreateQueue"), 39 | ("QueueName", Just $ TE.encodeUtf8 cqQueueName)] ++ 40 | catMaybes [("DefaultVisibilityTimeout",) <$> case cqDefaultVisibilityTimeout of 41 | Just x -> Just $ Just $ B.pack $ show x 42 | Nothing -> Nothing]} 43 | 44 | instance Transaction CreateQueue CreateQueueResponse 45 | 46 | instance AsMemoryResponse CreateQueueResponse where 47 | type MemoryResponse CreateQueueResponse = CreateQueueResponse 48 | loadToMemory = return 49 | 50 | data DeleteQueue = DeleteQueue { 51 | dqQueueName :: QueueName 52 | } deriving (Show) 53 | 54 | data DeleteQueueResponse = DeleteQueueResponse 55 | deriving (Show) 56 | 57 | instance ResponseConsumer r DeleteQueueResponse where 58 | type ResponseMetadata DeleteQueueResponse = SqsMetadata 59 | responseConsumer _ _ = sqsXmlResponseConsumer parse 60 | where 61 | parse _ = do return DeleteQueueResponse{} 62 | 63 | -- | ServiceConfiguration: 'SqsConfiguration' 64 | instance SignQuery DeleteQueue where 65 | type ServiceConfiguration DeleteQueue = SqsConfiguration 66 | signQuery DeleteQueue {..} = sqsSignQuery SqsQuery { 67 | sqsQueueName = Just dqQueueName, 68 | sqsQuery = [("Action", Just "DeleteQueue")]} 69 | 70 | instance Transaction DeleteQueue DeleteQueueResponse 71 | 72 | instance AsMemoryResponse DeleteQueueResponse where 73 | type MemoryResponse DeleteQueueResponse = DeleteQueueResponse 74 | loadToMemory = return 75 | 76 | data ListQueues = ListQueues { 77 | lqQueueNamePrefix :: Maybe T.Text 78 | } deriving (Show) 79 | 80 | data ListQueuesResponse = ListQueuesResponse { 81 | lqrQueueUrls :: [T.Text] 82 | } deriving (Show) 83 | 84 | instance ResponseConsumer r ListQueuesResponse where 85 | type ResponseMetadata ListQueuesResponse = SqsMetadata 86 | responseConsumer _ _ = sqsXmlResponseConsumer parse 87 | where 88 | parse el = do 89 | let queues = el $// Cu.laxElement "QueueUrl" &/ Cu.content 90 | return ListQueuesResponse { lqrQueueUrls = queues } 91 | 92 | -- | ServiceConfiguration: 'SqsConfiguration' 93 | instance SignQuery ListQueues where 94 | type ServiceConfiguration ListQueues = SqsConfiguration 95 | signQuery ListQueues{..} = sqsSignQuery SqsQuery { 96 | sqsQueueName = Nothing, 97 | sqsQuery = [("Action", Just "ListQueues")] ++ catMaybes [ 98 | ("QueueNamePrefix",) <$> case lqQueueNamePrefix of 99 | Just x -> Just $ Just $ TE.encodeUtf8 x 100 | Nothing -> Nothing]} 101 | 102 | instance Transaction ListQueues ListQueuesResponse 103 | 104 | instance AsMemoryResponse ListQueuesResponse where 105 | type MemoryResponse ListQueuesResponse = ListQueuesResponse 106 | loadToMemory = return 107 | -------------------------------------------------------------------------------- /Aws/Sqs/Commands/QueueAttributes.hs: -------------------------------------------------------------------------------- 1 | 2 | module Aws.Sqs.Commands.QueueAttributes where 3 | 4 | import Aws.Core 5 | import Aws.Sqs.Core 6 | import Text.XML.Cursor (($/), ($//), (&/), (&|)) 7 | import qualified Data.ByteString.Char8 as B 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as TE 10 | import qualified Text.XML.Cursor as Cu 11 | 12 | data GetQueueAttributes = GetQueueAttributes { 13 | gqaQueueName :: QueueName, 14 | gqaAttributes :: [QueueAttribute] 15 | }deriving (Show) 16 | 17 | data GetQueueAttributesResponse = GetQueueAttributesResponse{ 18 | gqarAttributes :: [(QueueAttribute,T.Text)] 19 | } deriving (Show) 20 | 21 | parseAttributes :: Cu.Cursor -> [(QueueAttribute, T.Text)] 22 | parseAttributes el = do 23 | name <- force "Missing Name" $ el $/ Cu.laxElement "Name" &/ Cu.content 24 | value <- force "Missing Value" $ el $/ Cu.laxElement "Value" &/ Cu.content 25 | parsedName <- parseQueueAttribute name 26 | return (parsedName, value) 27 | 28 | instance ResponseConsumer r GetQueueAttributesResponse where 29 | type ResponseMetadata GetQueueAttributesResponse = SqsMetadata 30 | responseConsumer _ _ = sqsXmlResponseConsumer parse 31 | where 32 | parse el = do 33 | let attributes = concat $ el $// Cu.laxElement "Attribute" &| parseAttributes 34 | return GetQueueAttributesResponse{ gqarAttributes = attributes } 35 | 36 | formatAttributes :: [QueueAttribute] -> [(B.ByteString, Maybe B.ByteString)] 37 | formatAttributes attrs = 38 | case length attrs of 39 | 0 -> undefined 40 | 1 -> [("AttributeName", Just $ B.pack $ T.unpack $ printQueueAttribute $ attrs !! 0)] 41 | _ -> zipWith (\ x y -> ((B.concat ["AttributeName.", B.pack $ show $ y]), Just $ B.pack $ T.unpack $ printQueueAttribute x) ) attrs [1 :: Integer ..] 42 | 43 | -- | ServiceConfiguration: 'SqsConfiguration' 44 | instance SignQuery GetQueueAttributes where 45 | type ServiceConfiguration GetQueueAttributes = SqsConfiguration 46 | signQuery GetQueueAttributes{..} = sqsSignQuery SqsQuery { 47 | sqsQueueName = Just gqaQueueName, 48 | sqsQuery = [("Action", Just "GetQueueAttributes")] ++ (formatAttributes gqaAttributes)} 49 | 50 | instance Transaction GetQueueAttributes GetQueueAttributesResponse 51 | 52 | instance AsMemoryResponse GetQueueAttributesResponse where 53 | type MemoryResponse GetQueueAttributesResponse = GetQueueAttributesResponse 54 | loadToMemory = return 55 | 56 | data SetQueueAttributes = SetQueueAttributes{ 57 | sqaAttribute :: QueueAttribute, 58 | sqaValue :: T.Text, 59 | sqaQueueName :: QueueName 60 | }deriving (Show) 61 | 62 | data SetQueueAttributesResponse = SetQueueAttributesResponse{ 63 | } deriving (Show) 64 | 65 | instance ResponseConsumer r SetQueueAttributesResponse where 66 | type ResponseMetadata SetQueueAttributesResponse = SqsMetadata 67 | responseConsumer _ _ = sqsXmlResponseConsumer parse 68 | where 69 | parse _ = do 70 | return SetQueueAttributesResponse {} 71 | 72 | -- | ServiceConfiguration: 'SqsConfiguration' 73 | instance SignQuery SetQueueAttributes where 74 | type ServiceConfiguration SetQueueAttributes = SqsConfiguration 75 | signQuery SetQueueAttributes {..} = sqsSignQuery SqsQuery { 76 | sqsQueueName = Just sqaQueueName, 77 | sqsQuery = [("Action", Just "SetQueueAttributes"), 78 | ("Attribute.Name", Just $ TE.encodeUtf8 $ printQueueAttribute sqaAttribute), 79 | ("Attribute.Value", Just $ TE.encodeUtf8 sqaValue)]} 80 | 81 | instance Transaction SetQueueAttributes SetQueueAttributesResponse 82 | 83 | instance AsMemoryResponse SetQueueAttributesResponse where 84 | type MemoryResponse SetQueueAttributesResponse = SetQueueAttributesResponse 85 | loadToMemory = return 86 | -------------------------------------------------------------------------------- /Examples/DynamoDb.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | module Main where 6 | 7 | ------------------------------------------------------------------------------- 8 | import Aws 9 | import Aws.DynamoDb.Commands 10 | import Aws.DynamoDb.Core 11 | import Control.Concurrent 12 | import Control.Monad 13 | import Control.Monad.Catch 14 | import Control.Monad.Trans.Resource 15 | import Control.Applicative 16 | import Data.Conduit 17 | import Data.Maybe 18 | import qualified Data.Conduit.List as C 19 | import qualified Data.Text as T 20 | import Network.HTTP.Conduit (newManager, tlsManagerSettings) 21 | ------------------------------------------------------------------------------- 22 | 23 | createTableAndWait :: IO () 24 | createTableAndWait = do 25 | let req0 = createTable "devel-1" 26 | [AttributeDefinition "name" AttrString] 27 | (HashOnly "name") 28 | (ProvisionedThroughput 1 1) 29 | resp0 <- runCommand req0 30 | print resp0 31 | 32 | print "Waiting for table to be created" 33 | threadDelay (30 * 1000000) 34 | 35 | let req1 = DescribeTable "devel-1" 36 | resp1 <- runCommand req1 37 | print resp1 38 | 39 | data ExampleItem = ExampleItem { 40 | name :: T.Text 41 | , class_ :: T.Text 42 | , boolAttr :: Bool 43 | , oldBoolAttr :: Bool 44 | } 45 | deriving (Show) 46 | 47 | instance ToDynItem ExampleItem where 48 | toItem (ExampleItem name class_ boolAttr oldBoolAttr) = 49 | item [ attr "name" name 50 | , attr "class" class_ 51 | , attr "boolattr" boolAttr 52 | , attr "oldboolattr" (OldBool oldBoolAttr) 53 | ] 54 | 55 | instance FromDynItem ExampleItem where 56 | parseItem x = ExampleItem <$> getAttr "name" x <*> getAttr "class" x <*> getAttr "boolattr" x <*> getAttr "oldboolattr" x 57 | 58 | main :: IO () 59 | main = do 60 | cfg <- Aws.baseConfiguration 61 | 62 | createTableAndWait `catch` (\DdbError{} -> putStrLn "Table already exists") 63 | 64 | putStrLn "Putting an item..." 65 | 66 | let x = ExampleItem { name = "josh", class_ = "not-so-awesome", 67 | boolAttr = False, oldBoolAttr = True } 68 | 69 | let req1 = (putItem "devel-1" (toItem x)) { piReturn = URAllOld 70 | , piRetCons = RCTotal 71 | , piRetMet = RICMSize 72 | } 73 | 74 | 75 | resp1 <- runCommand req1 76 | print resp1 77 | 78 | putStrLn "Getting the item back..." 79 | 80 | let req2 = getItem "devel-1" (hk "name" "josh") 81 | resp2 <- runCommand req2 82 | print resp2 83 | 84 | let y = fromItem (fromMaybe (item []) $ girItem resp2) :: Either String ExampleItem 85 | print y 86 | 87 | print =<< runCommand 88 | (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesome")]) 89 | 90 | echo "Updating with false conditional." 91 | (print =<< runCommand 92 | (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer")]) 93 | { uiExpect = Conditions CondAnd [Condition "name" (DEq "john")] }) 94 | `catch` (\ (e :: DdbError) -> echo ("Eating exception: " ++ show e)) 95 | 96 | echo "Getting the item back..." 97 | print =<< runCommand req2 98 | 99 | 100 | echo "Updating with true conditional" 101 | print =<< runCommand 102 | (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer"), au (attr "oldboolattr" False)]) 103 | { uiExpect = Conditions CondAnd [Condition "name" (DEq "josh")] } 104 | 105 | echo "Getting the item back..." 106 | print =<< runCommand req2 107 | 108 | echo "Running a Query command..." 109 | print =<< runCommand (query "devel-1" (Slice (Attribute "name" "josh") Nothing)) 110 | 111 | echo "Running a Scan command..." 112 | print =<< runCommand (scan "devel-1") 113 | 114 | echo "Filling table with several items..." 115 | forM_ [0..30] $ \ i -> do 116 | threadDelay 50000 117 | runCommand $ putItem "devel-1" $ 118 | item [Attribute "name" (toValue $ T.pack ("lots-" ++ show i)), attrAs int "val" i] 119 | 120 | echo "Now paginating in increments of 5..." 121 | let q0 = (scan "devel-1") { sLimit = Just 5 } 122 | 123 | mgr <- newManager tlsManagerSettings 124 | xs <- runResourceT $ awsIteratedList cfg debugServiceConfig mgr q0 `connect` C.consume 125 | echo ("Pagination returned " ++ show (length xs) ++ " items") 126 | 127 | 128 | runCommand r = do 129 | cfg <- Aws.baseConfiguration 130 | Aws.simpleAws cfg debugServiceConfig r 131 | 132 | echo = putStrLn 133 | 134 | 135 | -------------------------------------------------------------------------------- /Examples/GetObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.S3 as S3 5 | import Control.Monad.Trans.Resource 6 | import Data.Conduit ((.|), runConduit) 7 | import Data.Conduit.Binary (sinkFile) 8 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) 9 | 10 | main :: IO () 11 | main = do 12 | {- Set up AWS credentials and the default configuration. -} 13 | cfg <- Aws.baseConfiguration 14 | let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery 15 | 16 | {- Set up a ResourceT region with an available HTTP manager. -} 17 | mgr <- newManager tlsManagerSettings 18 | runResourceT $ do 19 | {- Create a request object with S3.getObject and run the request with pureAws. -} 20 | S3.GetObjectResponse { S3.gorResponse = rsp } <- 21 | Aws.pureAws cfg s3cfg mgr $ 22 | S3.getObject "haskell-aws" "cloud-remote.pdf" 23 | 24 | {- Save the response to a file. -} 25 | runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf" 26 | -------------------------------------------------------------------------------- /Examples/GetObjectGoogle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.Core as Aws 5 | import qualified Aws.S3 as S3 6 | import Control.Monad.Trans.Resource 7 | import Data.Conduit ((.|), runConduit) 8 | import Data.Conduit.Binary (sinkFile) 9 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) 10 | 11 | main :: IO () 12 | main = do 13 | Just creds <- Aws.loadCredentialsFromEnv 14 | let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing 15 | let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False 16 | {- Set up a ResourceT region with an available HTTP manager. -} 17 | mgr <- newManager tlsManagerSettings 18 | runResourceT $ do 19 | {- Create a request object with S3.getObject and run the request with pureAws. -} 20 | S3.GetObjectResponse { S3.gorResponse = rsp } <- 21 | Aws.pureAws cfg s3cfg mgr $ 22 | {- Public bucket from GCP examples -} 23 | S3.getObject "uspto-pair" "applications/05900016.zip" 24 | 25 | {- Save the response to a file. -} 26 | runConduit $ responseBody rsp .| sinkFile "getobject-test.zip" 27 | -------------------------------------------------------------------------------- /Examples/GetObjectV4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.Core as Aws 5 | import qualified Aws.S3 as S3 6 | import Control.Monad.Trans.Resource 7 | import Data.Conduit ((.|), runConduit) 8 | import Data.Conduit.Binary (sinkFile) 9 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) 10 | 11 | main :: IO () 12 | main = do 13 | {- Set up AWS credentials and the default configuration. -} 14 | Just creds <- Aws.loadCredentialsDefault 15 | let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing 16 | let s3cfg = S3.s3v4 Aws.HTTP "s3.amazonaws.com" False S3.SignWithEffort 17 | 18 | {- Set up a ResourceT region with an available HTTP manager. -} 19 | mgr <- newManager tlsManagerSettings 20 | runResourceT $ do 21 | {- Create a request object with S3.getObject and run the request with pureAws. -} 22 | S3.GetObjectResponse { S3.gorResponse = rsp } <- 23 | Aws.pureAws cfg s3cfg mgr $ 24 | S3.getObject "haskell-aws" "cloud-remote.pdf" 25 | 26 | {- Save the response to a file. -} 27 | runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf" 28 | -------------------------------------------------------------------------------- /Examples/MultipartTransfer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | {- This example demonstrates an ability to stream in constant space content from a remote resource into an S3 object accessible publicly -} 4 | 5 | 6 | import qualified Aws 7 | import Aws.Aws (Configuration (..)) 8 | import qualified Aws.S3 as S3 9 | import Control.Applicative ((<$>)) 10 | import Control.Monad.Trans.Resource 11 | import qualified Data.Text as T 12 | import Network.HTTP.Conduit (http, parseUrl, responseBody, 13 | newManager, tlsManagerSettings) 14 | import System.Environment (getArgs) 15 | 16 | main :: IO () 17 | main = do 18 | maybeCreds <- Aws.loadCredentialsFromEnv 19 | case maybeCreds of 20 | Nothing -> do 21 | putStrLn "Please set the environment variables AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET" 22 | Just creds -> do 23 | args <- getArgs 24 | cfg <- Aws.dbgConfiguration 25 | let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery 26 | 27 | case args of 28 | [sourceUrl,destBucket,destObj] -> do 29 | request <- parseUrl sourceUrl 30 | mgr <- newManager tlsManagerSettings 31 | runResourceT $ do 32 | source <- responseBody <$> http request mgr 33 | let initiator b o = (S3.postInitiateMultipartUpload b o){S3.imuAcl = Just S3.AclPublicRead} 34 | S3.multipartUploadWithInitiator cfg{credentials = creds} s3cfg initiator mgr (T.pack destBucket) (T.pack destObj) source (10*1024*1024) 35 | _ -> do 36 | putStrLn "Usage: MultipartTransfer sourceUrl destinationBucket destinationObjectname" 37 | 38 | -------------------------------------------------------------------------------- /Examples/MultipartUpload.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.Core as Aws 5 | import qualified Aws.S3 as S3 6 | import qualified Data.ByteString.Char8 as B 7 | import Data.Conduit (connect) 8 | import Data.Conduit.Binary (sourceFile) 9 | import qualified Data.Text as T 10 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) 11 | import Control.Monad.Trans.Resource (runResourceT) 12 | import System.Environment (getArgs) 13 | 14 | main :: IO () 15 | main = do 16 | args <- getArgs 17 | case args of 18 | [endpoint, bucket, obj, file] -> doUpload endpoint bucket obj file 10 19 | [endpoint, bucket, obj, file, chunkSize] -> doUpload endpoint bucket obj file (read chunkSize) 20 | _ -> mapM_ putStrLn 21 | [ "Usage: MultipartUpload endpoint bucket dstobject srcfile [chunksize(MB)]" 22 | , "Example: MultipartUpload s3.us-east-2.amazonaws.com your-bucket tmp/test.bin test.bin" 23 | ] 24 | where 25 | doUpload endpoint bucket obj file chunkSize = do 26 | cfg <- Aws.dbgConfiguration 27 | let s3cfg = S3.s3v4 Aws.HTTPS (B.pack endpoint) False S3.SignWithEffort 28 | mgr <- newManager tlsManagerSettings 29 | runResourceT $ 30 | sourceFile file `connect` S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024) 31 | -------------------------------------------------------------------------------- /Examples/NukeBucket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.S3 as S3 5 | import qualified Data.Conduit as C 6 | import qualified Data.Conduit.List as CL 7 | import Data.Text (pack) 8 | import Control.Monad ((<=<)) 9 | import Control.Monad.IO.Class (liftIO) 10 | import Control.Monad.Trans.Resource 11 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) 12 | import System.Environment (getArgs) 13 | 14 | main :: IO () 15 | main = do 16 | [bucket] <- fmap (map pack) getArgs 17 | 18 | {- Set up AWS credentials and the default configuration. -} 19 | cfg <- Aws.baseConfiguration 20 | let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery 21 | 22 | {- Set up a ResourceT region with an available HTTP manager. -} 23 | mgr <- newManager tlsManagerSettings 24 | runResourceT $ do 25 | let src = Aws.awsIteratedSource cfg s3cfg mgr (S3.getBucket bucket) 26 | let deleteObjects [] = return () 27 | deleteObjects os = 28 | do 29 | let keys = map S3.objectKey os 30 | liftIO $ putStrLn ("Deleting objects: " ++ show keys) 31 | _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os)) 32 | return () 33 | src `C.connect` CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO) 34 | liftIO $ putStrLn ("Deleting bucket: " ++ show bucket) 35 | _ <- Aws.pureAws cfg s3cfg mgr (S3.DeleteBucket bucket) 36 | return () 37 | -------------------------------------------------------------------------------- /Examples/PutBucketNearLine.hs: -------------------------------------------------------------------------------- 1 | -- | Example of creating a Nearline bucket on Google Cloud Storage. 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import qualified Aws 6 | import qualified Aws.Core as Aws 7 | import qualified Aws.S3 as S3 8 | import Data.Conduit.Binary (sinkFile) 9 | import Control.Monad.Trans.Resource 10 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..)) 11 | import Control.Monad.IO.Class 12 | import Control.Concurrent 13 | import System.IO 14 | import Control.Applicative 15 | import qualified Data.Text as T 16 | import System.Environment 17 | 18 | sc :: S3.StorageClass 19 | sc = S3.OtherStorageClass (T.pack "NEARLINE") 20 | 21 | main :: IO () 22 | main = do 23 | [bucket] <- fmap (map T.pack) getArgs 24 | 25 | {- Set up AWS credentials and S3 configuration using the Google Cloud 26 | - Storage endpoint. -} 27 | Just creds <- Aws.loadCredentialsFromEnv 28 | let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing 29 | let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False 30 | 31 | {- Set up a ResourceT region with an available HTTP manager. -} 32 | mgr <- newManager tlsManagerSettings 33 | runResourceT $ do 34 | {- Create a request object with S3.PutBucket and run the request with pureAws. -} 35 | rsp <- 36 | Aws.pureAws cfg s3cfg mgr $ 37 | S3.PutBucket bucket Nothing "US" (Just sc) 38 | liftIO $ print rsp 39 | -------------------------------------------------------------------------------- /Examples/PutObjectIA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.Core as Aws 5 | import qualified Aws.S3 as S3 6 | import Data.Conduit (($$+-)) 7 | import Data.Conduit.Binary (sinkFile) 8 | import Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..)) 9 | import qualified Data.ByteString.Lazy as L 10 | import qualified Data.ByteString as S 11 | import Control.Monad.Trans.Resource 12 | import Control.Monad.IO.Class 13 | import Control.Concurrent 14 | import System.Posix.Files 15 | import System.IO 16 | import Control.Applicative 17 | import qualified Data.Text as T 18 | 19 | main :: IO () 20 | main = do 21 | {- Set up AWS credentials and S3 configuration using the IA endpoint. -} 22 | Just creds <- Aws.loadCredentialsFromEnv 23 | let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing 24 | let s3cfg = S3.s3 Aws.HTTP "s3.us.archive.org" False 25 | 26 | {- Set up a ResourceT region with an available HTTP manager. -} 27 | mgr <- newManager tlsManagerSettings 28 | runResourceT $ do 29 | let file ="test" 30 | -- streams large file content, without buffering more than 10k in memory 31 | let streamer sink = withFile file ReadMode $ \h -> sink $ S.hGet h 10240 32 | b <- liftIO $ L.readFile file 33 | size <- liftIO $ (fromIntegral . fileSize <$> getFileStatus file :: IO Integer) 34 | let body = RequestBodyStream (fromInteger size) streamer 35 | rsp <- Aws.pureAws cfg s3cfg mgr $ 36 | (S3.putObject "joeyh-test-item" (T.pack file) body) 37 | { S3.poMetadata = 38 | [ ("mediatype", "texts") 39 | , ("meta-description", "test Internet Archive item made via haskell aws library") 40 | ] 41 | -- Automatically creates bucket on IA if it does not exist, 42 | -- and uses the above metadata as the bucket's metadata. 43 | , S3.poAutoMakeBucket = True 44 | } 45 | liftIO $ print rsp 46 | -------------------------------------------------------------------------------- /Examples/SimpleDb.hs: -------------------------------------------------------------------------------- 1 | import qualified Aws 2 | import qualified Aws.SimpleDb as Sdb 3 | import qualified Data.Text as T 4 | import qualified Data.Text.IO as T 5 | 6 | main :: IO () 7 | main = do 8 | {- Load configuration -} 9 | cfg <- Aws.baseConfiguration 10 | let sdbCfg = Aws.defServiceConfig 11 | 12 | putStrLn "Making request..." 13 | 14 | {- Make request -} 15 | let req = Sdb.listDomains { Sdb.ldMaxNumberOfDomains = Just 10 } 16 | Sdb.ListDomainsResponse names _token <- Aws.simpleAws cfg sdbCfg req 17 | 18 | {- Analyze response -} 19 | putStrLn "First 10 domains:" 20 | mapM_ (T.putStrLn . T.cons '\t') names 21 | -------------------------------------------------------------------------------- /Examples/Sqs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Aws 4 | import qualified Aws.Core 5 | import qualified Aws.Sqs as Sqs 6 | import Control.Concurrent 7 | import Control.Error 8 | import Control.Monad.IO.Class 9 | import Data.Monoid 10 | import Data.String 11 | import qualified Data.Text.IO as T 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Read as TR 14 | import Control.Monad (forM_, forM, replicateM) 15 | 16 | {-| Created by Tim Perry on September 18, 2013 17 | | 18 | | All code relies on a correctly configured ~/.aws-keys and will access that account which 19 | | may incur charges for the user! 20 | | 21 | | This code will demonstrate: 22 | | - Listing all queue's attached to the current AWS account. 23 | | - Creating a queue 24 | | - Adding messages to the queue 25 | | - Retrieving messages from the queue 26 | | - Deleting messages from the queue 27 | | and finally 28 | | - Deleting the queue. 29 | | -} 30 | main :: IO () 31 | main = do 32 | {- Set up AWS credentials and the default configuration. -} 33 | cfg <- Aws.baseConfiguration 34 | let sqscfg = Sqs.sqs Aws.Core.HTTP Sqs.sqsEndpointUsWest2 False :: Sqs.SqsConfiguration Aws.NormalQuery 35 | 36 | {- List any Queues you have already created in your SQS account -} 37 | Sqs.ListQueuesResponse qUrls <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing 38 | let origQUrlCount = length qUrls 39 | putStrLn $ "originally had " ++ show origQUrlCount ++ " queue urls" 40 | mapM_ print qUrls 41 | 42 | {- Create a request object to create a queue and then print out the Queue URL -} 43 | let qName = "scaledsoftwaretest1" 44 | let createQReq = Sqs.CreateQueue (Just 8400) qName 45 | Sqs.CreateQueueResponse qUrl <- Aws.simpleAws cfg sqscfg createQReq 46 | T.putStrLn $ T.concat ["queue was created with Url: ", qUrl] 47 | 48 | {- Create a QueueName object, sqsQName, to hold the name of this queue for the duration -} 49 | let awsAccountNum = T.split (== '/') qUrl !! 3 50 | let sqsQName = Sqs.QueueName qName awsAccountNum 51 | 52 | {- list queue attributes -- for this example we will only list the approximateNumberOfMessages in this queue. -} 53 | let qAttReq = Sqs.GetQueueAttributes sqsQName [Sqs.ApproximateNumberOfMessages] 54 | Sqs.GetQueueAttributesResponse attPairs <- Aws.simpleAws cfg sqscfg qAttReq 55 | mapM_ (\(attName, attText) -> T.putStrLn $ T.concat [" ", Sqs.printQueueAttribute attName, " ", attText]) attPairs 56 | 57 | {- Here we add some messages to the queue -} 58 | let messages = map (\n -> T.pack $ "msg" ++ show n) [1 .. 10] 59 | {- Add messages to the queue -} 60 | forM_ messages $ \mText -> do 61 | T.putStrLn $ " Adding: " <> mText 62 | let sqsSendMessage = Sqs.SendMessage mText sqsQName [] (Just 0) 63 | Sqs.SendMessageResponse _ mid _ <- Aws.simpleAws cfg sqscfg sqsSendMessage 64 | T.putStrLn $ " message id: " <> sshow mid 65 | 66 | {- Here we remove messages from the queue one at a time. -} 67 | let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) [] sqsQName (Just 20) 68 | let numMessages = length messages 69 | removedMsgs <- replicateM numMessages $ do 70 | msgs <- exceptT (const $ return []) return . retryT 2 $ do 71 | Sqs.ReceiveMessageResponse r <- liftIO $ Aws.simpleAws cfg sqscfg receiveMessageReq 72 | case r of 73 | [] -> throwE "no message received" 74 | _ -> return r 75 | putStrLn $ "number of messages received: " ++ show (length msgs) 76 | forM msgs (\msg -> do 77 | -- here we remove a message, delete it from the queue, and then return the 78 | -- text sent in the body of the message 79 | putStrLn $ " Received " ++ show (Sqs.mBody msg) 80 | Aws.simpleAws cfg sqscfg $ Sqs.DeleteMessage (Sqs.mReceiptHandle msg) sqsQName 81 | return $ Sqs.mBody msg) 82 | 83 | {- Now we'll delete the queue we created at the start of this program -} 84 | putStrLn $ "Deleting the queue: " ++ show (Sqs.qName sqsQName) 85 | let dQReq = Sqs.DeleteQueue sqsQName 86 | _ <- Aws.simpleAws cfg sqscfg dQReq 87 | 88 | {- | Let's make sure the queue was actually deleted and that the same number of queues exist at when 89 | | the program ends as when it started. 90 | -} 91 | exceptT T.putStrLn T.putStrLn . retryT 4 $ do 92 | qUrls <- liftIO $ do 93 | putStrLn $ "Listing all queueus to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone" 94 | Sqs.ListQueuesResponse qUrls_ <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing 95 | mapM_ T.putStrLn qUrls_ 96 | return qUrls_ 97 | 98 | if qUrl `elem` qUrls 99 | then throwE $ " *\n *\n * Warning, '" <> sshow qName <> "' was not deleted\n" 100 | <> " * This is probably just a race condition." 101 | else return $ " The queue '" <> sshow qName <> "' was correctly deleted" 102 | 103 | retryT :: MonadIO m => Int -> ExceptT T.Text m a -> ExceptT T.Text m a 104 | retryT i f = go 1 105 | where 106 | go x 107 | | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f 108 | | otherwise = f `catchE` \_ -> do 109 | liftIO $ threadDelay (1000000 * min 60 (2^(x-1))) 110 | go (succ x) 111 | 112 | sshow :: (Show a, IsString b) => a -> b 113 | sshow = fromString . show 114 | 115 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, 2011, 2012, Aristid Breitkreuz 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Aristid Breitkreuz nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /VERSIONING: -------------------------------------------------------------------------------- 1 | The AWS package is, starting with the 0.4 release, following the following versioning scheme: 2 | 3 | - Releases follow the Major.minor.tiny scheme. Numbering starts from 0, no numbers are special. 4 | - Minor changes that do not change any APIs, including APIs from other packages that are used by this package (e.g. by raising the lower version bound of a dependency), change the "tiny" level only. 5 | - Medium changes that change the API, or minor changes that raise the lower version bound of a dependency, change the "minor" level. 6 | - Major changes that change the API, change the "major" level. 7 | 8 | This means that the next major release after 0.4.0 will be 1.0.0, where the 1.x does NOT denote a "stable" release. 9 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, attoparsec, base, base16-bytestring 2 | , base64-bytestring, blaze-builder, byteable, bytestring 3 | , case-insensitive, cereal, conduit, conduit-combinators 4 | , conduit-extra, containers, cryptohash, data-default, directory 5 | , errors, filepath, http-client, http-client-tls, http-conduit 6 | , http-types, lifted-base, monad-control, mtl, network, network-bsd, old-locale 7 | , QuickCheck, quickcheck-instances, resourcet, safe, scientific 8 | , stdenv, tagged, tasty, tasty-hunit, tasty-quickcheck, text, time 9 | , transformers, transformers-base, unordered-containers 10 | , utf8-string, vector, xml-conduit 11 | }: 12 | mkDerivation { 13 | pname = "aws"; 14 | version = "0.17"; 15 | src = ./.; 16 | isLibrary = true; 17 | isExecutable = true; 18 | libraryHaskellDepends = [ 19 | aeson attoparsec base base16-bytestring base64-bytestring 20 | blaze-builder byteable bytestring case-insensitive cereal conduit 21 | conduit-extra containers cryptohash data-default directory filepath 22 | http-conduit http-types lifted-base monad-control mtl network network-bsd 23 | old-locale resourcet safe scientific tagged text time transformers 24 | unordered-containers utf8-string vector xml-conduit 25 | ]; 26 | testHaskellDepends = [ 27 | aeson base bytestring conduit-combinators errors http-client 28 | http-client-tls http-types lifted-base monad-control mtl QuickCheck 29 | quickcheck-instances resourcet tagged tasty tasty-hunit 30 | tasty-quickcheck text time transformers transformers-base 31 | ]; 32 | homepage = "http://github.com/aristidb/aws"; 33 | description = "Amazon Web Services (AWS) for Haskell"; 34 | license = stdenv.lib.licenses.bsd3; 35 | } 36 | -------------------------------------------------------------------------------- /ghci.hs: -------------------------------------------------------------------------------- 1 | -- GHCI convenience code 2 | 3 | import Aws 4 | import Aws.Ec2.InstanceMetadata 5 | import qualified Aws.S3 as S3 6 | import qualified Aws.Ses as Ses 7 | import qualified Aws.SimpleDb as Sdb 8 | import qualified Aws.Sqs as Sqs 9 | import Control.Monad.IO.Class 10 | import Control.Monad.Trans.Resource 11 | import qualified Data.ByteString as S 12 | import qualified Data.ByteString.Lazy as L 13 | import qualified Data.Conduit as C 14 | import qualified Data.Conduit.List as CL 15 | import Data.Default 16 | import qualified Network.HTTP.Conduit as HTTP 17 | import qualified Network.HTTP.Types as HTTP 18 | 19 | import System.IO.Unsafe -- only for the initialisation Please 20 | 21 | bcfg = unsafePerformIO baseConfiguration 22 | dcfg = unsafePerformIO dbgConfiguration 23 | mgr = unsafePerformIO (HTTP.newManager def) -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with (import {}).pkgs; 2 | let 3 | pkg = haskellPackages.callPackage ./. {}; 4 | in 5 | pkg.env 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-19.16 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /tests/DynamoDb/Main.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2014 AlephCloud Systems, Inc. 3 | -- ------------------------------------------------------ -- 4 | 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | 11 | -- | 12 | -- Module: Main 13 | -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. 14 | -- License: BSD3 15 | -- Maintainer: Lars Kuhtz 16 | -- Stability: experimental 17 | -- 18 | -- Tests for Haskell AWS DynamoDb bindings 19 | -- 20 | 21 | module Main 22 | ( main 23 | ) where 24 | 25 | import Aws 26 | import qualified Aws.DynamoDb as DY 27 | 28 | import Control.Arrow (second) 29 | import Control.Error 30 | import Control.Monad 31 | import Control.Monad.IO.Class 32 | 33 | import Data.IORef 34 | import qualified Data.List as L 35 | import qualified Data.Text as T 36 | 37 | import qualified Network.HTTP.Client as HTTP 38 | 39 | import Test.Tasty 40 | import Test.QuickCheck.Instances () 41 | 42 | import System.Environment 43 | import System.Exit 44 | 45 | import Utils 46 | import DynamoDb.Utils 47 | 48 | -- -------------------------------------------------------------------------- -- 49 | -- Main 50 | 51 | main :: IO () 52 | main = do 53 | args <- getArgs 54 | runMain args $ map (second tail . span (/= '=')) args 55 | where 56 | runMain :: [String] -> [(String,String)] -> IO () 57 | runMain args _argsMap 58 | | any (`elem` helpArgs) args = defaultMain tests 59 | | "--run-with-aws-credentials" `elem` args = 60 | withArgs (tastyArgs args) . defaultMain $ tests 61 | | otherwise = putStrLn help >> exitFailure 62 | 63 | helpArgs = ["--help", "-h"] 64 | mainArgs = 65 | [ "--run-with-aws-credentials" 66 | ] 67 | tastyArgs args = flip filter args $ \x -> not 68 | $ any (`L.isPrefixOf` x) mainArgs 69 | 70 | 71 | help :: String 72 | help = L.intercalate "\n" 73 | [ "" 74 | , "NOTE" 75 | , "" 76 | , "This test suite accesses the AWS account that is associated with" 77 | , "the default credentials from the credential file ~/.aws-keys." 78 | , "" 79 | , "By running the tests in this test-suite costs for usage of AWS" 80 | , "services may incur." 81 | , "" 82 | , "In order to actually execute the tests in this test-suite you must" 83 | , "provide the command line options:" 84 | , "" 85 | , " --run-with-aws-credentials" 86 | , "" 87 | , "When running this test-suite through cabal you may use the following" 88 | , "command:" 89 | , "" 90 | , " cabal test --test-option=--run-with-aws-credentials dynamodb-tests" 91 | , "" 92 | ] 93 | 94 | tests :: TestTree 95 | tests = testGroup "DynamoDb Tests" 96 | [ test_table 97 | -- , test_message 98 | , test_core 99 | ] 100 | 101 | -- -------------------------------------------------------------------------- -- 102 | -- Table Tests 103 | 104 | test_table :: TestTree 105 | test_table = testGroup "Table Tests" 106 | [ eitherTOnceTest1 "CreateDescribeDeleteTable" (prop_createDescribeDeleteTable 10 10) 107 | ] 108 | 109 | -- | 110 | -- 111 | prop_createDescribeDeleteTable 112 | :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) 113 | -> Int -- ^ write capacity (#writes * itemsize/1KB) 114 | -> T.Text -- ^ table name 115 | -> ExceptT T.Text IO () 116 | prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do 117 | tTableName <- testData tableName 118 | tryT $ createTestTable tTableName readCapacity writeCapacity 119 | let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName) 120 | flip catchE (\e -> deleteTable >> throwE e) $ do 121 | retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName 122 | deleteTable 123 | 124 | -- -------------------------------------------------------------------------- -- 125 | -- Test core functionality 126 | 127 | test_core :: TestTree 128 | test_core = testGroup "Core Tests" 129 | [ eitherTOnceTest0 "connectionReuse" prop_connectionReuse 130 | ] 131 | 132 | prop_connectionReuse 133 | :: ExceptT T.Text IO () 134 | prop_connectionReuse = do 135 | c <- liftIO $ do 136 | cfg <- baseConfiguration 137 | 138 | -- counts the number of TCP connections 139 | ref <- newIORef (0 :: Int) 140 | 141 | manager <- HTTP.newManager (managerSettings ref) 142 | void $ runExceptT $ 143 | flip catchE (error . T.unpack) . replicateM_ 3 $ do 144 | void $ dyT cfg manager DY.ListTables 145 | mustFail . dyT cfg manager $ DY.DescribeTable "____" 146 | 147 | readIORef ref 148 | unless (c == 1) $ 149 | throwE "The TCP connection has not been reused" 150 | where 151 | managerSettings ref = HTTP.defaultManagerSettings 152 | { HTTP.managerRawConnection = do 153 | mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings 154 | return $ \a b c -> do 155 | atomicModifyIORef ref $ \i -> (succ i, ()) 156 | mkConn a b c 157 | } 158 | 159 | -------------------------------------------------------------------------------- /tests/DynamoDb/Utils.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2014 AlephCloud Systems, Inc. 3 | -- ------------------------------------------------------ -- 4 | 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | -- | 13 | -- Module: DynamoDb.Utils 14 | -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. 15 | -- License: BSD3 16 | -- Maintainer: Lars Kuhtz 17 | -- Stability: experimental 18 | -- 19 | -- Tests for Haskell SQS bindings 20 | -- 21 | 22 | module DynamoDb.Utils 23 | ( 24 | -- * Static Parameters 25 | testProtocol 26 | , testRegion 27 | , defaultTableName 28 | 29 | -- * Static Configuration 30 | , dyConfiguration 31 | 32 | -- * DynamoDb Utils 33 | , simpleDy 34 | , simpleDyT 35 | , dyT 36 | , withTable 37 | , withTable_ 38 | , createTestTable 39 | ) where 40 | 41 | import Aws 42 | import Aws.Core 43 | import qualified Aws.DynamoDb as DY 44 | 45 | import Control.Error 46 | import Control.Exception 47 | import Control.Monad 48 | import Control.Monad.IO.Class 49 | import Control.Monad.Trans.Control 50 | import Control.Monad.Trans.Resource 51 | 52 | import Data.Monoid 53 | import qualified Data.Text as T 54 | import qualified Data.Text.IO as T 55 | 56 | import qualified Network.HTTP.Client as HTTP 57 | 58 | import Test.Tasty 59 | import Test.QuickCheck.Instances () 60 | 61 | import System.IO 62 | 63 | import Utils 64 | 65 | -- -------------------------------------------------------------------------- -- 66 | -- Static Test parameters 67 | -- 68 | -- TODO make these configurable 69 | 70 | testProtocol :: Protocol 71 | testProtocol = HTTP 72 | 73 | testRegion :: DY.Region 74 | testRegion = DY.ddbUsWest2 75 | 76 | defaultTableName :: T.Text 77 | defaultTableName = "test-table" 78 | 79 | -- -------------------------------------------------------------------------- -- 80 | -- Dynamo Utils 81 | 82 | dyConfiguration :: DY.DdbConfiguration qt 83 | dyConfiguration = DY.DdbConfiguration 84 | { DY.ddbcRegion = testRegion 85 | , DY.ddbcProtocol = testProtocol 86 | , DY.ddbcPort = Nothing 87 | } 88 | 89 | simpleDy 90 | :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadIO m) 91 | => r 92 | -> m (MemoryResponse a) 93 | simpleDy command = do 94 | c <- dbgConfiguration 95 | simpleAws c dyConfiguration command 96 | 97 | simpleDyT 98 | :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m) 99 | => r 100 | -> ExceptT T.Text m (MemoryResponse a) 101 | simpleDyT = tryT . simpleDy 102 | 103 | dyT 104 | :: (Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration) 105 | => Configuration 106 | -> HTTP.Manager 107 | -> r 108 | -> ExceptT T.Text IO a 109 | dyT cfg manager req = do 110 | Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req 111 | hoistEither $ fmapL sshow r 112 | 113 | withTable 114 | :: T.Text -- ^ table Name 115 | -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) 116 | -> Int -- ^ write capacity (#writes * itemsize/1KB) 117 | -> (T.Text -> IO a) -- ^ test tree 118 | -> IO a 119 | withTable = withTable_ True 120 | 121 | withTable_ 122 | :: Bool -- ^ whether to prefix te table name 123 | -> T.Text -- ^ table Name 124 | -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) 125 | -> Int -- ^ write capacity (#writes * itemsize/1KB) 126 | -> (T.Text -> IO a) -- ^ test tree 127 | -> IO a 128 | withTable_ prefix tableName readCapacity writeCapacity f = 129 | do 130 | tTableName <- if prefix then testData tableName else return tableName 131 | 132 | let deleteTable = do 133 | r <- runExceptT . retryT 6 $ 134 | void (simpleDyT $ DY.DeleteTable tTableName) `catchE` \e -> 135 | liftIO . T.hPutStrLn stderr $ "attempt to delete table failed: " <> e 136 | either (error . T.unpack) (const $ return ()) r 137 | 138 | let createTable = do 139 | r <- runExceptT $ do 140 | retryT 3 $ tryT $ createTestTable tTableName readCapacity writeCapacity 141 | retryT 6 $ do 142 | tableDesc <- simpleDyT $ DY.DescribeTable tTableName 143 | when (DY.rTableStatus tableDesc == "CREATING") $ throwE "Table not ready: status CREATING" 144 | either (error . T.unpack) return r 145 | 146 | bracket_ createTable deleteTable $ f tTableName 147 | 148 | createTestTable 149 | :: T.Text -- ^ table Name 150 | -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB) 151 | -> Int -- ^ write capacity (#writes * itemsize/1KB) 152 | -> IO () 153 | createTestTable tableName readCapacity writeCapacity = void . simpleDy $ 154 | DY.createTable 155 | tableName 156 | attrs 157 | (DY.HashOnly keyName) 158 | throughPut 159 | where 160 | keyName = "Id" 161 | keyType = DY.AttrString 162 | attrs = [DY.AttributeDefinition keyName keyType] 163 | throughPut = DY.ProvisionedThroughput 164 | { DY.readCapacityUnits = readCapacity 165 | , DY.writeCapacityUnits = writeCapacity 166 | } 167 | 168 | 169 | --------------------------------------------------------------------------------