tox: Separate transports for handshakes and crypto-packets.

3 files changed, 53 insertions, 14 deletions

diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index ce9939a9..6df239b5 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -240,6 +240,7 @@ data Tox = Tox
     , toxOnion          :: Onion.Client RouteId
     , toxToRoute        :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
     , toxCrypto         :: Transport String SockAddr NetCrypto
+    , toxHandshakes     :: Transport String SockAddr NetCrypto
     , toxCryptoSessions :: NetCryptoSessions
     , toxCryptoKeys     :: TransportCrypto
     , toxRouting        :: DHT.Routing
@@ -439,8 +440,22 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
     mkrouting <- DHT.newRouting addr crypto updateIP updateIP
     let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building.
     orouter <- newOnionRouter ignoreErrors
-    (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp
-    let sessionsState = sessionsState0 { sessionTransport = cryptonet
+    (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp
+
+    -- TODO: Avoid adapting these transports here.
+    let nc_cryptonet  = layerTransport (\x addr -> Right (NetCrypto x,addr))
+                                       (\(NetCrypto x) addr -> (x,addr))
+                                       cryptonet
+        nc_handshakes = layerTransport (\x addr -> Right (NetHandshake x,addr))
+                                       (\(NetHandshake x) addr -> (x,addr))
+                                       handshakes
+        nc_combo = nc_handshakes
+                    { sendMessage = \addr -> \case
+                        NetCrypto    x -> sendMessage cryptonet  addr x
+                        NetHandshake x -> sendMessage handshakes addr x
+                    }
+
+    let sessionsState = sessionsState0 { sessionTransport = nc_combo
                                        , transportCrypto = crypto }
     let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
         tbl4 = DHT.routing4 $ mkrouting (error "missing client")
@@ -465,7 +480,8 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
         { toxDHT            = dhtclient
         , toxOnion          = onionclient
         , toxToRoute        = onInbound (updateContactInfo roster) dtacrypt
-        , toxCrypto         = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet
+        , toxCrypto         = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) nc_cryptonet
+        , toxHandshakes     = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) nc_handshakes
         , toxCryptoSessions = sessionsState
         , toxCryptoKeys     = crypto
         , toxRouting        = mkrouting dhtclient
@@ -481,10 +497,11 @@ onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTim
 
 forkTox :: Tox -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
 forkTox tox = do
-    _ <- forkListener "toxCrypto" (toxCrypto tox)
+    _ <- forkListener "toxHandshakes" (toxHandshakes tox)
     _ <- forkListener "toxToRoute" (toxToRoute tox)
     _ <- forkListener "toxOnion" (clientNet $ toxOnion tox)
-    quit <- forkListener "toxDHT" (clientNet $ toxDHT tox)
+    _ <- forkListener "toxDHT" (clientNet $ toxDHT tox)
+    quit <- forkListener "toxCrypto" (toxCrypto tox)
     forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
     forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
     return ( quit
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
index 1444ffca..2c998006 100644
--- a/src/Network/Tox/Crypto/Transport.hs
+++ b/src/Network/Tox/Crypto/Transport.hs
@@ -5,9 +5,10 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 module Network.Tox.Crypto.Transport
-    ( parseNetCrypto
-    , encodeNetCrypto
-    -- CryptoTransport
+    ( parseCrypto
+    , encodeCrypto
+    , parseHandshakes
+    , encodeHandshakes
     , NetCrypto(..)
     , CryptoData(..)
     , CryptoMessage(..)
@@ -80,6 +81,23 @@ data NetCrypto
     = NetHandshake (Handshake Encrypted)
     | NetCrypto (CryptoPacket Encrypted)
 
+parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
+parseCrypto ((B.uncons -> Just (0x1b,pkt)),saddr) = either (\_ -> Right (pkt,saddr))
+                                                           (\x -> Left  (x  ,saddr))
+                                                        $ runGet get pkt
+parseCrypto not_mine = Right not_mine
+
+encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
+encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)
+
+parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr)
+parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseNetCrypto: "++) $ (,saddr) <$> runGet get pkt
+parseHandshakes _                             _     = Left "parseHandshakes_: ?"
+
+encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr)
+encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr)
+
+
 parseNetCrypto :: ByteString -> SockAddr -> Either String (NetCrypto, SockAddr)
 parseNetCrypto (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseNetCrypto: "++) $ (,saddr) . NetHandshake <$> runGet get pkt
 parseNetCrypto (B.uncons -> Just (0x1b,pkt)) saddr = left ("parseNetCrypto: "++) $ (,saddr) . NetCrypto    <$> runGet get pkt
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
index 30df93c8..57f07aad 100644
--- a/src/Network/Tox/Transport.hs
+++ b/src/Network/Tox/Transport.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeOperators              #-}
 module Network.Tox.Transport (toxTransport, RouteId) where
 
+import Data.ByteString (ByteString)
 import Network.QueryResponse
 import Crypto.Tox
 import Network.Tox.DHT.Transport
@@ -22,21 +23,24 @@ toxTransport ::
           -> OnionRouter
           -> (PublicKey -> IO (Maybe NodeInfo))
           -> UDPTransport
-          -> IO ( Transport String NodeInfo (DHTMessage Encrypted8)
+          -> IO ( Transport String SockAddr (CryptoPacket Encrypted)
+                , Transport String NodeInfo (DHTMessage Encrypted8)
                 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
                 , Transport String AnnouncedRendezvous (PublicKey,OnionData)
-                , Transport String SockAddr NetCrypto )
+                , Transport String SockAddr (Handshake Encrypted))
 toxTransport crypto orouter closeLookup udp = do
-    (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp
+    (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
+    (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp0
     (onion1,udp2) <- partitionTransportM (parseOnionAddr $ lookupSender orouter)
                                         (encodeOnionAddr crypto $ lookupRoute orouter)
                                         udp1
     (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
-    let netcrypto = layerTransport parseNetCrypto encodeNetCrypto udp2
-    return ( forwardDHTRequests crypto closeLookup dht
+    let handshakes = layerTransport parseHandshakes encodeHandshakes udp2
+    return ( netcrypto
+           , forwardDHTRequests crypto closeLookup dht
            , onion
            , dta
-           , netcrypto
+           , handshakes
            )