1 files changed, 21 insertions, 8 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 4b38a7ea..d5310f57 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -92,6 +92,7 @@ import qualified Network.Tox.Crypto.Handlers as Tox
 import Data.Typeable
 import Roster
 import OnionRouter
+import PingMachine
 
 -- Presence imports.
 import ConsoleWriter
@@ -99,7 +100,7 @@ import Presence
 import XMPPServer
 import Connection
 import ToxToXMPP
-import qualified Connection.Tcp (ConnectionEvent(..))
+import qualified Connection.Tcp as Tcp (ConnectionEvent(..))
 
 
 showReport :: [(String,String)] -> String
@@ -987,17 +988,25 @@ noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r)
 noArgPing f [] x = f x
 noArgPing _ _  _ = return Nothing
 
-announceToxConnection :: TChan ((ConnectionKey,SockAddr), Connection.Tcp.ConnectionEvent XML.Event)
+newXmmpSource :: Tox.NetCryptoSession -> IO (C.Source IO Tox.CryptoMessage)
+newXmmpSource = _todo
+
+newXmmpSink :: Tox.NetCryptoSession -> IO (C.Sink (Flush Tox.CryptoMessage) IO ())
+newXmmpSink = _todo
+
+announceToxXMPPClients :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event)
                       -> SockAddr
                       -> SockAddr
                       -> STM Bool
                       -> C.Source IO Tox.CryptoMessage
                       -> C.Sink (Flush Tox.CryptoMessage) IO ()
-                      -> IO ()
-announceToxConnection echan laddr saddr pingflag tsrc tsnk
-    = atomically $ writeTChan echan
+                      -> IO (Maybe (Tox.NetCryptoSession -> Tox.NetCryptoSession))
+announceToxXMPPClients echan laddr saddr pingflag tsrc tsnk
+    = do
+     atomically $ writeTChan echan
         ( (PeerKey saddr, laddr )
-        , Connection.Tcp.Connection pingflag xsrc xsnk )
+        , Tcp.Connection pingflag xsrc xsnk )
+     return Nothing
  where
     xsrc = tsrc =$= toxToXmpp
     xsnk = flushPassThrough xmppToTox =$= tsnk
@@ -1126,17 +1135,21 @@ main = runResourceT $ liftBaseWith $ \resT -> do
 
     crypto <- Tox.newCrypto
     netCryptoSessionsState <- Tox.newSessionsState crypto Tox.defaultUnRecHook Tox.defaultCryptoDataHooks
-
     (mbtox,quitTox,toxdhts,toxips,taddrs) <- case porttox opts of
         "" -> return (Nothing,return (), Map.empty, return [],[])
         toxport -> do
             addrTox <- getBindAddress toxport (ip6tox opts)
+            atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do
+                let Just pingMachine = Tox.ncPingMachine netcrypto
+                    pingflag = readTVar (pingFlag pingMachine)
+                xmppSrc <- newXmmpSource netcrypto
+                xmppSink <- newXmmpSink netcrypto
+                announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
             hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
             tox <- Tox.newTox keysdb
                               addrTox
                               (Just netCryptoSessionsState)
                               (dhtkey opts)
-                              (announceToxConnection (xmppEventChannel sv) addrTox)
             (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox
 
             toxSearches <- atomically $ newTVar Map.empty