1 files changed, 81 insertions, 13 deletions

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 8b2544d7..7208a1d1 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -5,26 +5,41 @@
 {-# LANGUAGE ViewPatterns             #-}
 module ToxToXMPP where
 
+import Control.Monad
 import Crypto.Tox
 import Data.Conduit                 as C
 import qualified Data.Conduit.List  as CL
+import Data.Function
 import Data.Monoid
 import qualified Data.Text          as T
          ;import Data.Text          (Text)
-import Data.Word
 import Data.Text.Encoding           as T
+import Data.Word
 import Data.XML.Types               as XML
 import EventUtil
 import Network.Address
-import Network.Tox.Crypto.Transport as Tox
+import Network.Tox.Crypto.Transport as Tox hiding (UserStatus (..))
 import Network.Tox.NodeId
 import Util                         (unsplitJID)
 import XMPPServer                   as XMPP
 
+available :: StanzaType
+available = PresenceStatus { presenceShow      = Available
+                           , presencePriority  = Nothing
+                           , presenceStatus    = []
+                           , presenceWhiteList = []
+                           }
+
 xmppHostname :: PublicKey -> Text
 xmppHostname k = T.pack $ show (key2id k) ++ ".tox"
 
-toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event
+toxUserStatus :: Word8 -> JabberShow
+toxUserStatus 0 = Available
+toxUserStatus 1 = Away
+toxUserStatus 2 = DoNotDisturb
+toxUserStatus _ = Away -- Default, shouldn't occur.
+
+toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> ConduitM Tox.CryptoMessage XML.Event m ()
 toxToXmpp laddr me theirhost = do
     CL.sourceList $ XMPP.greet' "jabber:server" theirhost
     let me_u    = Nothing
@@ -35,29 +50,82 @@ toxToXmpp laddr me theirhost = do
                             -- /to/ should match local address of this node.
                             , me_h
                             , Nothing))
-    awaitForever $ \case
+    let
+      statelessMessages = \case
 
-        UpToN { msgID    = MESSAGE
-              , msgBytes = bs      }
-               -> do
+        UpToN MESSAGE bs ->
             xmppInstantMessage "jabber:server" im_from im_to [] (T.decodeUtf8 bs)
 
         TwoByte TYPING st -> xmppTyping "jabber:server" im_from im_to st
 
+        UpToN NICKNAME bs ->
+            xmppInstantMessage "jabber:server" im_from im_to
+                [ attr "style" "font-weight:bold; color:red" ]
+                ("NICKNAME(todo) " <> T.decodeUtf8 bs)
+
         toxmsg | msgID toxmsg == PacketRequest -> return ()
 
         toxmsg -> do
-            xmppInstantMessage "jabber:server"
-                im_from
-                im_to  -- /to/ should match local address of this node.
+            xmppInstantMessage "jabber:server" im_from im_to
                 [ attr "style" "font-weight:bold; color:red" ]
-                (T.pack $ show $ msgID toxmsg)
+                (T.pack $ "Unhandled message: " ++ show (msgID toxmsg))
+
+    flip fix available $ \loop status -> do
+        let go (TwoByte USERSTATUS st) = do
+                let status' = status { presenceShow = toxUserStatus st }
+                xmppPresence "jabber:server" im_from status'
+                loop status'
+
+            go (UpToN STATUSMESSAGE bs) = do
+                let status' = status { presenceStatus = [("",T.decodeUtf8 bs)] }
+                xmppPresence "jabber:server" im_from status'
+                loop status'
+
+            go (OneByte ONLINE) = do
+                xmppPresence "jabber:server" im_from status
+                loop status
+
+            go x = do
+                statelessMessages x
+                loop status
+        await >>= mapM_ go
+
+xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m ()
+xmppPresence namespace mjid p = do
+    let ns n = n { nameNamespace = Just namespace }
+        setFrom = maybe id
+                        (\jid -> (attr "from" jid :) )
+                        mjid
+        typ Offline = [attr "type" "unavailable"]
+        typ _       = []
+        shw ExtendedAway = ["xa"]
+        shw Chatty       = ["chat"]
+        shw Away         = ["away"]
+        shw DoNotDisturb = ["dnd"]
+        shw _            = []
+        jabberShow stat =
+          [ EventBeginElement "{jabber:client}show" []
+          , EventContent (ContentText stat)
+          , EventEndElement "{jabber:client}show" ]
+    C.yield       $ EventBeginElement (ns "presence") (setFrom $ typ $ presenceShow p)
+    mapM_ C.yield $ shw (presenceShow p) >>= jabberShow
+    forM_ (presencePriority p) $ \prio -> do
+        C.yield   $ EventBeginElement (ns "priority") []
+        C.yield   $   EventContent $ ContentText (T.pack $ show prio)
+        C.yield   $ EventEndElement (ns "priority")
+    forM_ (presenceStatus p) $ \(lang,txt) -> do
+        let atts | T.null lang = []
+                 | otherwise   = [ ("xml:lang", [ContentText lang]) ]
+        C.yield   $ EventBeginElement (ns "status") atts
+        C.yield   $   EventContent $ ContentText txt
+        C.yield   $ EventEndElement (ns "status")
+    C.yield       $ EventEndElement (ns "presence")
 
 xmppTyping :: Monad m => Text
                               -> Maybe Text
                               -> Maybe Text
                               -> Word8
-                              -> ConduitM i Event m ()
+                              -> ConduitM i XML.Event m ()
 xmppTyping namespace mfrom mto x =
     let ns n = n { nameNamespace = Just namespace }
         st = case x of
@@ -80,7 +148,7 @@ xmppInstantMessage :: Monad m => Text
                               -> Maybe Text
                               -> [(Name, [Content])]
                               -> Text
-                              -> ConduitM i Event m ()
+                              -> ConduitM i XML.Event m ()
 xmppInstantMessage namespace mfrom mto style text = do
     let ns n = n { nameNamespace = Just namespace }
     C.yield $ EventBeginElement (ns "message")