summaryrefslogtreecommitdiff
path: root/ToxToXMPP.hs
diff options
context:
space:
mode:
Diffstat (limited to 'ToxToXMPP.hs')
-rw-r--r--ToxToXMPP.hs55
1 files changed, 37 insertions, 18 deletions
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index b1c233a3..804f1db3 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -1,14 +1,25 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-} 2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE NamedFieldPuns #-} 3{-# LANGUAGE NamedFieldPuns #-}
4module ToxToXMPP where 4module ToxToXMPP
5 ( forkAccountWatcher
6 , JabberClients
7 , PerClient
8 , initPerClient
9 , toxQSearch
10 , toxAnnounceInterval
11 , xmppToTox
12 , toxToXmpp
13 , interweave
14 ) where
5 15
16import Control.Monad.IO.Class
6import Data.Conduit as C 17import Data.Conduit as C
7import qualified Data.Conduit.List as CL 18import qualified Data.Conduit.List as CL
8import Data.XML.Types as XML 19import Data.XML.Types as XML
20import EventUtil
9import Network.Tox.Crypto.Transport as Tox 21import Network.Tox.Crypto.Transport as Tox
10import XMPPServer as XMPP 22import XMPPServer as XMPP
11import EventUtil
12 23
13import Announcer 24import Announcer
14import Announcer.Tox 25import Announcer.Tox
@@ -63,10 +74,13 @@ import Control.Concurrent.Lifted
63import GHC.Conc (labelThread) 74import GHC.Conc (labelThread)
64#endif 75#endif
65import DPut 76import DPut
77import Nesting
66 78
67xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage 79xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
68xmppToTox = do 80xmppToTox = doNestingXML $ fix $ \loop -> do
69 awaitForever (\_ -> return ()) 81 e <- await
82 dput DPut.XMan $ "xmppToTox: " ++ show e
83 loop
70 84
71toxToXmpp :: Monad m => Text -> Conduit Tox.CryptoMessage m XML.Event 85toxToXmpp :: Monad m => Text -> Conduit Tox.CryptoMessage m XML.Event
72toxToXmpp toxhost = do 86toxToXmpp toxhost = do
@@ -159,8 +173,11 @@ interweave :: [a] -> [a] -> [a]
159interweave [] ys = ys 173interweave [] ys = ys
160interweave (x:xs) ys = x : interweave ys xs 174interweave (x:xs) ys = x : interweave ys xs
161 175
176akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey
162akeyDHTKeyShare announcer me them = atomically $ do 177akeyDHTKeyShare announcer me them = atomically $ do
163 packAnnounceKey announcer $ "dhtkey:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) 178 packAnnounceKey announcer $ "dhtkey:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them)
179
180akeyConnect :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey
164akeyConnect announcer me them = atomically $ do 181akeyConnect announcer me them = atomically $ do
165 packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them) 182 packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them)
166 183
@@ -176,6 +193,7 @@ startConnecting0 tx them contact = do
176 [bkts4,bkts6] 193 [bkts4,bkts6]
177 return $ foldr interweave [] nss 194 return $ foldr interweave [] nss
178 wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact) 195 wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact)
196 soliciting <- return False -- TODO: read subscribers file to answer this question.
179 when wanted $ do 197 when wanted $ do
180 let pub = toPublic $ userSecret acnt 198 let pub = toPublic $ userSecret acnt
181 me = key2id pub 199 me = key2id pub
@@ -194,19 +212,20 @@ startConnecting0 tx them contact = do
194 -- likelihood of failure as the chances of packet loss 212 -- likelihood of failure as the chances of packet loss
195 -- happening to all (up to to 8) packets sent is low. 213 -- happening to all (up to to 8) packets sent is low.
196 -- 214 --
197 scheduleSearch announcer 215 let meth = SearchMethod (toxQSearch tox) onResult nearNodes (key2id them) 30
198 akey 216 where
199 (SearchMethod (toxQSearch tox) 217 onResult theirkey rendezvous = do
200 (\theirkey rendezvous -> do 218 dkey <- Tox.getContactInfo tox
201 dkey <- Tox.getContactInfo tox 219 let tr = Tox.toxToRoute tox
202 sendMessage 220 route = Tox.AnnouncedRendezvous theirkey rendezvous
203 (Tox.toxToRoute tox) 221 sendMessage tr route (pub,Tox.OnionDHTPublicKey dkey)
204 (Tox.AnnouncedRendezvous theirkey rendezvous) 222 when soliciting $ do
205 (pub,Tox.OnionDHTPublicKey dkey)) 223 let fr = FriendRequest
206 nearNodes 224 { friendNoSpam = _todo
207 (key2id them) 225 , friendRequestText = mempty
208 30) -- every 30 seconds 226 }
209 pub 227 sendMessage tr route (pub,Tox.OnionFriendRequest fr)
228 scheduleSearch announcer akey meth pub
210 229
211startConnecting :: ToxToXMPP -> PublicKey -> IO () 230startConnecting :: ToxToXMPP -> PublicKey -> IO ()
212startConnecting tx them = do 231startConnecting tx them = do
@@ -217,7 +236,7 @@ startConnecting tx them = do
217 236
218stopConnecting :: ToxToXMPP -> PublicKey -> IO () 237stopConnecting :: ToxToXMPP -> PublicKey -> IO ()
219stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do 238stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do
220 dput XMisc $ "STOP CONNECTING " ++ show (key2id them) 239 dput XMan $ "STOP CONNECTING " ++ show (key2id them)
221 let pub = toPublic $ userSecret acnt 240 let pub = toPublic $ userSecret acnt
222 me = key2id pub 241 me = key2id pub
223 akey <- akeyDHTKeyShare announcer me them 242 akey <- akeyDHTKeyShare announcer me them