The ToxToXMPP code should use XMan tag.

2 files changed, 42 insertions, 22 deletions

diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index b1c233a3..804f1db3 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -1,14 +1,25 @@
 {-# LANGUAGE CPP            #-}
 {-# LANGUAGE LambdaCase     #-}
 {-# LANGUAGE NamedFieldPuns #-}
-module ToxToXMPP where
+module ToxToXMPP
+    ( forkAccountWatcher
+    , JabberClients
+    , PerClient
+    , initPerClient
+    , toxQSearch
+    , toxAnnounceInterval
+    , xmppToTox
+    , toxToXmpp
+    , interweave
+    ) where
 
+import Control.Monad.IO.Class
 import Data.Conduit                 as C
 import qualified Data.Conduit.List  as CL
 import Data.XML.Types               as XML
+import EventUtil
 import Network.Tox.Crypto.Transport as Tox
 import XMPPServer                   as XMPP
-import EventUtil
 
 import Announcer
 import Announcer.Tox
@@ -63,10 +74,13 @@ import Control.Concurrent.Lifted
 import GHC.Conc                  (labelThread)
 #endif
 import DPut
+import Nesting
 
 xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
-xmppToTox = do
-    awaitForever (\_ -> return ())
+xmppToTox = doNestingXML $ fix $ \loop -> do
+    e <- await
+    dput DPut.XMan $ "xmppToTox: " ++ show e
+    loop
 
 toxToXmpp :: Monad m => Text -> Conduit Tox.CryptoMessage m XML.Event
 toxToXmpp toxhost = do
@@ -159,8 +173,11 @@ interweave :: [a] -> [a] -> [a]
 interweave []     ys = ys
 interweave (x:xs) ys = x : interweave ys xs
 
+akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey
 akeyDHTKeyShare announcer me them = atomically $ do
     packAnnounceKey announcer $ "dhtkey:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them)
+
+akeyConnect :: Announcer -> NodeId -> PublicKey -> IO AnnounceKey
 akeyConnect announcer me them = atomically $ do
     packAnnounceKey announcer $ "connect:" ++ (take 8 $ show me) ++ ":" ++ show (key2id them)
 
@@ -176,6 +193,7 @@ startConnecting0 tx them contact = do
                               [bkts4,bkts6]
                 return $ foldr interweave [] nss
         wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact)
+        soliciting <- return False -- TODO: read subscribers file to answer this question.
         when wanted $ do
             let pub = toPublic $ userSecret acnt
                 me  = key2id pub
@@ -194,19 +212,20 @@ startConnecting0 tx them contact = do
                     -- 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
-                                     (key2id them)
-                                     30) -- every 30 seconds
-                     pub
+            let meth = SearchMethod (toxQSearch tox) onResult nearNodes (key2id them) 30
+                 where
+                  onResult theirkey rendezvous = do
+                    dkey <- Tox.getContactInfo tox
+                    let tr    = Tox.toxToRoute tox
+                        route = Tox.AnnouncedRendezvous theirkey rendezvous
+                    sendMessage tr route (pub,Tox.OnionDHTPublicKey dkey)
+                    when soliciting $ do
+                        let fr = FriendRequest
+                                    { friendNoSpam      = _todo
+                                    , friendRequestText = mempty
+                                    }
+                        sendMessage tr route (pub,Tox.OnionFriendRequest fr)
+            scheduleSearch announcer akey meth pub
 
 startConnecting :: ToxToXMPP -> PublicKey -> IO ()
 startConnecting tx them = do
@@ -217,7 +236,7 @@ startConnecting tx them = do
 
 stopConnecting :: ToxToXMPP -> PublicKey -> IO ()
 stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them = do
-    dput XMisc $ "STOP CONNECTING " ++ show (key2id them)
+    dput XMan $ "STOP CONNECTING " ++ show (key2id them)
     let pub = toPublic $ userSecret acnt
         me  = key2id pub
     akey <- akeyDHTKeyShare announcer me them
diff --git a/src/DPut.hs b/src/DPut.hs
index 84f086b3..52714086 100644
--- a/src/DPut.hs
+++ b/src/DPut.hs
@@ -1,5 +1,6 @@
 module DPut where
 
+import Control.Monad.IO.Class
 import Control.Concurrent.STM
 import qualified Data.Map.Strict as Map
 import System.IO (stderr,hPutStrLn)
@@ -20,11 +21,11 @@ appName = "toxmpp"
 (<.>) :: String -> String -> String
 a <.> b = a ++ "." ++ b
 
-dput :: DebugTag -> String -> IO ()
-dput tag msg = debugM (appName <.> show tag) msg
+dput :: MonadIO m => DebugTag -> String -> m ()
+dput tag msg = liftIO $ debugM (appName <.> show tag) msg
 
-dputB :: DebugTag -> B.ByteString -> IO ()
-dputB tag msg = debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
+dputB :: MonadIO m => DebugTag -> B.ByteString -> m ()
+dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
 
 setTagLevel :: Priority -> DebugTag -> IO ()
 setTagLevel level tag = updateGlobalLogger (appName <.> show tag) (setLevel level)