1 files changed, 35 insertions, 28 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 73ae5a57..fbfca86f 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -994,6 +994,18 @@ newXmmpSource = _todo
 newXmmpSink :: Tox.NetCryptoSession -> IO (C.Sink (Flush Tox.CryptoMessage) IO ())
 newXmmpSink = _todo
 
+-- | TODO
+--
+-- These hooks will be invoked in order to connect to *.tox hosts in a user's
+-- XMPP roster.
+toxman :: Tox.Tox -> ToxManager k
+toxman tox = ToxManager
+    { activateAccount        = \k pubname seckey -> return ()
+    , deactivateAccount      = \k pubname -> return ()
+    , setToxConnectionPolicy = \me them policy -> return ()
+    }
+
+
 announceToxXMPPClients :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event)
                       -> SockAddr
                       -> SockAddr
@@ -1012,6 +1024,7 @@ announceToxXMPPClients echan laddr saddr pingflag tsrc tsnk
     xsnk = flushPassThrough xmppToTox =$= tsnk
 
 
+
 main :: IO ()
 main = runResourceT $ liftBaseWith $ \resT -> do
     args <- getArgs
@@ -1027,28 +1040,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do
 
     announcer <- forkAnnouncer
 
-    let toxman = ToxManager
-            { activateAccount        = \k pubkey -> return ()
-            , deactivateAccount      = \k pubkey -> return ()
-            , setToxConnectionPolicy = \me them policy -> return ()
-            }
-
-    -- XMPP initialization
-    cw        <- newConsoleWriter
-    serverVar <- atomically $ newEmptyTMVar
-    state     <- newPresenceState cw (Just toxman) serverVar
-
-    -- XMPP stanza handling
-    sv    <- resT $ xmppServer (presenceHooks state (verbosity opts))
-    -- 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
-
-    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 [],[])
@@ -1145,12 +1136,6 @@ main = runResourceT $ liftBaseWith $ \resT -> do
         "" -> 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
@@ -1321,8 +1306,30 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                 ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
                                                  , Tox.routing6 $ Tox.toxRouting tox ]
             return (Just tox, quitTox, dhts, ips, [addrTox])
+
     _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs
 
+    -- XMPP initialization
+    cw        <- newConsoleWriter
+    serverVar <- atomically $ newEmptyTMVar
+    state     <- newPresenceState cw (toxman <$> mbtox) serverVar
+
+    sv    <- resT $ xmppServer (presenceHooks state (verbosity opts))
+    -- 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
+    atomically $ do
+        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
+                                       -- FIXME: This is error prone.
+
+    forM_ (take 1 taddrs) $ \addrTox -> do
+        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
+
     let dhts = Map.union btdhts toxdhts
 
     (waitForSignal, checkQuit) <- do