Multi Transports: TCP for DHT/Cookies/Handshakes.

3 files changed, 149 insertions, 6 deletions

diff --git a/dht/src/Data/Tox/DHT/Multi.hs b/dht/src/Data/Tox/DHT/Multi.hs
new file mode 100644
index 00000000..3f91387c
--- /dev/null
+++ b/dht/src/Data/Tox/DHT/Multi.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Data.Tox.DHT.Multi where
+
+import qualified Network.Tox.NodeId as UDP
+         ;import Network.Tox.NodeId (NodeId)
+import qualified Network.Tox.TCP.NodeId as TCP
+import Data.Tox.Relay
+import Network.Address (either4or6)
+import Network.Tox.TCP as TCP (ViaRelay(..))
+import Network.QueryResponse (Tagged(..))
+
+import Data.Dependent.Sum
+import Data.GADT.Compare
+import Data.GADT.Show
+import Data.Functor.Identity
+import Data.Typeable
+import Network.Socket
+
+#if MIN_VERSION_dependent_sum(0,6,0)
+import Data.Constraint.Compose
+import Data.Constraint.Extras
+import Data.Constraint.Extras.TH
+#endif
+
+
+data T ni where
+    UDP :: T UDP.NodeInfo
+    TCP :: T TCP.ViaRelay
+
+instance GEq T where
+    geq UDP UDP = Just Refl
+    geq TCP TCP = Just Refl
+    geq _   _   = Nothing
+instance GCompare T where
+    gcompare UDP UDP = GEQ
+    gcompare UDP TCP = GLT
+    gcompare TCP TCP = GEQ
+    gcompare TCP UDP = GGT
+instance GShow T where
+     gshowsPrec _ UDP = showString "UDP"
+     gshowsPrec _ TCP = showString "TCP"
+
+data S addr where
+    SessionUDP :: S SockAddr
+    SessionTCP :: S TCP.ViaRelay
+
+instance GEq S where
+    geq SessionUDP SessionUDP = Just Refl
+    geq SessionTCP SessionTCP = Just Refl
+    geq _          _          = Nothing
+instance GCompare S where
+    gcompare SessionUDP SessionUDP = GEQ
+    gcompare SessionUDP SessionTCP = GLT
+    gcompare SessionTCP SessionTCP = GEQ
+    gcompare SessionTCP SessionUDP = GGT
+instance GShow S where
+     gshowsPrec _ SessionUDP = showString "UDP"
+     gshowsPrec _ SessionTCP = showString "TCP"
+
+-- Canonical in case of 6-mapped-4 addresses.
+canonize :: DSum S Identity -> DSum S Identity
+canonize (SessionUDP :=> Identity saddr) = SessionUDP ==> either id id (either4or6 saddr)
+canonize taddr                           = taddr
+
+data A addr where
+    AddrUDP :: SockAddr -> A UDP.NodeInfo
+    AddrTCP :: Maybe ConId -> TCP.NodeInfo -> A TCP.ViaRelay
+
+deriving instance Eq (A addr)
+
+type NodeInfo = DSum T Identity
+type SessionAddress = DSum S Identity
+
+type Address = DSum T A
+
+#if MIN_VERSION_dependent_sum(0,6,0)
+deriveArgDict ''T
+deriveArgDict ''S
+#else
+instance ShowTag T Identity where
+    showTaggedPrec UDP = showsPrec
+    showTaggedPrec TCP = showsPrec
+instance ShowTag S Identity where
+    showTaggedPrec SessionUDP = showsPrec
+    showTaggedPrec SessionTCP = showsPrec
+instance EqTag S Identity where
+    eqTagged SessionUDP SessionUDP = (==)
+    eqTagged SessionTCP SessionTCP = (==)
+instance OrdTag S Identity where
+    compareTagged SessionUDP SessionUDP = compare
+    compareTagged SessionTCP SessionTCP = compare
+#endif
+
+
+{-
+nodeInfo :: NodeId -> DSum T A -> Either String (DSum T Identity )
+nodeInfo nid (UDP :=> AddrUDP saddr      ) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
+nodeInfo nid (TCP :=> AddrTCP conid relay) = Right $ TCP ==> ViaRelay conid nid relay
+
+nodeAddr :: DSum T Identity -> DSum T A
+nodeAddr (UDP :=> Identity ni                    ) = UDP :=> AddrUDP (UDP.nodeAddr ni)
+nodeAddr (TCP :=> Identity (ViaRelay conid _ relay)) = TCP :=> AddrTCP conid relay
+-}
+
+nodeInfo :: NodeId -> DSum S Identity -> Either String (DSum T Identity)
+nodeInfo nid (SessionUDP :=> Identity saddr) = fmap (UDP ==>) $ UDP.nodeInfo nid saddr
+nodeInfo nid (SessionTCP :=> Identity taddr@(ViaRelay _ nid2 _)) =
+    if nid2 == nid then Right $ TCP ==> taddr
+                   else Left $ "Cached dht-key doesn't match."
+
+nodeId :: DSum T Identity -> NodeId
+nodeId (UDP :=> Identity ni                ) = UDP.nodeId ni
+nodeId (TCP :=> Identity (ViaRelay _ nid _)) = nid
+
+relayNodeId :: TCP.ViaRelay -> UDP.NodeId
+relayNodeId (ViaRelay _ nid _) = nid
+
+udpNode :: DSum T Identity -> Maybe UDP.NodeInfo
+udpNode (UDP :=> Identity ni) = Just ni
+udpNode _                     = Nothing
diff --git a/dht/src/Data/Tox/Msg.hs b/dht/src/Data/Tox/Msg.hs
index 8819faa7..4398586f 100644
--- a/dht/src/Data/Tox/Msg.hs
+++ b/dht/src/Data/Tox/Msg.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DefaultSignatures          #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -7,6 +8,7 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE PolyKinds                  #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
 module Data.Tox.Msg where
 
@@ -14,6 +16,7 @@ import Crypto.Error
 import qualified Crypto.PubKey.Ed25519 as Ed25519
 import Data.ByteArray             as BA
 import Data.ByteString            as B
+import Data.Constraint
 import Data.Dependent.Sum
 import Data.Functor.Contravariant
 import Data.Functor.Identity
@@ -31,6 +34,12 @@ import Crypto.Tox
 import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers)
 import Network.Tox.NodeId
 
+#if MIN_VERSION_dependent_sum(0,6,0)
+import Data.Constraint.Compose
+import Data.Constraint.Extras
+import Data.Constraint.Extras.TH
+#endif
+
 newtype Unknown = Unknown B.ByteString deriving (Eq,Show)
 newtype Padded  = Padded  B.ByteString deriving (Eq,Show)
 
@@ -102,11 +111,7 @@ msgID (Pkt mid :=> Identity _) = M mid
 
 -- TODO
 instance GShow Pkt where gshowsPrec = showsPrec
-instance ShowTag Pkt Identity where
-    showTaggedPrec (Pkt _) = showsPrec
-
 instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
-instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
 
 someMsgVal :: KnownMsg n => Msg n a -> SomeMsg
 someMsgVal m = msgid (proxy m)
@@ -311,3 +316,16 @@ instance Serialize Invite where
             ConfirmedInvite ns -> return () -- TODO: encode nodes.
 
 instance Packet Invite where
+
+#if MIN_VERSION_dependent_sum(0,6,0)
+-- deriveArgDict ''Pkt
+instance ArgDict (ComposeC Show Identity) Pkt where
+    type ConstraintsFor Pkt (ComposeC Show Identity) = ()
+    argDict (Pkt _) = Dict
+instance ArgDict (ComposeC Eq Identity) Pkt where
+    type ConstraintsFor Pkt (ComposeC Eq Identity) = ()
+    argDict (Pkt _) = Dict
+#else
+instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
+instance ShowTag Pkt Identity where showTaggedPrec (Pkt _) = showsPrec
+#endif
diff --git a/dht/src/Data/Tox/Relay.hs b/dht/src/Data/Tox/Relay.hs
index 1bce76db..31752433 100644
--- a/dht/src/Data/Tox/Relay.hs
+++ b/dht/src/Data/Tox/Relay.hs
@@ -8,7 +8,7 @@
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE UndecidableInstances       #-}
 module Data.Tox.Relay
-    ( module Network.Tox.TCP.NodeId
+    ( module TCP
     , module Data.Tox.Relay
     ) where
 
@@ -30,7 +30,6 @@ import qualified Rank2
 import qualified Text.ParserCombinators.ReadP as RP
 
 import Crypto.Tox
-import Network.Tox.TCP.NodeId
 import Data.Tox.Onion
 import qualified Network.Tox.NodeId as UDP
 import Network.Tox.TCP.NodeId as TCP