hSimpleDB-0.1: src/Network/AWS/Actions.hs
{-# 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