module Aws.SimpleDb.Core where

import           Aws.Core
import qualified Blaze.ByteString.Builder       as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import qualified Control.Exception              as C
import           Control.Monad
import           Control.Monad.Trans.Resource   (MonadThrow, throwM)
import qualified Data.ByteString                as B
import qualified Data.ByteString.Base64         as Base64
import           Data.IORef
import           Data.List
import           Data.Maybe
import           Data.Monoid
import qualified Data.Semigroup                 as Sem
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as T
import           Data.Typeable
import           Prelude
import qualified Network.HTTP.Conduit           as HTTP
import qualified Network.HTTP.Types             as HTTP
import           Text.XML.Cursor                (($|), ($/), ($//), (&|))
import qualified Text.XML.Cursor                as Cu

type ErrorCode = String

data SdbError
    = SdbError {
        SdbError -> Status
sdbStatusCode :: HTTP.Status
      , SdbError -> ErrorCode
sdbErrorCode :: ErrorCode
      , SdbError -> ErrorCode
sdbErrorMessage :: String
      }
    deriving (Int -> SdbError -> ShowS
[SdbError] -> ShowS
SdbError -> ErrorCode
(Int -> SdbError -> ShowS)
-> (SdbError -> ErrorCode)
-> ([SdbError] -> ShowS)
-> Show SdbError
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SdbError -> ShowS
showsPrec :: Int -> SdbError -> ShowS
$cshow :: SdbError -> ErrorCode
show :: SdbError -> ErrorCode
$cshowList :: [SdbError] -> ShowS
showList :: [SdbError] -> ShowS
Show, Typeable)

instance C.Exception SdbError

data SdbMetadata
    = SdbMetadata {
        SdbMetadata -> Maybe Text
requestId :: Maybe T.Text
      , SdbMetadata -> Maybe Text
boxUsage :: Maybe T.Text
      }
    deriving (Int -> SdbMetadata -> ShowS
[SdbMetadata] -> ShowS
SdbMetadata -> ErrorCode
(Int -> SdbMetadata -> ShowS)
-> (SdbMetadata -> ErrorCode)
-> ([SdbMetadata] -> ShowS)
-> Show SdbMetadata
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SdbMetadata -> ShowS
showsPrec :: Int -> SdbMetadata -> ShowS
$cshow :: SdbMetadata -> ErrorCode
show :: SdbMetadata -> ErrorCode
$cshowList :: [SdbMetadata] -> ShowS
showList :: [SdbMetadata] -> ShowS
Show, Typeable)

instance Loggable SdbMetadata where
    toLogText :: SdbMetadata -> Text
toLogText (SdbMetadata Maybe Text
rid Maybe Text
bu) = Text
"SimpleDB: request ID=" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend`
                                     Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"<none>" Maybe Text
rid Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend`
                                     Text
", box usage=" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend`
                                     Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"<not available>" Maybe Text
bu

instance Sem.Semigroup SdbMetadata where
    SdbMetadata Maybe Text
r1 Maybe Text
b1 <> :: SdbMetadata -> SdbMetadata -> SdbMetadata
<> SdbMetadata Maybe Text
r2 Maybe Text
b2 = Maybe Text -> Maybe Text -> SdbMetadata
SdbMetadata (Maybe Text
r1 Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe Text
r2) (Maybe Text
b1 Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe Text
b2)

instance Monoid SdbMetadata where
    mempty :: SdbMetadata
mempty = Maybe Text -> Maybe Text -> SdbMetadata
SdbMetadata Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
    mappend :: SdbMetadata -> SdbMetadata -> SdbMetadata
mappend = SdbMetadata -> SdbMetadata -> SdbMetadata
forall a. Semigroup a => a -> a -> a
(Sem.<>)

data SdbConfiguration qt
    = SdbConfiguration {
        forall qt. SdbConfiguration qt -> Protocol
sdbiProtocol :: Protocol
      , forall qt. SdbConfiguration qt -> Method
sdbiHttpMethod :: Method
      , forall qt. SdbConfiguration qt -> ByteString
sdbiHost :: B.ByteString
      , forall qt. SdbConfiguration qt -> Int
sdbiPort :: Int
      }
    deriving (Int -> SdbConfiguration qt -> ShowS
[SdbConfiguration qt] -> ShowS
SdbConfiguration qt -> ErrorCode
(Int -> SdbConfiguration qt -> ShowS)
-> (SdbConfiguration qt -> ErrorCode)
-> ([SdbConfiguration qt] -> ShowS)
-> Show (SdbConfiguration qt)
forall qt. Int -> SdbConfiguration qt -> ShowS
forall qt. [SdbConfiguration qt] -> ShowS
forall qt. SdbConfiguration qt -> ErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall qt. Int -> SdbConfiguration qt -> ShowS
showsPrec :: Int -> SdbConfiguration qt -> ShowS
$cshow :: forall qt. SdbConfiguration qt -> ErrorCode
show :: SdbConfiguration qt -> ErrorCode
$cshowList :: forall qt. [SdbConfiguration qt] -> ShowS
showList :: [SdbConfiguration qt] -> ShowS
Show)

instance DefaultServiceConfiguration (SdbConfiguration NormalQuery) where
  defServiceConfig :: SdbConfiguration NormalQuery
defServiceConfig = ByteString -> SdbConfiguration NormalQuery
sdbHttpsPost ByteString
sdbUsEast
  debugServiceConfig :: SdbConfiguration NormalQuery
debugServiceConfig = ByteString -> SdbConfiguration NormalQuery
sdbHttpPost ByteString
sdbUsEast

instance DefaultServiceConfiguration (SdbConfiguration UriOnlyQuery) where
  defServiceConfig :: SdbConfiguration UriOnlyQuery
defServiceConfig = ByteString -> SdbConfiguration UriOnlyQuery
forall qt. ByteString -> SdbConfiguration qt
sdbHttpsGet ByteString
sdbUsEast
  debugServiceConfig :: SdbConfiguration UriOnlyQuery
debugServiceConfig = ByteString -> SdbConfiguration UriOnlyQuery
forall qt. ByteString -> SdbConfiguration qt
sdbHttpGet ByteString
sdbUsEast

sdbUsEast :: B.ByteString
sdbUsEast :: ByteString
sdbUsEast = ByteString
"sdb.amazonaws.com"

sdbUsWest :: B.ByteString
sdbUsWest :: ByteString
sdbUsWest = ByteString
"sdb.us-west-1.amazonaws.com"

sdbEuWest :: B.ByteString
sdbEuWest :: ByteString
sdbEuWest = ByteString
"sdb.eu-west-1.amazonaws.com"

sdbApSoutheast :: B.ByteString
sdbApSoutheast :: ByteString
sdbApSoutheast = ByteString
"sdb.ap-southeast-1.amazonaws.com"

sdbApNortheast :: B.ByteString
sdbApNortheast :: ByteString
sdbApNortheast = ByteString
"sdb.ap-northeast-1.amazonaws.com"

sdbHttpGet :: B.ByteString -> SdbConfiguration qt
sdbHttpGet :: forall qt. ByteString -> SdbConfiguration qt
sdbHttpGet ByteString
endpoint = Protocol -> Method -> ByteString -> Int -> SdbConfiguration qt
forall qt.
Protocol -> Method -> ByteString -> Int -> SdbConfiguration qt
SdbConfiguration Protocol
HTTP Method
Get ByteString
endpoint (Protocol -> Int
defaultPort Protocol
HTTP)

sdbHttpPost :: B.ByteString -> SdbConfiguration NormalQuery
sdbHttpPost :: ByteString -> SdbConfiguration NormalQuery
sdbHttpPost ByteString
endpoint = Protocol
-> Method -> ByteString -> Int -> SdbConfiguration NormalQuery
forall qt.
Protocol -> Method -> ByteString -> Int -> SdbConfiguration qt
SdbConfiguration Protocol
HTTP Method
PostQuery ByteString
endpoint (Protocol -> Int
defaultPort Protocol
HTTP)

sdbHttpsGet :: B.ByteString -> SdbConfiguration qt
sdbHttpsGet :: forall qt. ByteString -> SdbConfiguration qt
sdbHttpsGet ByteString
endpoint = Protocol -> Method -> ByteString -> Int -> SdbConfiguration qt
forall qt.
Protocol -> Method -> ByteString -> Int -> SdbConfiguration qt
SdbConfiguration Protocol
HTTPS Method
Get ByteString
endpoint (Protocol -> Int
defaultPort Protocol
HTTPS)

sdbHttpsPost :: B.ByteString -> SdbConfiguration NormalQuery
sdbHttpsPost :: ByteString -> SdbConfiguration NormalQuery
sdbHttpsPost ByteString
endpoint = Protocol
-> Method -> ByteString -> Int -> SdbConfiguration NormalQuery
forall qt.
Protocol -> Method -> ByteString -> Int -> SdbConfiguration qt
SdbConfiguration Protocol
HTTPS Method
PostQuery ByteString
endpoint (Protocol -> Int
defaultPort Protocol
HTTPS)

sdbSignQuery :: [(B.ByteString, B.ByteString)] -> SdbConfiguration qt -> SignatureData -> SignedQuery
sdbSignQuery :: forall qt.
[(ByteString, ByteString)]
-> SdbConfiguration qt -> SignatureData -> SignedQuery
sdbSignQuery [(ByteString, ByteString)]
q SdbConfiguration qt
si SignatureData
sd
    = SignedQuery {
        sqMethod :: Method
sqMethod = Method
method
      , sqProtocol :: Protocol
sqProtocol = SdbConfiguration qt -> Protocol
forall qt. SdbConfiguration qt -> Protocol
sdbiProtocol SdbConfiguration qt
si
      , sqHost :: ByteString
sqHost = ByteString
host
      , sqPort :: Int
sqPort = SdbConfiguration qt -> Int
forall qt. SdbConfiguration qt -> Int
sdbiPort SdbConfiguration qt
si
      , sqPath :: ByteString
sqPath = ByteString
path
      , sqQuery :: Query
sqQuery = Query
sq
      , sqDate :: Maybe UTCTime
sqDate = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
      , sqAuthorization :: Maybe (IO ByteString)
sqAuthorization = Maybe (IO ByteString)
forall a. Maybe a
Nothing
      , sqContentType :: Maybe ByteString
sqContentType = Maybe ByteString
forall a. Maybe a
Nothing
      , sqContentMd5 :: Maybe (Digest MD5)
sqContentMd5 = Maybe (Digest MD5)
forall a. Maybe a
Nothing
      , sqAmzHeaders :: RequestHeaders
sqAmzHeaders = []
      , sqOtherHeaders :: RequestHeaders
sqOtherHeaders = []
      , sqBody :: Maybe RequestBody
sqBody = Maybe RequestBody
forall a. Maybe a
Nothing
      , sqStringToSign :: ByteString
sqStringToSign = ByteString
stringToSign
      }
    where
      ah :: AuthorizationHash
ah = AuthorizationHash
HmacSHA256
      q' :: Query
q' = [(ByteString, ByteString)] -> Query
forall a. QueryLike a => a -> Query
HTTP.toQuery ([(ByteString, ByteString)] -> Query)
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Ord a => [a] -> [a]
sort ([(ByteString, ByteString)] -> Query)
-> [(ByteString, ByteString)] -> Query
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)]
q [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ (ByteString
"Version", ByteString
"2009-04-15") (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, ByteString)]
queryAuth
      ti :: AbsoluteTimeInfo
ti = SignatureData -> AbsoluteTimeInfo
signatureTimeInfo SignatureData
sd
      cr :: Credentials
cr = SignatureData -> Credentials
signatureCredentials SignatureData
sd
      queryAuth :: [(ByteString, ByteString)]
queryAuth = [case AbsoluteTimeInfo
ti of
                     AbsoluteTimestamp UTCTime
time -> (ByteString
"Timestamp", UTCTime -> ByteString
fmtAmzTime UTCTime
time)
                     AbsoluteExpires   UTCTime
time -> (ByteString
"Expires", UTCTime -> ByteString
fmtAmzTime UTCTime
time)
                  , (ByteString
"AWSAccessKeyId", Credentials -> ByteString
accessKeyID Credentials
cr)
                  , (ByteString
"SignatureMethod", AuthorizationHash -> ByteString
amzHash AuthorizationHash
ah)
                  , (ByteString
"SignatureVersion", ByteString
"2")]
                  [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
-> (ByteString -> [(ByteString, ByteString)])
-> Maybe ByteString
-> [(ByteString, ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ByteString
tok -> [(ByteString
"SecurityToken", ByteString
tok)]) (Credentials -> Maybe ByteString
iamToken Credentials
cr)
      sq :: Query
sq = (ByteString
"Signature", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
sig) (ByteString, Maybe ByteString) -> Query -> Query
forall a. a -> [a] -> [a]
: Query
q'
      method :: Method
method = SdbConfiguration qt -> Method
forall qt. SdbConfiguration qt -> Method
sdbiHttpMethod SdbConfiguration qt
si
      host :: ByteString
host = SdbConfiguration qt -> ByteString
forall qt. SdbConfiguration qt -> ByteString
sdbiHost SdbConfiguration qt
si
      path :: ByteString
path = ByteString
"/"
      sig :: ByteString
sig = Credentials -> AuthorizationHash -> ByteString -> ByteString
signature Credentials
cr AuthorizationHash
ah ByteString
stringToSign
      stringToSign :: ByteString
stringToSign = Builder -> ByteString
Blaze.toByteString (Builder -> ByteString)
-> ([Builder] -> Builder) -> [Builder] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> ByteString) -> [Builder] -> ByteString
forall a b. (a -> b) -> a -> b
$
                     Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
Blaze8.fromChar Char
'\n')
                       [ByteString -> Builder
Blaze.copyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Method -> ByteString
httpMethod Method
method
                       , ByteString -> Builder
Blaze.copyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString
host
                       , ByteString -> Builder
Blaze.copyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString
path
                       , Bool -> Query -> Builder
HTTP.renderQueryBuilder Bool
False Query
q']

sdbResponseConsumer :: (Cu.Cursor -> Response SdbMetadata a)
                    -> IORef SdbMetadata
                    -> HTTPResponseConsumer a
sdbResponseConsumer :: forall a.
(Cursor -> Response SdbMetadata a)
-> IORef SdbMetadata -> HTTPResponseConsumer a
sdbResponseConsumer Cursor -> Response SdbMetadata a
inner IORef SdbMetadata
metadataRef Response (ConduitM () ByteString (ResourceT IO) ())
resp
    = (Cursor -> Response SdbMetadata a)
-> IORef SdbMetadata -> HTTPResponseConsumer a
forall m a.
Monoid m =>
(Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a
xmlCursorConsumer Cursor -> Response SdbMetadata a
parse IORef SdbMetadata
metadataRef Response (ConduitM () ByteString (ResourceT IO) ())
resp
    where parse :: Cursor -> Response SdbMetadata a
parse Cursor
cursor
              = do let requestId' :: Maybe Text
requestId' = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Text -> Cursor -> [Text]
elContent Text
"RequestID"
                   let boxUsage' :: Maybe Text
boxUsage' = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Text -> Cursor -> [Text]
elContent Text
"BoxUsage"
                   SdbMetadata -> Response SdbMetadata ()
forall m. m -> Response m ()
tellMetadata (SdbMetadata -> Response SdbMetadata ())
-> SdbMetadata -> Response SdbMetadata ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Maybe Text -> SdbMetadata
SdbMetadata Maybe Text
requestId' Maybe Text
boxUsage'
                   case Cursor
cursor Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Text -> Cursor -> [Cursor]
Cu.laxElement Text
"Error" of
                     []      -> Cursor -> Response SdbMetadata a
inner Cursor
cursor
                     (Cursor
err:[Cursor]
_) -> Cursor -> Response SdbMetadata a
fromError Cursor
err
          fromError :: Cursor -> Response SdbMetadata a
fromError Cursor
cursor = do ErrorCode
errCode <- ErrorCode -> [ErrorCode] -> Response SdbMetadata ErrorCode
forall (m :: * -> *) a. MonadThrow m => ErrorCode -> [a] -> m a
force ErrorCode
"Missing Error Code" ([ErrorCode] -> Response SdbMetadata ErrorCode)
-> [ErrorCode] -> Response SdbMetadata ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Text -> Cursor -> [ErrorCode]
elCont Text
"Code"
                                ErrorCode
errMessage <- ErrorCode -> [ErrorCode] -> Response SdbMetadata ErrorCode
forall (m :: * -> *) a. MonadThrow m => ErrorCode -> [a] -> m a
force ErrorCode
"Missing Error Message" ([ErrorCode] -> Response SdbMetadata ErrorCode)
-> [ErrorCode] -> Response SdbMetadata ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Text -> Cursor -> [ErrorCode]
elCont Text
"Message"
                                SdbError -> Response SdbMetadata a
forall e a.
(HasCallStack, Exception e) =>
e -> Response SdbMetadata a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (SdbError -> Response SdbMetadata a)
-> SdbError -> Response SdbMetadata a
forall a b. (a -> b) -> a -> b
$ Status -> ErrorCode -> ErrorCode -> SdbError
SdbError (Response (ConduitM () ByteString (ResourceT IO) ()) -> Status
forall body. Response body -> Status
HTTP.responseStatus Response (ConduitM () ByteString (ResourceT IO) ())
resp) ErrorCode
errCode ErrorCode
errMessage

class SdbFromResponse a where
    sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a

sdbCheckResponseType :: MonadThrow m => a -> T.Text -> Cu.Cursor -> m a
sdbCheckResponseType :: forall (m :: * -> *) a. MonadThrow m => a -> Text -> Cursor -> m a
sdbCheckResponseType a
a Text
n Cursor
c = do Cursor
_ <- ErrorCode -> [Cursor] -> m Cursor
forall (m :: * -> *) a. MonadThrow m => ErrorCode -> [a] -> m a
force (ErrorCode
"Expected response type " ErrorCode -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> ErrorCode
T.unpack Text
n) (Text -> Cursor -> [Cursor]
Cu.laxElement Text
n Cursor
c)
                                a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

decodeBase64 :: MonadThrow m => Cu.Cursor -> m T.Text
decodeBase64 :: forall (m :: * -> *). MonadThrow m => Cursor -> m Text
decodeBase64 Cursor
cursor =
  let encoded :: Text
encoded = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Cursor -> [Text]
Cu.content
      encoding :: Maybe Text
encoding = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> a) -> a
$| Text -> Cursor -> [Text]
Cu.laxAttribute Text
"encoding" (Cursor -> [Text]) -> (Text -> Text) -> Cursor -> [Text]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Text -> Text
T.toCaseFold
  in
    case Maybe Text
encoding of
      Maybe Text
Nothing -> Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
encoded
      Just Text
"base64" -> case ByteString -> Either ErrorCode ByteString
Base64.decode (ByteString -> Either ErrorCode ByteString)
-> (Text -> ByteString) -> Text -> Either ErrorCode ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> Either ErrorCode ByteString)
-> Text -> Either ErrorCode ByteString
forall a b. (a -> b) -> a -> b
$ Text
encoded of
                         Left ErrorCode
msg -> XmlException -> m Text
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m Text) -> XmlException -> m Text
forall a b. (a -> b) -> a -> b
$ ErrorCode -> XmlException
XmlException (ErrorCode
"Invalid Base64 data: " ErrorCode -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorCode
msg)
                         Right ByteString
x -> Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
x
      Just Text
actual -> XmlException -> m Text
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m Text) -> XmlException -> m Text
forall a b. (a -> b) -> a -> b
$ ErrorCode -> XmlException
XmlException (ErrorCode
"Unrecognized encoding " ErrorCode -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> ErrorCode
T.unpack Text
actual)

data Attribute a
    = ForAttribute { forall a. Attribute a -> Text
attributeName :: T.Text, forall a. Attribute a -> a
attributeData :: a }
    deriving (Int -> Attribute a -> ShowS
[Attribute a] -> ShowS
Attribute a -> ErrorCode
(Int -> Attribute a -> ShowS)
-> (Attribute a -> ErrorCode)
-> ([Attribute a] -> ShowS)
-> Show (Attribute a)
forall a. Show a => Int -> Attribute a -> ShowS
forall a. Show a => [Attribute a] -> ShowS
forall a. Show a => Attribute a -> ErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Attribute a -> ShowS
showsPrec :: Int -> Attribute a -> ShowS
$cshow :: forall a. Show a => Attribute a -> ErrorCode
show :: Attribute a -> ErrorCode
$cshowList :: forall a. Show a => [Attribute a] -> ShowS
showList :: [Attribute a] -> ShowS
Show)

readAttribute :: MonadThrow m => Cu.Cursor -> m (Attribute T.Text)
readAttribute :: forall (m :: * -> *). MonadThrow m => Cursor -> m (Attribute Text)
readAttribute Cursor
cursor = do
  Text
name <- ErrorCode -> [m Text] -> m Text
forall (m :: * -> *) a. MonadThrow m => ErrorCode -> [m a] -> m a
forceM ErrorCode
"Missing Name" ([m Text] -> m Text) -> [m Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [m Text]) -> [m Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Cursor -> [Cursor]
Cu.laxElement Text
"Name" (Cursor -> [Cursor]) -> (Cursor -> m Text) -> Cursor -> [m Text]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m Text
forall (m :: * -> *). MonadThrow m => Cursor -> m Text
decodeBase64
  Text
value <- ErrorCode -> [m Text] -> m Text
forall (m :: * -> *) a. MonadThrow m => ErrorCode -> [m a] -> m a
forceM ErrorCode
"Missing Value" ([m Text] -> m Text) -> [m Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [m Text]) -> [m Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Cursor -> [Cursor]
Cu.laxElement Text
"Value" (Cursor -> [Cursor]) -> (Cursor -> m Text) -> Cursor -> [m Text]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m Text
forall (m :: * -> *). MonadThrow m => Cursor -> m Text
decodeBase64
  Attribute Text -> m (Attribute Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Attribute Text -> m (Attribute Text))
-> Attribute Text -> m (Attribute Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Attribute Text
forall a. Text -> a -> Attribute a
ForAttribute Text
name Text
value

data SetAttribute
    = SetAttribute { SetAttribute -> Text
setAttribute :: T.Text, SetAttribute -> Bool
isReplaceAttribute :: Bool }
    deriving (Int -> SetAttribute -> ShowS
[SetAttribute] -> ShowS
SetAttribute -> ErrorCode
(Int -> SetAttribute -> ShowS)
-> (SetAttribute -> ErrorCode)
-> ([SetAttribute] -> ShowS)
-> Show SetAttribute
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetAttribute -> ShowS
showsPrec :: Int -> SetAttribute -> ShowS
$cshow :: SetAttribute -> ErrorCode
show :: SetAttribute -> ErrorCode
$cshowList :: [SetAttribute] -> ShowS
showList :: [SetAttribute] -> ShowS
Show)

attributeQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Attribute a -> [(B.ByteString, B.ByteString)]
attributeQuery :: forall a.
(a -> [(ByteString, ByteString)])
-> Attribute a -> [(ByteString, ByteString)]
attributeQuery  a -> [(ByteString, ByteString)]
f (ForAttribute Text
name a
x) =  (ByteString
"Name", Text -> ByteString
T.encodeUtf8 Text
name) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: a -> [(ByteString, ByteString)]
f a
x

addAttribute :: T.Text -> T.Text -> Attribute SetAttribute
addAttribute :: Text -> Text -> Attribute SetAttribute
addAttribute Text
name Text
value = Text -> SetAttribute -> Attribute SetAttribute
forall a. Text -> a -> Attribute a
ForAttribute Text
name (Text -> Bool -> SetAttribute
SetAttribute Text
value Bool
False)

replaceAttribute :: T.Text -> T.Text -> Attribute SetAttribute
replaceAttribute :: Text -> Text -> Attribute SetAttribute
replaceAttribute Text
name Text
value = Text -> SetAttribute -> Attribute SetAttribute
forall a. Text -> a -> Attribute a
ForAttribute Text
name (Text -> Bool -> SetAttribute
SetAttribute Text
value Bool
True)

setAttributeQuery :: SetAttribute -> [(B.ByteString, B.ByteString)]
setAttributeQuery :: SetAttribute -> [(ByteString, ByteString)]
setAttributeQuery (SetAttribute Text
value Bool
replace)
    = (ByteString
"Value", Text -> ByteString
T.encodeUtf8 Text
value) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString
"Replace", ByteString
awsTrue) | Bool
replace]

data DeleteAttribute
    = DeleteAttribute
    | ValuedDeleteAttribute { DeleteAttribute -> Text
deleteAttributeValue :: T.Text }
    deriving (Int -> DeleteAttribute -> ShowS
[DeleteAttribute] -> ShowS
DeleteAttribute -> ErrorCode
(Int -> DeleteAttribute -> ShowS)
-> (DeleteAttribute -> ErrorCode)
-> ([DeleteAttribute] -> ShowS)
-> Show DeleteAttribute
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeleteAttribute -> ShowS
showsPrec :: Int -> DeleteAttribute -> ShowS
$cshow :: DeleteAttribute -> ErrorCode
show :: DeleteAttribute -> ErrorCode
$cshowList :: [DeleteAttribute] -> ShowS
showList :: [DeleteAttribute] -> ShowS
Show)

deleteAttributeQuery :: DeleteAttribute -> [(B.ByteString, B.ByteString)]
deleteAttributeQuery :: DeleteAttribute -> [(ByteString, ByteString)]
deleteAttributeQuery DeleteAttribute
DeleteAttribute = []
deleteAttributeQuery (ValuedDeleteAttribute Text
value) = [(ByteString
"Value", Text -> ByteString
T.encodeUtf8 Text
value)]

data ExpectedAttribute
    = ExpectedValue { ExpectedAttribute -> Text
expectedAttributeValue :: T.Text }
    | ExpectedExists { ExpectedAttribute -> Bool
expectedAttributeExists :: Bool }
    deriving (Int -> ExpectedAttribute -> ShowS
[ExpectedAttribute] -> ShowS
ExpectedAttribute -> ErrorCode
(Int -> ExpectedAttribute -> ShowS)
-> (ExpectedAttribute -> ErrorCode)
-> ([ExpectedAttribute] -> ShowS)
-> Show ExpectedAttribute
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExpectedAttribute -> ShowS
showsPrec :: Int -> ExpectedAttribute -> ShowS
$cshow :: ExpectedAttribute -> ErrorCode
show :: ExpectedAttribute -> ErrorCode
$cshowList :: [ExpectedAttribute] -> ShowS
showList :: [ExpectedAttribute] -> ShowS
Show)

expectedValue :: T.Text -> T.Text -> Attribute ExpectedAttribute
expectedValue :: Text -> Text -> Attribute ExpectedAttribute
expectedValue Text
name Text
value = Text -> ExpectedAttribute -> Attribute ExpectedAttribute
forall a. Text -> a -> Attribute a
ForAttribute Text
name (Text -> ExpectedAttribute
ExpectedValue Text
value)

expectedExists :: T.Text -> Bool -> Attribute ExpectedAttribute
expectedExists :: Text -> Bool -> Attribute ExpectedAttribute
expectedExists Text
name Bool
exists = Text -> ExpectedAttribute -> Attribute ExpectedAttribute
forall a. Text -> a -> Attribute a
ForAttribute Text
name (Bool -> ExpectedAttribute
ExpectedExists Bool
exists)

expectedAttributeQuery :: ExpectedAttribute -> [(B.ByteString, B.ByteString)]
expectedAttributeQuery :: ExpectedAttribute -> [(ByteString, ByteString)]
expectedAttributeQuery (ExpectedValue Text
value) = [(ByteString
"Value", Text -> ByteString
T.encodeUtf8 Text
value)]
expectedAttributeQuery (ExpectedExists Bool
exists) = [(ByteString
"Exists", Bool -> ByteString
awsBool Bool
exists)]

data Item a
    = Item { forall a. Item a -> Text
itemName :: T.Text, forall a. Item a -> a
itemData :: a }
    deriving (Int -> Item a -> ShowS
[Item a] -> ShowS
Item a -> ErrorCode
(Int -> Item a -> ShowS)
-> (Item a -> ErrorCode) -> ([Item a] -> ShowS) -> Show (Item a)
forall a. Show a => Int -> Item a -> ShowS
forall a. Show a => [Item a] -> ShowS
forall a. Show a => Item a -> ErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> ErrorCode) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Item a -> ShowS
showsPrec :: Int -> Item a -> ShowS
$cshow :: forall a. Show a => Item a -> ErrorCode
show :: Item a -> ErrorCode
$cshowList :: forall a. Show a => [Item a] -> ShowS
showList :: [Item a] -> ShowS
Show)

readItem :: MonadThrow m => Cu.Cursor -> m (Item [Attribute T.Text])
readItem :: forall (m :: * -> *).
MonadThrow m =>
Cursor -> m (Item [Attribute Text])
readItem Cursor
cursor = do
  Text
name <- ErrorCode -> [Text] -> m Text
forall (m :: * -> *) a. MonadThrow m => ErrorCode -> [a] -> m a
force ErrorCode
"Missing Name" ([Text] -> m Text) -> ([m Text] -> m [Text]) -> [m Text] -> m Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [m Text] -> m [Text]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m Text] -> m Text) -> [m Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [m Text]) -> [m Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Cursor -> [Cursor]
Cu.laxElement Text
"Name" (Cursor -> [Cursor]) -> (Cursor -> m Text) -> Cursor -> [m Text]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m Text
forall (m :: * -> *). MonadThrow m => Cursor -> m Text
decodeBase64
  [Attribute Text]
attributes <- [m (Attribute Text)] -> m [Attribute Text]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m (Attribute Text)] -> m [Attribute Text])
-> [m (Attribute Text)] -> m [Attribute Text]
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [m (Attribute Text)]) -> [m (Attribute Text)]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Cursor -> [Cursor]
Cu.laxElement Text
"Attribute" (Cursor -> [Cursor])
-> (Cursor -> m (Attribute Text)) -> Cursor -> [m (Attribute Text)]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m (Attribute Text)
forall (m :: * -> *). MonadThrow m => Cursor -> m (Attribute Text)
readAttribute
  Item [Attribute Text] -> m (Item [Attribute Text])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Item [Attribute Text] -> m (Item [Attribute Text]))
-> Item [Attribute Text] -> m (Item [Attribute Text])
forall a b. (a -> b) -> a -> b
$ Text -> [Attribute Text] -> Item [Attribute Text]
forall a. Text -> a -> Item a
Item Text
name [Attribute Text]
attributes

itemQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Item a -> [(B.ByteString, B.ByteString)]
itemQuery :: forall a.
(a -> [(ByteString, ByteString)])
-> Item a -> [(ByteString, ByteString)]
itemQuery a -> [(ByteString, ByteString)]
f (Item Text
name a
x) = (ByteString
"ItemName", Text -> ByteString
T.encodeUtf8 Text
name) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: a -> [(ByteString, ByteString)]
f a
x