1 files changed, 32 insertions, 6 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index e9b365cb..527af7e7 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -27,6 +27,7 @@ import Control.Monad.Trans.Control
 import Control.Monad.Trans.Resource (runResourceT)
 import Data.Bool
 import Data.Char
+import Data.Conduit as C
 import Data.Function
 import Data.Hashable
 import Data.List
@@ -35,6 +36,7 @@ import qualified Data.Map.Strict as Map
 import Data.Maybe
 import qualified Data.Set        as Set
 import Data.Time.Clock
+import qualified Data.XML.Types  as XML
 import GHC.Conc (threadStatus,ThreadStatus(..))
 import GHC.Stats
 import Network.Socket
@@ -85,6 +87,7 @@ import qualified Network.Tox.DHT.Transport as Tox
 import qualified Network.Tox.DHT.Handlers as Tox
 import qualified Network.Tox.Onion.Transport as Tox
 import qualified Network.Tox.Onion.Handlers as Tox
+import qualified Network.Tox.Crypto.Transport as Tox (CryptoMessage)
 import qualified Network.Tox.Crypto.Handlers as Tox
 import Data.Typeable
 import Roster
@@ -95,6 +98,8 @@ import ConsoleWriter
 import Presence
 import XMPPServer
 import Connection
+import ToxToXMPP
+import qualified Server (ConnectionEvent(..))
 
 
 showReport :: [(String,String)] -> String
@@ -982,6 +987,22 @@ noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r)
 noArgPing f [] x = f x
 noArgPing _ _  _ = return Nothing
 
+announceToxConnection :: TChan ((ConnectionKey,SockAddr), Server.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
+        ( (PeerKey saddr, laddr )
+        , Server.Connection pingflag xsrc xsnk )
+ where
+    xsrc = tsrc =$= toxToXmpp
+    xsnk = flushPassThrough xmppToTox =$= tsnk
+
+
 main :: IO ()
 main = runResourceT $ liftBaseWith $ \resT -> do
     args <- getArgs
@@ -1007,7 +1028,12 @@ main = runResourceT $ liftBaseWith $ \resT -> do
     -- We now have a server object but it's not ready to use until
     -- we put it into the 'server' field of our /state/ record.
 
-    conns <- xmppConnections sv
+    conns     <- xmppConnections  sv
+
+    atomically $ do
+        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
+                                       -- FIXME: This is error prone.
+
 
     (quitBt,btdhts,btips,baddrs) <- case portbt opts of
         "" -> return (return (), Map.empty,return [],[])
@@ -1106,7 +1132,11 @@ main = runResourceT $ liftBaseWith $ \resT -> do
         toxport -> do
             addrTox <- getBindAddress toxport (ip6tox opts)
             hPutStrLn stderr $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
-            tox <- Tox.newTox keysdb addrTox (Just netCryptoSessionsState) (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
@@ -1329,10 +1359,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do
             bootstrap btSaved fallbackNodes
         return ()
 
-    atomically $ do
-        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
-                                       -- FIXME: This is error prone.
-
     forkIO $ do
         myThreadId >>= flip labelThread "XMPP.stanzas"
         let console = cwPresenceChan <$> consoleWriter state