module Cloud.AWS.Lib.Parser.Unordered
( SimpleXML (..)
, ParseError (..)
, xmlParser
, xmlParserM
, xmlParserConduit
, getT, (.<)
, getElementM
, getElement
, getElements
) where
import Control.Applicative
import Control.Exception (Exception)
import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.XML.Types
import Text.XML.Stream.Parse
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HM
import Cloud.AWS.Lib.FromText
data SimpleXML = Map (HashMap Text [SimpleXML])
| Content Text
deriving (Show)
data ParseError = ParseError
{ parseErrorMessage :: Text
} deriving (Show, Typeable)
instance Exception ParseError
xmlParser :: MonadThrow m
=> (SimpleXML -> m a)
-> ConduitM Event o m a
xmlParser parse = xmlParserM parse >>=
maybe (lift $ monadThrow $ ParseError "xmlParser: invalid xml") return
xmlParserM :: MonadThrow m
=> (SimpleXML -> m a)
-> ConduitM Event o m (Maybe a)
xmlParserM parse = do
xmlm <- getXML
case xmlm of
Just xml -> lift $ liftM Just $ parse xml
Nothing -> return Nothing
xmlParserConduit :: MonadThrow m
=> Text
-> (SimpleXML -> m a)
-> Conduit Event m a
xmlParserConduit set parse = do
e <- dropWS
case e of
Just (EventBeginElement name _) | nameLocalName name == set -> do
CL.drop 1
innerParser parse
_ -> monadThrow $ ParseError $ "xmlParserConduit: no element '" <> set <> "'"
where
innerParser parse' = do
ma <- xmlParserM parse'
case ma of
Just a -> yield a >> innerParser parse'
Nothing -> return ()
getXML :: MonadThrow m
=> ConduitM Event o m (Maybe SimpleXML)
getXML = do
e <- dropWS
case e of
Just (EventBeginElement name _) -> do
CL.drop 1
xmls <- getXMLList
let xml = Map $ HM.singleton (nameLocalName name) $ case xmls of
[Content _] -> xmls
_ -> [Map $ foldr (HM.unionWith (++) . toHMap) HM.empty xmls]
e' <- dropWS
case e' of
Just (EventEndElement name')
| name == name' -> CL.drop 1 >> return (Just xml)
_ -> lift $ monadThrow $ XmlException ("Expected end tag: " ++ show name) e'
Just (EventContent (ContentText t)) -> CL.drop 1 >> return (Just $ Content t)
_ -> return Nothing
where
getXMLList = do
e <- dropWS
case e of
Just EventEndElement{} -> return []
_ -> do
xml <- getXML
case xml of
Just xml' -> (xml' :) <$> getXMLList
Nothing -> return []
toHMap (Map hmap) = hmap
toHMap _ = error "toHMap: invalid structure"
dropWS :: Monad m => ConduitM Event o m (Maybe Event)
dropWS = do
e <- CL.peek
if isWS e then CL.drop 1 >> dropWS else return e
where
isWS e = case e of
Just EventBeginDocument -> True
Just EventEndDocument -> True
Just EventBeginDoctype{} -> True
Just EventEndDoctype -> True
Just EventInstruction{} -> True
Just EventBeginElement{} -> False
Just EventEndElement{} -> False
Just (EventContent (ContentText t))
| T.all isSpace t -> True
| otherwise -> False
Just (EventContent ContentEntity{}) -> False
Just EventComment{} -> True
Just EventCDATA{} -> False
Nothing -> False
fromMaybeM :: Monad m => m a -> Maybe a -> m a
fromMaybeM a Nothing = a
fromMaybeM _ (Just a) = return a
getContentText :: SimpleXML -> Maybe Text
getContentText (Map _) = Nothing
getContentText (Content c) = return c
getSubXMLs :: SimpleXML -> Text -> [SimpleXML]
getSubXMLs (Map hmap) name = cat $ HM.lookup name hmap
where
cat (Just xs) = xs
cat Nothing = []
getSubXMLs (Content _) _ = []
getSubXMLM :: SimpleXML -> Text -> Maybe SimpleXML
getSubXMLM xml name = listToMaybe $ getSubXMLs xml name
getT :: (MonadThrow m, FromText a) => SimpleXML -> Text -> m a
getT xml name = fromNamedText name $
getSubXMLM xml name >>= getContentText
(.<) :: (MonadThrow m, FromText a) => SimpleXML -> Text -> m a
(.<) = getT
getElementM :: MonadThrow m => SimpleXML -> Text -> (SimpleXML -> m a) -> m (Maybe a)
getElementM xml name parse = case getSubXMLM xml name of
Just xml' -> liftM Just $ parse xml'
Nothing -> return Nothing
getElement :: MonadThrow m => SimpleXML -> Text -> (SimpleXML -> m a) -> m a
getElement xml name parse = getElementM xml name parse >>=
fromMaybeM (monadThrow $ ParseError $ "getElement: element '" <> name <> "' not found")
getElements :: MonadThrow m => SimpleXML -> Text -> Text -> (SimpleXML -> m a) -> m [a]
getElements xml set item parse = case getSubXMLM xml set of
Just xml' -> mapM parse $ getSubXMLs xml' item
Nothing -> return []