1 files changed, 52 insertions, 1 deletions

diff --git a/XMPPToTox.hs b/XMPPToTox.hs
index ae9a774b..f0505ac7 100644
--- a/XMPPToTox.hs
+++ b/XMPPToTox.hs
@@ -14,10 +14,13 @@ import Data.Function
 import Data.Monoid
 import Data.Text                    (Text)
 import Data.Text.Encoding           as T
+import Data.Word
 import Data.XML.Types               as XML
 import Network.Tox.Crypto.Transport (CryptoMessage (..), MessageID (..))
 import Text.XML.Stream.Parse        as XML
 
+import XMPPServer (JabberShow(..))
+
 -- Debugging.  Not real Tox message.
 funnyMessage :: MonadThrow m => Text -> ConduitM i CryptoMessage m ()
 funnyMessage txt = yield $ UpToN Padding (T.encodeUtf8 txt)
@@ -53,6 +56,53 @@ msgToTox = tag' "{jabber:server}message"
     , ignoreAnyTreeContent
     ]
 
+readJabberShow :: Text -> JabberShow
+readJabberShow "xa"   = ExtendedAway
+readJabberShow "chat" = Chatty
+readJabberShow "away" = Away
+readJabberShow "dnd"  = DoNotDisturb
+readJabberShow _      = Available
+
+-- | Convert XMPP "show" field to Tox USERSTATUS.
+jabberUserStatus :: JabberShow -> Word8
+jabberUserStatus Available    = 0
+jabberUserStatus Chatty       = 0
+jabberUserStatus Away         = 1
+jabberUserStatus ExtendedAway = 1
+jabberUserStatus Offline      = 1
+jabberUserStatus DoNotDisturb = 2
+
+
+requireMissing :: XML.Name -> AttrParser ()
+requireMissing nm = force ("Unexpected "++show (XML.nameLocalName nm)++" attribute.") $ do
+    m <- attr nm
+    case m of
+        Nothing -> return $ Just ()
+        Just _  -> return Nothing
+
+presenceToTox :: MonadThrow m =>
+                  ConduitM Event CryptoMessage m (Maybe ())
+presenceToTox = tag' "{jabber:server}presence"
+                     (requireMissing "type" >> ignoreAttrs)
+  $ \_ -> do
+    xs <- XML.many $ choose
+        [ tagIgnoreAttrs "{jabber:server}show"
+           $ do shw <- readJabberShow <$> content
+                yield $ TwoByte USERSTATUS $ jabberUserStatus shw
+                eom
+                return USERSTATUS
+        , tagIgnoreAttrs "{jabber:server}status"
+           -- TODO: The <status> tag may occur multiple times for different "xml:lang" values.
+           $ do txt <- content
+                yield $ UpToN STATUSMESSAGE $ T.encodeUtf8 txt
+                eom
+                return STATUSMESSAGE
+        , fmap (const Padding) <$> ignoreAnyTreeContent -- Ignore the priority tag and anything else.
+        ]
+    when (not $ USERSTATUS `elem` xs) $ do
+        -- Missing <show> element means Available.
+        yield $ TwoByte USERSTATUS $ jabberUserStatus Available
+
 unknownToTox :: MonadThrow m =>
                       ConduitM Event CryptoMessage m (Maybe ())
 unknownToTox = tag anyName (\n -> ignoreAttrs >> return n) $ \n -> do
@@ -60,13 +110,14 @@ unknownToTox = tag anyName (\n -> ignoreAttrs >> return n) $ \n -> do
     eom
 
 
-xmppToTox :: MonadThrow m => Conduit XML.Event m CryptoMessage
+xmppToTox :: MonadThrow m => ConduitM XML.Event CryptoMessage m ()
 xmppToTox = do
     eventBeginDocument <- await
     streamTag <- await
     fix $ \loop -> do
         got <- choose
             [ msgToTox
+            , presenceToTox
             , unknownToTox
             ]
         forM_ got $ \_ -> loop