{-# LANGUAGE NoMonomorphismRestriction, Arrows #-} module Network.AWS.Actions ( -- * Types DomainName , MaxNumberOfDomains , SelectExpression , ItemName , AttributeKey , AttributeValue , Attribute(..) , Item(..) -- * Actions , createDomain , deleteDomain , listDomains -- , listDomains' , getAttributes , putAttributes , putAttributes' , batchPutAttributes , batchPutAttributes' , deleteAttributes , select ) where import Network.AWS.Authentication import Network.AWS.AWSConnection import qualified Data.ByteString.Lazy.Char8 as L import Network.HTTP import Text.XML.HXT.Arrow import qualified Data.Tree.NTree.TypeDefs import Control.Arrow import Data.List -- | Domain name limits: 3-255 characters (a-z, A-Z, 0-9, '_', '-', and '.') type DomainName = String type MaxNumberOfDomains = Int type SelectExpression = String type ItemName = String type AttributeKey = String type AttributeValue = String data Attribute = AttributeKey := AttributeValue deriving (Read,Show,Eq,Ord) data Item = Item { itemName :: ItemName , itemAttributes :: [Attribute] } deriving (Read,Show,Eq,Ord) attributeKey :: Attribute -> AttributeKey attributeKey (key := _) = key attributeValue :: Attribute -> AttributeValue attributeValue (_ := value) = value -- | The @createDomain@ operation creates a new domain. The domain name must be unique -- among the domains associated with the Access Key ID provided in the request. The -- @createDomain@ operation might take 10 or more seconds to complete. createDomain :: AWSConnection -> DomainName -> IO () createDomain conn domain = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = ["Action=CreateDomain","DomainName="++urlEncode domain,"Version=2009-04-15", "SignatureVersion=2","SignatureMethod=HmacSHA1"] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right _rsp -> return () -- | The @listDomains@ operation lists all domains associated with the Access Key ID. listDomains :: AWSConnection -> IO [DomainName] listDomains conn = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = ["Action=ListDomains","Version=2009-04-15", "SignatureVersion=2","SignatureMethod=HmacSHA1"] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right rsp -> parseDomainListXML (L.unpack $ rspBody rsp) -- | The @listDomains@ operation lists all domains associated with the Access Key ID. -- It returns domain names up to the limit set by `MaxNumberOfDomains`. A NextToken -- is returned if there are more than `MaxNumberOfDomains` domains. Calling @listDomains'@ -- successive times with the @NextToken@ returns up to `MaxNumberOfDomains` more domain -- names each time. listDomains' :: AWSConnection -> MaxNumberOfDomains -> Maybe DomainName -> IO [DomainName] listDomains' conn maxNumberOfDomains mbNextToken = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=ListDomains","Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1"] ++ [ "MaxNumberOfDomains="++show maxNumberOfDomains] ++ maybe [] (\nextToken -> ["NextToken="++urlEncode nextToken]) mbNextToken , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right rsp -> parseDomainListXML (L.unpack $ rspBody rsp) parseDomainListXML :: String -> IO [DomainName] parseDomainListXML x = runX (readString [(a_validate,v_0)] x >>> processDomains) processDomains :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) DomainName processDomains = deep (isElem >>> hasName "ListDomainsResult") >>> (text <<< atTag "DomainName") -- | The @deleteDomain@ operation deletes a domain. Any items (and their attributes) -- in the domain are deleted as well. The @deleteDomain@ operation might take 10 or -- more seconds to complete. deleteDomain :: AWSConnection -> DomainName -> IO () deleteDomain conn domain = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=DeleteDomain","DomainName="++urlEncode domain,"Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1"] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right _rsp -> return () -- | The @putAttributes@ operation creates or replaces attributes in an item. -- Attributes are uniquely identified in an item by their name/value combination. -- For example, a single item can have the attributes @[\"first_name\" := \"first_value\"]@ -- and @[\"first_name\" := \"second_value\"]@. However, it cannot have two attribute -- instances where both the name and value are the same. -- See also `putAttributes'`. putAttributes :: AWSConnection -> DomainName -> Item -> IO () putAttributes conn domainName item = putAttributes' conn domainName item [] -- | The @putAttributes@ operation creates or replaces attributes in an item. -- Attributes are uniquely identified in an item by their name/value combination. -- For example, a single item can have the attributes @[\"first_name\" := \"first_value\"]@ -- and @[\"first_name\" := \"second_value\"]@. However, it cannot have two attribute -- instances where both the name and value are the same. -- -- This command differs from `putAttributes` by taking a list of attribute keys that -- are to be replaced instead of appended. putAttributes' :: AWSConnection -> DomainName -> Item -> [AttributeKey] -- ^ Keys for the attributes that should be replaced. -> IO () putAttributes' conn domainName item toReplace | not (null (toReplace \\ map attributeKey (itemAttributes item))) = error "Network.AWS.Actions.putAttributes': Attributes to replace are not a subset of total attributes." putAttributes' conn domainName item toReplace = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=PutAttributes","ItemName="++urlEncode (itemName item),"Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1", "DomainName="++urlEncode domainName] ++ concat [ ["Attribute."++show n++".Name="++urlEncode key ,"Attribute."++show n++".Value="++urlEncode val] ++ if replace then ["Attribute."++show n++".Replace=true"] else [] | (key := val, n) <- zip (itemAttributes item) [0..] , let replace = key `elem` toReplace ] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right _rsp -> return () -- | With the @batchPutAttributes@ operation, you can perform multiple @putAttribute@ -- operations in a single call. This helps you yield savings in round trips and -- latencies, and enables Amazon SimpleDB to optimize requests, which generally -- yields better throughput. -- -- See also `putAttributes`. batchPutAttributes :: AWSConnection -> DomainName -> [Item] -> IO () batchPutAttributes conn domainName items = batchPutAttributes' conn domainName [ (item, []) | item <- items ] -- | With the @batchPutAttributes@ operation, you can perform multiple @putAttribute@ -- operations in a single call. This helps you yield savings in round trips and -- latencies, and enables Amazon SimpleDB to optimize requests, which generally -- yields better throughput. -- -- See also `putAttributes'`. batchPutAttributes' :: AWSConnection -> DomainName -> [(Item, [AttributeKey])] -> IO () batchPutAttributes' conn domainName items = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=BatchPutAttributes","Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1", "DomainName="++urlEncode domainName] ++ concat [ ["Item."++show idx++".ItemName="++urlEncode (itemName item)] ++ concat [ ["Item."++show idx++".Attribute."++show n++".Name="++urlEncode key ,"Item."++show idx++".Attribute."++show n++".Value="++urlEncode val] ++ if replace then ["Item."++show idx++".Attribute."++show n++".Replace=true"] else [] | (key := val, n) <- zip (itemAttributes item) [0..] , let replace = key `elem` toReplace ] | ((item, toReplace),idx) <- zip items [0..]] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right _rsp -> return () -- FIXME: Support NextToken. -- | The @select@ operation returns a set of Attributes for ItemNames that match the -- select expression. @select@ is similar to the standard SQL SELECT statement. -- The total size of the response cannot exceed 1 MB in total size. Amazon SimpleDB -- automatically adjusts the number of items returned per page to enforce this limit. -- For example, even if you ask to retrieve 2500 items, but each individual item is -- 10 kB in size, the system returns 100 items and an appropriate next token so you -- can get the next page of results. select :: AWSConnection -> SelectExpression -> IO [Item] select conn expression = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=Select","Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1" , "SelectExpression="++urlEncode expression] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right rsp -> parseSelectResponseXML (L.unpack $ rspBody rsp) parseSelectResponseXML :: String -> IO [Item] parseSelectResponseXML x = runX (readString [(a_validate,v_0)] x >>> processSelectResponse) processSelectResponse :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) Item processSelectResponse = proc x -> do y <- deep (isElem >>> hasName "Item") -< x name <- (text <<< hasName "Name" <<< getChildren) -< y attrs <- listA (atTag "Attribute" >>> textAt "Name" &&& textAt "Value" >>> arr (uncurry (:=))) -< y returnA -< Item name attrs -- | Returns all of the attributes associated with the item. Optionally, the attributes -- returned can be limited to one or more specified attribute name parameters. If the -- item does not exist on the replica that was accessed for this operation, an empty -- set is returned. The system does not return an error as it cannot guarantee the -- item does not exist on other replicas. getAttributes :: AWSConnection -> DomainName -> ItemName -> [AttributeKey] -> IO Item getAttributes conn domain itemName attributes = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=GetAttributes","DomainName="++urlEncode domain,"Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1" , "ItemName="++urlEncode itemName] ++ [ "AttributeName."++show n ++ "=" ++ urlEncode key | (key, n) <- zip attributes [0..] ] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right rsp -> do attrs <- parseAttributesXML (L.unpack $ rspBody rsp) return $ Item itemName attrs parseAttributesXML :: String -> IO [Attribute] parseAttributesXML x = runX (readString [(a_validate,v_0)] x >>> processAttributesResponse) processAttributesResponse :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) Attribute processAttributesResponse = proc x -> do y <- deep (atTag "Attribute") -< x textAt "Name" &&& textAt "Value" >>> arr (uncurry (:=)) -< y -- | Deletes one or more attributes associated with the item. If all attributes of an item -- are deleted, the item is deleted. deleteAttributes :: AWSConnection -> DomainName -> Item -> IO () deleteAttributes conn domain item = do let action = SimpleDBAction { sdbConnection = conn , sdbQuery = [ "Action=DeleteAttributes","DomainName="++urlEncode domain,"Version=2009-04-15" , "SignatureVersion=2","SignatureMethod=HmacSHA1" , "ItemName="++urlEncode (itemName item)] ++ concat [ [ "Attribute."++show n++".Name="++urlEncode key ] ++ if null val then [] else ["Attribute."++show n++".Value="++urlEncode val ] | (key := val, n) <- zip (itemAttributes item) [0..] ] , sdbMetaData = [] , sdbBody = L.empty , sdbOperation = GET } result <- runAction action case result of Left err -> error (show err) Right _rsp -> return () -- Utilities atTag tag = deep (isElem >>> hasName tag) text = getChildren >>> getText textAt tag = atTag tag >>> text