Fix for tcp-bound DHTKey message (I think).

3 files changed, 21 insertions, 52 deletions

diff --git a/dht/src/Data/Tox/DHT/Multi.hs b/dht/src/Data/Tox/DHT/Multi.hs
index 8d614262..acd645a3 100644
--- a/dht/src/Data/Tox/DHT/Multi.hs
+++ b/dht/src/Data/Tox/DHT/Multi.hs
@@ -11,7 +11,7 @@ import Crypto.PubKey.Curve25519 (PublicKey)
 import qualified Network.Tox.NodeId as UDP
          ;import Network.Tox.NodeId (NodeId)
 import qualified Network.Tox.TCP.NodeId as TCP
-import Data.Tox.Onion (OnionDestination,RouteId,AnnouncedRendezvous)
+import Data.Tox.Onion (OnionDestination,RouteId)
 import Data.Tox.Relay hiding (NodeInfo)
 import Network.Address (either4or6)
 import Network.Tox.TCP as TCP (ViaRelay(..), tcpConnectionRequest_)
@@ -95,28 +95,10 @@ type NodeInfo = DSum T Identity
 type SessionAddress = DSum S Identity
 type OnionAddress = DSum O Identity
 
-data R addr where
-    RendezvousUDP :: R AnnouncedRendezvous
-    RendezvousTCP :: R AnnouncedRendezvous
-
-instance GEq R where
-    geq RendezvousUDP RendezvousUDP = Just Refl
-    geq RendezvousTCP RendezvousTCP = Just Refl
-    geq _          _          = Nothing
-instance GCompare R where
-    gcompare RendezvousUDP RendezvousUDP = GEQ
-    gcompare RendezvousUDP RendezvousTCP = GLT
-    gcompare RendezvousTCP RendezvousTCP = GEQ
-    gcompare RendezvousTCP RendezvousUDP = GGT
-instance GShow R where
-    gshowsPrec _ RendezvousUDP = showString "UDP"
-    gshowsPrec _ RendezvousTCP = showString "TCP"
-
 #if MIN_VERSION_dependent_sum(0,6,0)
 deriveArgDict ''T
 deriveArgDict ''S
 deriveArgDict ''O
-deriveArgDict ''R
 #else
 instance ShowTag T Identity where
     showTaggedPrec UDP = showsPrec
@@ -133,15 +115,8 @@ instance EqTag S Identity where
 instance OrdTag S Identity where
     compareTagged SessionUDP SessionUDP = compare
     compareTagged SessionTCP SessionTCP = compare
-instance ShowTag R Identity where
-    showTaggedPrec RendezvousUDP = showsPrec
-    showTaggedPrec RendezvousTCP = showsPrec
 #endif
 
-untagRendezvous :: DSum R Identity -> AnnouncedRendezvous
-untagRendezvous (RendezvousUDP :=> Identity o) = o
-untagRendezvous (RendezvousTCP :=> Identity o) = o
-
 
 nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity)
 nodeInfo nid (SessionUDP :=> Identity saddr) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index a7e5d2c2..f136ab96 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -315,9 +315,8 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
     let lookupClose _ = return Nothing
 
     mkrouting <- DHT.newRouting addr crypto updateIP updateIP
-    (orouter,relaynet,onioncryptTCP0) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp)
-    (dtacryptTCP,onioncryptTCP) <- partitionTransportM (Onion.parseDataToRoute crypto) (Onion.encodeDataToRoute crypto) onioncryptTCP0
-    (cryptonet,dhtcrypt,onioncryptUDP,dtacryptUDP,handshakes)
+    (orouter,relaynet,onioncryptTCP) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp)
+    (cryptonet,dhtcrypt,onioncryptUDP,handshakes)
         <- toxTransport crypto orouter lookupClose addr udp relaynet
                 (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x))
                 (fromMaybe (\_ _ -> return ()) tcp)
@@ -356,31 +355,29 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
         nil <- nullSessionTokens
         atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
 
-    onioncrypt <- mergeTransports $ DMap.fromList
-        [ Multi.OnionUDP :=> ByAddress onioncryptUDP
-        , Multi.OnionTCP :=> ByAddress {- $ onInbound updateOnTCP -} onioncryptTCP ]
-    dtacrypt0 <- mergeTransports $ DMap.fromList
-        [ Multi.RendezvousUDP :=> ByAddress dtacryptUDP
-        , Multi.RendezvousTCP :=> ByAddress dtacryptTCP
-        ]
-    oniondrg <- drgNew
-    let onionnet = layerTransportM
-                        (\msg od -> Onion.decrypt crypto msg $ Multi.untagOnion od)
-                        (\msg od -> do
-                            (msg', od') <- Onion.encrypt crypto msg od
+    onioncrypt <-
+        layerTransportM (\msg addr -> return $ Right (msg,Multi.untagOnion addr))
+                        (\msg addr -> do
                             -- TODO: lookupRoute is unnecessarily done twice
                             -- because that was convenient for me.  The other
-                            -- call was done when building the transport.
+                            -- call was done when building the onioncryptUDP
+                            -- transport.
                             -- Consider simplifying this.
-                            mtcp <- case od' of
+                            mtcp <- case addr of
                                Onion.OnionDestination _ ni (Just rid)
                                     -> (>>= Onion.routeRelayPort) <$> lookupRoute orouter' ni rid
                                _    -> return Nothing
-                            return (msg', maybe (Multi.OnionUDP ==> od') (const $ Multi.OnionTCP ==> od') mtcp))
-                        onioncrypt
-        dtacrypt = layerTransport (\msg addr -> Right (msg,Multi.untagRendezvous addr))
-                                  (\msg addr -> (msg, Multi.RendezvousUDP ==> addr))
-                                  dtacrypt0
+                            return (msg, maybe (Multi.OnionUDP ==> addr) (const $ Multi.OnionTCP ==> addr) mtcp))
+            <$> mergeTransports (DMap.fromList
+                [ Multi.OnionUDP :=> ByAddress onioncryptUDP
+                , Multi.OnionTCP :=> ByAddress {- $ onInbound updateOnTCP -} onioncryptTCP ])
+
+    -- dtacrypt :: Transport String AnnouncedRendezvous (PublicKey,OnionData)
+    (dtacrypt,onioncrypt) <- partitionTransportM (Onion.parseDataToRoute crypto) (Onion.encodeDataToRoute crypto) onioncrypt
+    oniondrg <- drgNew
+    let onionnet = layerTransportM (\msg od -> Onion.decrypt crypto msg od)
+                                   (\msg od -> Onion.encrypt crypto msg od)
+                                   onioncrypt
     onionclient <- newClient oniondrg onionnet (const Onion.classify)
                     (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient))
                     (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb)
diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs
index 55e31e2a..b017f7be 100644
--- a/dht/src/Network/Tox/Transport.hs
+++ b/dht/src/Network/Tox/Transport.hs
@@ -43,7 +43,6 @@ toxTransport ::
           -> IO ( Transport String Multi.SessionAddress (CryptoPacket Encrypted)
                 , Transport String Multi.NodeInfo (DHTMessage Encrypted8)
                 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
-                , Transport String AnnouncedRendezvous (PublicKey,OnionData)
                 , Transport String Multi.SessionAddress (Handshake Encrypted))
 toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do
     (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
@@ -61,11 +60,10 @@ toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do
         [ Multi.UDP :=> ByAddress dhtUDP
         , Multi.TCP :=> ByAddress dhtTCP
         ]
-    (onion1,udp2) <- partitionTransportM
+    (onion,udp2) <- partitionTransportM
                              (parseOnionAddr $ lookupSender orouter)
                              (encodeOnionAddr crypto $ lookupRoute orouter)
                              udp1
-    (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
     multi_netcrypto <- mergeTransports $ DMap.fromList
         [ Multi.SessionUDP :=> ByAddress netcrypto
         , Multi.SessionTCP :=> ByAddress netcryptoTCP ]
@@ -77,7 +75,6 @@ toxTransport crypto orouter closeLookup addr udp relaynet _ tcp2client = do
     return ( multi_netcrypto
            , forwardDHTRequests crypto (fmap (fmap (Multi.UDP ==>)) . closeLookup) dht
            , onion
-           , dta
            , multi_handshakes
            )