module Network.AWS.Data.XML where
import Control.Applicative
import Control.Monad
import Data.Bifunctor
import qualified Data.ByteString.Lazy as LBS
import Data.Conduit
import Data.Conduit.Lazy (lazyConsume)
import qualified Data.Conduit.List as Conduit
import Data.Maybe
import Data.Monoid
import Data.Traversable (traverse)
import Data.XML.Types (Event (..))
import GHC.Exts
import Network.AWS.Data.ByteString
import Network.AWS.Data.Text
import Numeric.Natural
import System.IO.Unsafe (unsafePerformIO)
import Text.XML
import qualified Text.XML.Stream.Render as Stream
import Text.XML.Unresolved (toEvents)
import Prelude
infixl 7 .@, .@?
(.@) :: 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
infixr 7 @=
(@=) :: ToXML a => Name -> a -> XML
n @= x =
case toXML x of
XNull -> XNull
xs -> XOne . NodeElement $ mkElement n xs
decodeXML :: FromXML a => LazyByteString -> Either String a
decodeXML = either failure success . parseLBS def
where
failure = Left . show
success = parseXML . elementNodes . documentRoot
encodeXML :: ToElement a => a -> LazyByteString
encodeXML x = LBS.fromChunks . unsafePerformIO . lazyConsume
$ Conduit.sourceList (toEvents doc)
=$= Conduit.map rename
=$= Stream.renderBytes def
where
doc = toXMLDocument $ Document
{ documentRoot = root
, documentEpilogue = []
, documentPrologue =
Prologue
{ prologueBefore = []
, prologueDoctype = Nothing
, prologueAfter = []
}
}
rename = \case
EventBeginElement n xs -> EventBeginElement (f n) (map (first f) xs)
EventEndElement n -> EventEndElement (f n)
evt -> evt
where
f n | isNothing (nameNamespace n) = n { nameNamespace = ns }
| otherwise = n
ns = nameNamespace (elementName root)
root = toElement x
class FromXML a where
parseXML :: [Node] -> Either String a
instance FromXML [Node] where
parseXML = pure
instance FromXML a => FromXML (Maybe a) where
parseXML [] = pure Nothing
parseXML ns = Just <$> parseXML ns
instance FromXML Text where
parseXML = fmap (fromMaybe mempty) . withContent "Text"
instance FromXML Char where parseXML = parseXMLText "Char"
instance FromXML ByteString where parseXML = parseXMLText "ByteString"
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 ToElement a where
toElement :: a -> Element
instance ToElement Element where
toElement = id
data XML
= XNull
| XOne Node
| XMany [Node]
deriving (Show)
instance Monoid XML where
mempty = XNull
mappend XNull XNull = XNull
mappend a b = XMany (listXMLNodes a <> listXMLNodes b)
listXMLNodes :: XML -> [Node]
listXMLNodes = \case
XNull -> []
XOne n -> [n]
XMany ns -> ns
class ToXML a where
toXML :: a -> XML
toXMLNodes :: ToXML a => a -> [Node]
toXMLNodes = listXMLNodes . toXML
instance ToXML XML where
toXML = id
instance ToXML a => ToXML (Maybe a) where
toXML (Just x) = toXML x
toXML Nothing = XNull
instance ToXML Text where toXML = toXMLText
instance ToXML ByteString 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
parseXMLList :: FromXML a
=> Text
-> [Node]
-> Either String [a]
parseXMLList n = traverse parseXML . mapMaybe (childNodesOf n)
parseXMLText :: FromText a => String -> [Node] -> Either String a
parseXMLText n = withContent n >=>
maybe (Left $ "empty node list, when expecting single node " ++ n)
fromText
toXMLList :: (IsList a, ToXML (Item a)) => Name -> a -> XML
toXMLList n = XMany . map (NodeElement . mkElement n) . toList
toXMLText :: ToText a => a -> XML
toXMLText = XOne . NodeContent . toText
mkElement :: ToXML a => Name -> a -> Element
mkElement n = Element n mempty . listXMLNodes . toXML
withContent :: String -> [Node] -> Either String (Maybe Text)
withContent k = \case
[] -> Right Nothing
[NodeContent x] -> Right (Just x)
_ -> Left $ "encountered many nodes, when expecting text: " ++ k
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 (Left missing) Right . listToMaybe $ mapMaybe (childNodesOf n) ns
where
missing = "unable to find element "
++ show n
++ " in nodes "
++ show (mapMaybe localName ns)
childNodesOf :: Text -> Node -> Maybe [Node]
childNodesOf n x = case x of
NodeElement e
| Just n' <- localName x
, n == n' -> Just (elementNodes e)
_ -> Nothing
localName :: Node -> Maybe Text
localName = \case
NodeElement e -> Just (nameLocalName (elementName e))
_ -> Nothing