path: root/dht/Presence/Stanza/Parse.hs

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 $ lookupAttrib "node" $ tagAttrs tag
        "{http://jabber.org/protocol/disco#info}query"
                                  -> return $ RequestInfo $ lookupAttrib "node" $ tagAttrs tag
        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 -> -- Note: Possibly join-chat stanza.
                   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,
        msgType    = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
    }

parseMessageType :: Maybe Text -> MessageType
parseMessageType (Just "chat")      = ChatMsg
parseMessageType (Just "groupchat") = GroupChatMsg
parseMessageType (Just "headline")  = HeadlineMsg
parseMessageType _                  = NormalMsg

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