module Stanza.Parse (grokStanza,errorTagLocalName) where import Control.Concurrent.STM import Control.Monad import Data.Char import Data.Function import Data.Maybe import qualified Data.Text as Text (pack, unpack, words) ;import Data.Text (Text) import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Map as Map import Data.XML.Types as XML import qualified Text.XML.Stream.Parse as XML import Control.Concurrent.STM.Util import ControlMaybe (handleIO_, (<&>)) import EventUtil import Nesting import Stanza.Types -- | Identify an XMPP stanza based on the open-tag. grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType) grokStanza "jabber:server" stanzaTag = case () of _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag _ -> return $ Just Unrecognized grokStanza "jabber:client" stanzaTag = case () of _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag _ -> return $ Just Unrecognized grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType) grokStanzaIQGet stanza = do mtag <- nextElement forM mtag $ \tag -> do case tagName tag of "{urn:xmpp:ping}ping" -> return Ping "{jabber:iq:roster}query" -> return RequestRoster "{http://jabber.org/protocol/disco#items}query" -> return RequestItems "{http://jabber.org/protocol/disco#info}query" -> return RequestInfo name -> return $ UnrecognizedQuery name grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType) grokStanzaIQResult stanza = do mtag <- nextElement fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do case tagName tag of "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client" -> parseClientVersion "{http://jabber.org/protocol/disco#items}query" -> return $ Just Items "{http://jabber.org/protocol/disco#info}query" -> return $ Just Info _ -> return Nothing grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType) grokStanzaIQSet stanza = do mtag <- nextElement case tagName <$> mtag of Just "{urn:ietf:params:xml:ns:xmpp-bind}bind" -> do mchild <- nextElement case tagName <$> mchild of Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do rsc <- XML.content -- TODO: MonadThrow??? return . Just $ RequestResource Nothing (Just rsc) Just _ -> return Nothing Nothing -> return . Just $ RequestResource Nothing Nothing Just "{urn:ietf:params:xml:ns:xmpp-session}session" -> return $ Just SessionRequest _ -> return Nothing grokPresence :: ( MonadThrow m , MonadIO m ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType) grokPresence ns stanzaTag = do let typ = lookupAttrib "type" (tagAttrs stanzaTag) case typ of Nothing -> parsePresenceStatus ns stanzaTag Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline})) $ parsePresenceStatus ns stanzaTag Just "error" -> return . Just $ PresenceInformError Just "unsubscribed" -> return . Just $ PresenceInformSubscription False Just "subscribed" -> return . Just $ PresenceInformSubscription True Just "probe" -> return . Just $ PresenceRequestStatus Just "unsubscribe" -> return . Just $ PresenceRequestSubscription False Just "subscribe" -> return . Just $ PresenceRequestSubscription True _ -> return Nothing grokMessage :: ( MonadThrow m , MonadIO m ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType) grokMessage ns stanzaTag = do let typ = lookupAttrib "type" (tagAttrs stanzaTag) case typ of Just "error" -> do mb <- findErrorTag ns return $ do e <- mb return $ Error e stanzaTag _ -> do t <- parseMessage ns stanzaTag return $ Just t parseClientVersion :: NestingXML o IO (Maybe StanzaType) parseClientVersion = parseit Nothing Nothing where reportit mname mver = return $ do name <- mname ver <- mver return NotifyClientVersion { versionName=name, versionVersion=ver } parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType) parseit mname mver = do mtag <- nextElement fromMaybe (reportit mname mver) $ mtag <&> \tag -> do case tagName tag of "{jabber:iq:version}name" -> do x <- XML.content parseit (Just x) mver "{jabber:iq:version}version" -> do x <- XML.content parseit mname (Just x) _ -> parseit mname mver parsePresenceStatus :: ( MonadThrow m , MonadIO m ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType) parsePresenceStatus ns stanzaTag = do let toStat "away" = Away toStat "xa" = ExtendedAway toStat "dnd" = DoNotDisturb toStat "chat" = Chatty showv <- liftIO . atomically $ newTVar Available priov <- liftIO . atomically $ newTVar Nothing statusv <- liftIO . atomically $ newTChan fix $ \loop -> do mtag <- nextElement forM_ mtag $ \tag -> do when (nameNamespace (tagName tag) == Just ns) $ do case nameLocalName (tagName tag) of "show" -> do t <- XML.content liftIO . atomically $ writeTVar showv (toStat t) "priority" -> do t <- XML.content liftIO . handleIO_ (return ()) $ do prio <- readIO (Text.unpack t) atomically $ writeTVar priov (Just prio) "status" -> do t <- XML.content lang <- xmlLang ioWriteChan statusv (maybe "" id lang,t) _ -> return () loop show <- liftIO . atomically $ readTVar showv prio <- liftIO . atomically $ readTVar priov status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to -- avoid multiple passes, but whatever. let wlist = do w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag) Text.words w return . Just $ PresenceStatus { presenceShow = show , presencePriority = prio , presenceStatus = status , presenceWhiteList = wlist } parseMessage :: ( MonadThrow m , MonadIO m ) => Text -> XML.Event -> NestingXML o m StanzaType parseMessage ns stanza = do let bodytag = Name { nameNamespace = Just ns , nameLocalName = "body" , namePrefix = Nothing } subjecttag = Name { nameNamespace = Just ns , nameLocalName = "subject" , namePrefix = Nothing } threadtag = Name { nameNamespace = Just ns , nameLocalName = "thread" , namePrefix = Nothing } let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing } parseChildren (th,cmap) = do child <- nextElement lvl <- nesting xmllang <- xmlLang let lang = maybe "" id xmllang let c = maybe emptyMsg id (Map.lookup lang cmap) -- log $ " child: "<> bshow child case child of Just tag | tagName tag==bodytag -> do txt <- XML.content awaitCloser lvl parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap) Just tag | tagName tag==subjecttag -> do txt <- XML.content awaitCloser lvl parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap) Just tag | tagName tag==threadtag -> do txt <- XML.content awaitCloser lvl parseChildren (th {msgThreadContent=txt},cmap) Just tag -> do -- let nm = tagName tag -- attrs = tagAttrs tag -- -- elems = msgElements c -- txt <- XML.content awaitCloser lvl parseChildren (th,Map.insert lang c cmap) Nothing -> return (th,cmap) (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""} , Map.empty ) return Message { msgLangMap = Map.toList langmap, msgThread = if msgThreadContent th/="" then Just th else Nothing } findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError) findErrorTag ns = do x <- nextElement fmap join $ forM x $ \x -> case tagName x of n | nameNamespace n==Just ns && nameLocalName n=="error" -> do mtag <- findConditionTag return $ do tag <- {- trace ("mtag = "++show mtag) -} mtag let t = nameLocalName (tagName tag) conditionFromText t _ -> findErrorTag ns findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event) findConditionTag = do mx <- nextElement fmap join $ forM mx $ \x -> do case nameNamespace (tagName x) of Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x) _ -> findConditionTag conditionFromText :: Text -> Maybe StanzaError conditionFromText t = fmap fst $ listToMaybe ss where es = [BadRequest .. UnexpectedRequest] ts = map (\e->(e,errorTagLocalName e)) es ss = dropWhile ((/=t) . snd) ts -- | Converts a CamelCase constructor to a hyphenated lower-case name for use -- as an xml tag. errorTagLocalName :: StanzaError -> Text errorTagLocalName e = Text.pack . drop 1 $ do c <- show e if 'A' <= c && c <= 'Z' then [ '-', chr( ord c - ord 'A' + ord 'a') ] else return c