tox-to-xmpp: presence updates.

2 files changed, 100 insertions, 18 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 4ca49f78..59926d13 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -178,7 +178,7 @@ data LocalPresence = LocalPresence
     }
 
 data RemotePresence = RemotePresence
-    { resources :: Map Text Stanza
+    { resources :: Map ResourceName Stanza
     -- , localSubscribers :: Map Text ()
     -- ^ subset of clientsByUser who should be
     -- notified about this presence.
@@ -764,7 +764,14 @@ informPeerPresence state k stanza = do
     -- Presence must indicate full JID with resource...
     dput XJabber $ "xmppInformPeerPresence checking from address..."
     forM_ (stanzaFrom stanza) $ \from -> do
-    let (muser,h,mresource) = splitJID from
+    let (muser0,h,mresource0) = splitJID from
+        -- We'll allow the case that user and resource are simultaneously
+        -- absent.  They will be stored in the remotesByPeer map using the
+        -- empty string.  This is to accomodate the tox protocol which didn't
+        -- anticipate a single peer would have multiple users or front-ends.
+        (muser,mresource) = case (muser0,mresource0) of
+            (Nothing,Nothing) -> (Just "", Just "")
+            _                 -> (muser0,mresource0)
     dput XJabber $ "xmppInformPeerPresence from  = " ++ show from
     -- forM_ mresource       $ \resource -> do
     forM_ muser           $ \user -> do
@@ -806,15 +813,22 @@ informPeerPresence state k stanza = do
         con <- liftMaybe $ Map.lookup ck ktc
         return (ck,con,client)
     dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
+    (ctyp,cprof) <- atomically $ do
+        mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
+        return $ fromMaybe (XMPP,".") $ do
+            ConnectionData _ ctyp cprof <- auxData <$> mconn
+            return (ctyp,cprof)
     forM_ clients $ \(ck,con,client) -> do
         -- (TODO: appropriately authorized clients only.)
         -- For now, all "available" clients (available = sent initial presence)
         is_avail <- atomically $ clientIsAvailable client
         when is_avail $ do
         dput XJabber $ "reversing for client: " ++ show from
-        froms <- do -- flip (maybe $ return [from]) k . const $ do
-            (_,trip) <- multiplyJIDForClient ck from
-            return (map unsplitJID trip)
+        froms <- case ctyp of
+            Tox | clientProfile client == cprof -> return [from]
+            _ -> do -- flip (maybe $ return [from]) k . const $ do
+                (_,trip) <- multiplyJIDForClient ck from
+                return (map unsplitJID trip)
 
         dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
         forM_ froms $ \from' -> do
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")