From ea3f4e6543b6dddd94898c945a8ad2c24a46ae77 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 6 Jul 2018 05:24:37 -0400 Subject: tox-to-xmpp: presence updates. --- Presence/Presence.hs | 24 +++++++++++--- ToxToXMPP.hs | 94 ++++++++++++++++++++++++++++++++++++++++++++-------- 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") -- cgit v1.2.3