{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} module ToxToXMPP where import Data.Conduit as C import qualified Data.Conduit.List as CL import Data.XML.Types as XML import Network.Tox.Crypto.Transport as Tox import XMPPServer as XMPP import EventUtil import Announcer import Announcer.Tox import Connection import Network.QueryResponse -- import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Crypto.Tox import qualified Data.HashMap.Strict as HashMap import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import Data.Time.Clock.POSIX import Network.Address import Network.Kademlia.Search import qualified Network.Tox as Tox import Network.Tox.ContactInfo as Tox import qualified Network.Tox.Crypto.Handlers as Tox -- import qualified Network.Tox.DHT.Handlers as Tox import Announcer import ClientState import Control.Concurrent.STM import Control.Monad import Crypto.Tox import Data.Bits import Data.Function import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T ;import Data.Text (Text) import Data.Word import qualified Network.Kademlia.Routing as R import Network.Tox import Network.Tox.ContactInfo import Network.Tox.DHT.Handlers import qualified Network.Tox.DHT.Transport as Tox ;import Network.Tox.DHT.Transport (FriendRequest (..)) import Network.Tox.NodeId import qualified Network.Tox.Onion.Handlers as Tox import qualified Network.Tox.Onion.Transport as Tox ;import Network.Tox.Onion.Transport (OnionData (..)) import Presence import Presence import System.IO import Text.Read import XMPPServer (ConnectionKey) #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted import GHC.Conc (labelThread) #endif xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage xmppToTox = do awaitForever (\_ -> return ()) toxToXmpp :: Monad m => Text -> Conduit Tox.CryptoMessage m XML.Event toxToXmpp toxhost = do CL.sourceList $ XMPP.greet' "jabber:server" toxhost awaitForever $ \toxmsg -> do xmppInstantMessage "jabber:server" (Just toxhost) (T.pack $ show $ msgID toxmsg) xmppInstantMessage :: Monad m => Text -> Maybe Text -> Text -> ConduitM i Event m () xmppInstantMessage namespace mfrom text = do let ns n = n { nameNamespace = Just namespace } C.yield $ EventBeginElement (ns "message") ((maybe id (\t->(attr "from" t:)) mfrom) [attr "type" "normal" ]) C.yield $ EventBeginElement (ns "body") [] C.yield $ EventContent $ ContentText text C.yield $ EventEndElement (ns "body") C.yield $ EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" [] C.yield $ EventBeginElement "{http://www.w3.org/1999/xhtml}body" [] C.yield $ EventBeginElement "{http://www.w3.org/1999/xhtml}p" [ attr "style" "font-weight:bold; color:red" ] C.yield $ EventContent $ ContentText text C.yield $ EventEndElement "{http://www.w3.org/1999/xhtml}p" C.yield $ EventEndElement "{http://www.w3.org/1999/xhtml}body" C.yield $ EventEndElement "{http://jabber.org/protocol/xhtml-im}html" C.yield $ EventEndElement (ns "message") key2jid :: Word32 -> PublicKey -> Text key2jid nospam key = T.pack $ show $ NoSpamId nsp key where nsp = NoSpam nospam (Just sum) sum = nlo `xor` nhi `xor` xorsum key nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 dispatch :: Account -> PresenceState -> ContactEvent -> IO () dispatch acnt st (AddrChange theirkey saddr) = return () -- todo dispatch acnt st (PolicyChange theirkey policy ) = return () -- todo dispatch acnt st (OnionRouted theirkey (OnionDHTPublicKey pkey)) = return () -- todo dispatch acnt st (OnionRouted theirkey (OnionFriendRequest fr) ) = do k2c <- atomically $ do refs <- readTVar (clientRefs acnt) k2c <- Map.filterWithKey (\k _ -> k `Set.member` refs) <$> readTVar (keyToChan st) clients <- readTVar (clients st) return $ Map.intersectionWith (,) k2c clients -- TODO: Below we're using a hard coded default as their jabber user id. -- This isn't the right thing, but we don't know their user-id. Perhaps -- there should be a way to parse it out of the friend request text. Maybe -- after a zero-termination, or as visible text (nospam:...). let default_nospam = 0x6a7a27fc -- big-endian base64: anon/A== theirjid = key2jid default_nospam theirkey forM_ k2c $ \(conn,client) -> do self <- localJID (clientUser client) (clientProfile client) (clientResource client) ask <- presenceSolicitation theirjid self -- TODO Send friend-request text as an instant message or at least -- embed it in the stanza as a element. sendModifiedStanzaToClient ask (connChan conn) interweave :: [a] -> [a] -> [a] interweave [] ys = ys interweave (x:xs) ys = x : interweave ys xs forkAccountWatcher :: Account -> Tox -> PresenceState -> Announcer -> IO ThreadId forkAccountWatcher acc tox st announcer = forkIO $ do myThreadId >>= flip labelThread ("tox-xmpp:" ++ show (key2id $ toPublic $ userSecret acc)) (chan,contacts) <- atomically $ do chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading. contacts <- readTVar (contacts acc) return (chan,contacts) -- TODO: process information in contacts HashMap. let nearNodes nid = do bkts4 <- readTVar $ routing4 $ toxRouting tox bkts6 <- readTVar $ routing6 $ toxRouting tox let nss = map (R.kclosest (searchSpace (toxQSearch tox)) searchK nid) [bkts4,bkts6] return $ foldr interweave [] nss forM_ (HashMap.toList contacts) $ \(them,Contact{contactPolicy}) -> do wanted <- atomically $ (==Just TryingToConnect) <$> readTVar contactPolicy when wanted $ do let pub = toPublic $ userSecret acc akey <- atomically $ packAnnounceKey announcer $ "dhtkey:" ++ show them -- We send this packet every 30 seconds if there is more -- than one peer (in the 8) that says they our friend is -- announced on them. This packet can also be sent through -- the DHT module as a DHT request packet (see DHT) if we -- know the DHT public key of the friend and are looking -- for them in the DHT but have not connected to them yet. -- 30 second is a reasonable timeout to not flood the -- network with too many packets while making sure the -- other will eventually receive the packet. Since packets -- are sent through every peer that knows the friend, -- resending it right away without waiting has a high -- likelihood of failure as the chances of packet loss -- happening to all (up to to 8) packets sent is low. -- scheduleSearch announcer akey (SearchMethod (toxQSearch tox) (\theirkey rendezvous -> do dkey <- Tox.getContactInfo tox sendMessage (Tox.toxToRoute tox) (Tox.AnnouncedRendezvous theirkey rendezvous) (pub,Tox.OnionDHTPublicKey dkey)) nearNodes them 30) -- every 30 seconds pub -- Loop endlessly until clientRefs is null. fix $ \loop -> do mev <- atomically $ (Just <$> readTChan chan) `orElse` do refs <- readTVar $ clientRefs acc check $ Set.null refs return Nothing forM_ mev $ \ev -> dispatch acc st ev >> loop toxQSearch :: Tox.Tox -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox) toxAnnounceInterval :: POSIXTime toxAnnounceInterval = 15