4 files changed, 93 insertions, 29 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index c81cb9ce..6d6d3bd7 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -9,6 +9,7 @@ module XMPPServer
     , XMPPServerParameters(..)
     , XMPPServer
     , xmppConnections
+    , xmppEventChannel
     , StanzaWrap(..)
     , Stanza(..)
     , StanzaType(..)
@@ -27,6 +28,7 @@ module XMPPServer
     , makeMessage
     , JabberShow(..)
     , Server
+    , flushPassThrough
     ) where
 
 import ConnectionKey
@@ -1804,6 +1806,9 @@ xmppConnections sv = tcpManager (grokPeer sv) (Just . Text.pack) resolvPeer (_xm
     resolvPeer :: Text -> IO (Maybe ConnectionKey)
     resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer str
 
+xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, SockAddr), ConnectionEvent Event)
+xmppEventChannel sv = serverEvent $ _xmpp_sv sv
+
 xmppServer :: ( MonadResource m
               , MonadIO m
               ) => XMPPServerParameters -> m XMPPServer
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
new file mode 100644
index 00000000..b018e47b
--- /dev/null
+++ b/ToxToXMPP.hs
@@ -0,0 +1,11 @@
+module ToxToXMPP where
+
+import Data.Conduit                 as C
+import Data.XML.Types               as XML
+import Network.Tox.Crypto.Transport as Tox
+
+xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
+xmppToTox = _todo
+
+toxToXmpp :: Conduit Tox.CryptoMessage IO XML.Event
+toxToXmpp = _todo
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
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 37802e3c..5b30a7e6 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -46,6 +46,7 @@ import qualified Data.ByteString.Base16       as Base16
 import qualified Data.ByteString.Char8        as C8
 import Data.ByteString.Lazy                   (toStrict)
 import Data.Char
+import Data.Conduit (Source,Sink,Flush(..))
 import Data.Data
 import Data.Functor.Contravariant
 import Data.Hashable
@@ -85,11 +86,12 @@ import Control.TriadCommittee
 import Network.BitTorrent.DHT.Token           as Token
 import GHC.TypeLits
 
+import Connection
 import Crypto.Tox
 import Data.Word64Map                        (fitsInInt)
 import qualified Data.Word64Map              (empty)
 import Network.Kademlia.Bootstrap            (forkPollForRefresh, bootstrap)
-import Network.Tox.Crypto.Transport          (NetCrypto)
+import Network.Tox.Crypto.Transport          (NetCrypto, CryptoMessage)
 import Network.Tox.Crypto.Handlers           (cryptoNetHandler, newSessionsState, defaultUnRecHook, defaultCryptoDataHooks, NetCryptoSessions(..))
 import qualified Network.Tox.DHT.Handlers    as DHT
 import qualified Network.Tox.DHT.Transport   as DHT
@@ -221,18 +223,22 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
             in client
     return $ either mkclient mkclient tblvar handlers
 
+data ConnectionKey    -- TODO
+data ConnectionStatus -- TODO
+
 data Tox = Tox
-    { toxDHT :: DHT.Client
-    , toxOnion :: Onion.Client RouteId
-    , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
-    , toxCrypto :: Transport String SockAddr NetCrypto
+    { toxDHT            :: DHT.Client
+    , toxOnion          :: Onion.Client RouteId
+    , toxToRoute        :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
+    , toxCrypto         :: Transport String SockAddr NetCrypto
     , toxCryptoSessions :: NetCryptoSessions
-    , toxCryptoKeys :: TransportCrypto
-    , toxRouting :: DHT.Routing
-    , toxTokens :: TVar SessionTokens
-    , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
-    , toxOnionRoutes :: OnionRouter
-    , toxRoster :: Roster
+    , toxCryptoKeys     :: TransportCrypto
+    , toxRouting        :: DHT.Routing
+    , toxTokens         :: TVar SessionTokens
+    , toxAnnouncedKeys  :: TVar Onion.AnnouncedKeys
+    , toxOnionRoutes    :: OnionRouter
+    , toxRoster         :: Roster
+    , toxManager        :: Connection.Manager ConnectionStatus ConnectionKey
     }
 
 getContactInfo :: Tox -> IO DHT.DHTPublicKey
@@ -289,8 +295,17 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
     return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
 
 
-newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> Maybe NetCryptoSessions -> Maybe SecretKey -> IO Tox
-newTox keydb addr mbSessionsState suppliedDHTKey = do
+newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rendezvous for.
+       -> SockAddr                   -- ^ Bind-address to listen on.
+       -> Maybe NetCryptoSessions    -- ^ State of all one-on-one Tox links.
+       -> Maybe SecretKey            -- ^ Optional DHT secret key to use.
+       -> ( SockAddr                            -- ^ Address of remote peer.
+            -> STM Bool                         -- ^ True if connection requires a ping.
+            -> Source IO CryptoMessage          -- ^ Inbound packets.
+            -> Sink (Flush CryptoMessage) IO () -- ^ Outbound packets.
+            -> IO () )               -- ^ Action to invoke on new connections.
+       -> IO Tox
+newTox keydb addr mbSessionsState suppliedDHTKey announceConnection = do
     udp <- {- addVerbosity <$> -} udpTransport addr
     (crypto0,sessionsState) <- case mbSessionsState of
                                  Nothing -> do
@@ -338,17 +353,24 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
 
     roster <- newRoster
     return Tox
-        { toxDHT = dhtclient
-        , toxOnion = onionclient
-        , toxToRoute = onInbound (updateRoster roster) dtacrypt
-        , toxCrypto = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet
+        { toxDHT            = dhtclient
+        , toxOnion          = onionclient
+        , toxToRoute        = onInbound (updateRoster roster) dtacrypt
+        , toxCrypto         = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet
         , toxCryptoSessions = sessionsState
-        , toxCryptoKeys = crypto
-        , toxRouting = mkrouting dhtclient
-        , toxTokens = toks
-        , toxAnnouncedKeys = keydb
-        , toxOnionRoutes = orouter
-        , toxRoster = roster
+        , toxCryptoKeys     = crypto
+        , toxRouting        = mkrouting dhtclient
+        , toxTokens         = toks
+        , toxAnnouncedKeys  = keydb
+        , toxOnionRoutes    = orouter
+        , toxRoster         = roster
+        , toxManager        = Connection.Manager
+            { setPolicy    = _todo -- k -> Policy -> IO ()
+            , connections  = _todo -- STM (Map k (Connection status))
+            , stringToKey  = _todo -- String -> Maybe k
+            , showProgress = _todo -- status -> String
+            , showKey      = _todo -- k -> String
+            }
         }
 
 onionTimeout :: Tox -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)