{-# 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