module Network.AWS.Data.Internal.XML
(
FromXML (..)
, decodeXML
, parseXMLText
, childNodes
, findElement
, withContent
, withElement
, localName
, (.@)
, (.@?)
, (.!@)
, ToXML (..)
, ToXMLRoot (..)
, encodeXML
, toXMLText
, namespaced
, element
, nodes
, (=@)
, unsafeToXML
) where
import Control.Applicative
import Control.Monad
import Data.Default.Class
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import Network.AWS.Data.Internal.ByteString
import Network.AWS.Data.Internal.Text
import Numeric.Natural
import Text.XML
decodeXML :: LazyByteString -> Either String [Node]
decodeXML = either failure success . parseLBS def
where
failure = Left . show
success = Right . elementNodes . documentRoot
encodeXML :: ToXMLRoot a => a -> LazyByteString
encodeXML x = renderLBS def d
where
d = Document
{ documentPrologue = p
, documentRoot = toXMLRoot x
, documentEpilogue = []
}
p = Prologue
{ prologueBefore = []
, prologueDoctype = Nothing
, prologueAfter = []
}
parseXMLText :: FromText a => String -> [Node] -> Either String a
parseXMLText n = withContent n >=> maybe err fromText
where
err = Left $ "empty node list, when expecting single node " ++ n
toXMLText :: ToText a => a -> [Node]
toXMLText x = [NodeContent (toText x)]
(.@) :: FromXML a => [Node] -> Text -> Either String a
ns .@ n = findElement n ns >>= parseXML
(.@?) :: FromXML a => [Node] -> Text -> Either String (Maybe a)
ns .@? n =
case findElement n ns of
Left _ -> Right Nothing
Right xs -> parseXML xs
(.!@) :: Either String (Maybe a) -> a -> Either String a
f .!@ x = fromMaybe x <$> f
namespaced :: Text -> Text -> [Node] -> Element
namespaced g l = element (Name l (Just g) Nothing)
element :: Name -> [Node] -> Element
element n = Element n mempty
nodes :: Name -> [Node] -> [Node]
nodes n ns = [NodeElement (element n ns)]
(=@) :: ToXML a => Name -> a -> Node
n =@ x = NodeElement (element n (toXML x))
unsafeToXML :: (Show a, ToXML a) => a -> Node
unsafeToXML x =
fromMaybe (error $ "Failed to unflatten node-list for: " ++ show x)
(listToMaybe (toXML x))
withContent :: String -> [Node] -> Either String (Maybe Text)
withContent n = exactly >=> \case
Just x -> Just <$> content x
Nothing -> return Nothing
where
exactly :: [Node] -> Either String (Maybe Node)
exactly = \case
[x] -> Right (Just x)
[] -> Right Nothing
_ -> Left $
"encountered node list, when expecting exactly one node: " ++ n
content :: Node -> Either String Text
content (NodeContent x)
= Right x
content (NodeElement e)
= let k = show (elementName e)
in Left $ "unexpected element " ++ k ++ ", when expecting node content: " ++ n
content _ = Left $ "unrecognised element, when expecting node content: " ++ n
withElement :: Text -> ([Node] -> Either String a) -> [Node] -> Either String a
withElement n f = findElement n >=> f
findElement :: Text -> [Node] -> Either String [Node]
findElement n ns = maybe err Right . listToMaybe $ mapMaybe (childNodes n) ns
where
err = Left $ "unable to find element "
++ show n
++ " in nodes "
++ show (mapMaybe localName ns)
childNodes :: Text -> Node -> Maybe [Node]
childNodes n (NodeElement e)
| nameLocalName (elementName e) == n = Just (elementNodes e)
childNodes _ _ = Nothing
localName :: Node -> Maybe Text
localName (NodeElement e) = Just (nameLocalName (elementName e))
localName _ = Nothing
class FromXML a where
parseXML :: [Node] -> Either String a
instance FromXML a => FromXML (Maybe a) where
parseXML [] = pure Nothing
parseXML ns = Just <$> parseXML ns
instance FromXML Text where
parseXML = withContent "Text" >=> fromText . fromMaybe mempty
instance FromXML Int where parseXML = parseXMLText "Int"
instance FromXML Integer where parseXML = parseXMLText "Integer"
instance FromXML Natural where parseXML = parseXMLText "Natural"
instance FromXML Double where parseXML = parseXMLText "Double"
instance FromXML Bool where parseXML = parseXMLText "Bool"
class ToXMLRoot a where
toXMLRoot :: a -> Element
class ToXML a where
toXML :: a -> [Node]
default toXML :: ToXMLRoot a => a -> [Node]
toXML = (:[]) . NodeElement . toXMLRoot
instance ToXML a => ToXML (Maybe a) where
toXML (Just x) = toXML x
toXML Nothing = []
instance ToXML Text where toXML = toXMLText
instance ToXML Int where toXML = toXMLText
instance ToXML Integer where toXML = toXMLText
instance ToXML Natural where toXML = toXMLText
instance ToXML Double where toXML = toXMLText
instance ToXML Bool where toXML = toXMLText