1 files changed, 19 insertions, 14 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 8fc986a5..a921fea6 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns              #-}
 {-# LANGUAGE CPP                       #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts          #-}
@@ -1020,11 +1021,11 @@ noArgPing f [] x = f x
 noArgPing _ _  _ = return Nothing
 
 -- | Create a Conduit Source by repeatedly calling an IO action.
-ioToSource :: IO (Maybe x) -> C.Source IO x
-ioToSource action = liftIO action >>= \case
-        Nothing   -> return () -- EOF.
+ioToSource :: IO (Maybe x) -> IO () -> C.Source IO x
+ioToSource !action !onEOF = liftIO action >>= \case
+        Nothing   -> liftIO onEOF
         Just item -> do C.yield item
-                        ioToSource action
+                        ioToSource action onEOF
 
 newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO ()
 newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue, ncPacketQueue }) = C.awaitForever $ \flush_cyptomessage -> do
@@ -1096,14 +1097,16 @@ toxman tox = ToxManager
 
 #ifdef XMPP
 
-announceToxXMPPClients :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event)
-                      -> SockAddr
-                      -> SockAddr
+-- | Called upon a new Tox friend-connection session with a remote peer in
+-- order to set up translating conduits that simulate a remote XMPP server.
+announceToxJabberPeer :: TChan ((ConnectionKey,SockAddr), Tcp.ConnectionEvent XML.Event)
+                      -> SockAddr -- ^ Local bind address for incoming Tox packets.
+                      -> SockAddr -- ^ Remote address for this connection.
                       -> STM Bool
                       -> C.Source IO Tox.CryptoMessage
                       -> C.Sink (Flush Tox.CryptoMessage) IO ()
                       -> IO (Maybe (Tox.NetCryptoSession -> Tox.NetCryptoSession))
-announceToxXMPPClients echan laddr saddr pingflag tsrc tsnk
+announceToxJabberPeer echan laddr saddr pingflag tsrc tsnk
     = do
      atomically $ writeTChan echan
         ( (PeerKey saddr, laddr )
@@ -1430,18 +1433,20 @@ main = runResourceT $ liftBaseWith $ \resT -> do
             let Just pingMachine = Tox.ncPingMachine netcrypto
                 pingflag         = readTVar (pingFlag pingMachine)
                 receiveCrypto    = atomically $ readTMChan tmchan
-                handleIncoming typ session cd | any ($ typ) [Tox.isKillPacket, Tox.isOFFLINE] = atomically $ do
+#ifdef XMPP
+                onEOF            = return () -- TODO: Update toxContactInfo, not connected.
+                xmppSrc          = ioToSource receiveCrypto onEOF
+                xmppSink         = newXmmpSink netcrypto
+            announceToxJabberPeer (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
+            -- TODO: Update toxContactInfo, connected.
+#endif
+            let handleIncoming typ session cd | any ($ typ) [Tox.isKillPacket, Tox.isOFFLINE] = atomically $ do
                     closeTMChan tmchan
                     Tox.forgetCrypto crypto netCryptoSessionsState netcrypto
                     return Nothing
                 handleIncoming mTyp session cd = do
                     atomically $ writeTMChan tmchan (Tox.bufferData cd)
                     return Nothing
-#ifdef XMPP
-                xmppSrc          = ioToSource receiveCrypto
-                xmppSink         = newXmmpSink netcrypto
-            announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
-#endif
             atomically $ writeTVar (Tox.ncUnrecognizedHook netcrypto) handleIncoming
             return Nothing