module Network.AWS.Actions
(
DomainName
, MaxNumberOfDomains
, SelectExpression
, ItemName
, AttributeKey
, AttributeValue
, Attribute(..)
, Item(..)
, createDomain
, deleteDomain
, 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
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
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 ()
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)
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")
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 ()
putAttributes :: AWSConnection -> DomainName -> Item -> IO ()
putAttributes conn domainName item
= putAttributes' conn domainName item []
putAttributes' :: AWSConnection -> DomainName -> Item
-> [AttributeKey]
-> 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 ()
batchPutAttributes :: AWSConnection -> DomainName -> [Item] -> IO ()
batchPutAttributes conn domainName items
= batchPutAttributes' conn domainName [ (item, []) | item <- items ]
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 ()
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
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
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 ()
atTag tag = deep (isElem >>> hasName tag)
text = getChildren >>> getText
textAt tag = atTag tag >>> text