1 files changed, 112 insertions, 0 deletions

diff --git a/src/Network/DHT/Tox.hs b/src/Network/DHT/Tox.hs
new file mode 100644
index 00000000..d6fc866f
--- /dev/null
+++ b/src/Network/DHT/Tox.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Network.DHT.Tox where
+
+import Data.Serialize
+import Data.Default
+import Text.PrettyPrint.HughesPJClass
+
+import Network.DHT.Types
+import Network.DatagramServer.Types
+import qualified Network.DatagramServer.Tox as Tox
+import Network.KRPC.Method
+import Data.Word
+import Data.ByteString (ByteString)
+import Data.IP
+import Data.Bool
+import Data.Maybe
+import Control.Monad
+import System.Random
+
+instance Kademlia Tox.Message where
+    data DHTData Tox.Message ip = ToxData
+    namePing      _   = Tox.Ping
+    nameFindNodes _   = Tox.GetNodes
+    initializeDHTData = return ToxData
+
+instance Pretty (NodeId Tox.Message) where
+    pPrint (Tox.NodeId nid) = encodeHexDoc nid
+
+instance Serialize (Query Tox.Message (Ping Tox.Message)) where
+    get = getToxPing False Network.DHT.Types.Query Tox.QueryNonce
+    put (Network.DHT.Types.Query extra Ping) = putToxPing False (Tox.qryNonce extra)
+instance Serialize (Response Tox.Message (Ping Tox.Message)) where
+    get = getToxPing True Network.DHT.Types.Response Tox.ResponseNonce
+    put (Network.DHT.Types.Response extra Ping) = putToxPing True (Tox.rspNonce extra)
+
+instance Serialize (Query Tox.Message (FindNode Tox.Message ip)) where
+    get = do
+        nid <- get
+        n8 <- get
+        return $ Network.DHT.Types.Query (Tox.QueryNonce n8) (FindNode nid)
+    put (Network.DHT.Types.Query (Tox.QueryNonce n8) (FindNode nid)) = do
+        put nid
+        put n8
+instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where
+    get = do
+        num <- get :: Get Word8
+        when (num > 4) $ fail "Too many nodes in Tox get-nodes reply"
+        ns0 <- sequence $ replicate (fromIntegral num) (nodeFormatToNodeInfo <$> get)
+        -- TODO: Allow tcp and ipv6. For now filtering to udp ip4...
+        let ns = flip mapMaybe ns0 $ \(NodeInfo nid addr u) -> do
+                    guard $ not u
+                    ip4 <- fromAddr addr
+                    return $ NodeInfo nid ip4 ()
+        n8 <- get
+        return $ Network.DHT.Types.Response (Tox.ResponseNonce n8) $ NodeFound ns
+    put (Network.DHT.Types.Response (Tox.ResponseNonce n8) (NodeFound ns)) = do
+        put ( fromIntegral (length ns) :: Word8 )
+        forM_ ns $ \(NodeInfo nid ip4 ()) -> do
+            put Tox.NodeFormat { nodePublicKey = nid
+                               , nodeIsTCP     = False
+                               , nodeIP        = IPv4 (nodeHost ip4)
+                               , nodePort      = nodePort ip4
+                               }
+        put n8
+
+instance KRPC Tox.Message (Query    Tox.Message (FindNode  Tox.Message IPv4))
+                          (Response Tox.Message (NodeFound Tox.Message IPv4)) where
+    method = Method Tox.GetNodes
+    validateExchange = validateToxExchange
+    makeQueryExtra _ _ _ _ = Tox.QueryNonce <$> randomIO
+    makeResponseExtra _ _ q _ = return $ Tox.ResponseNonce $ Tox.qryNonce $ queryExtra q
+    messageSender q _ = Tox.msgClient q
+    messageResponder _ r = Tox.msgClient r
+
+instance KRPC Tox.Message (Query    Tox.Message (Ping Tox.Message))
+                          (Response Tox.Message (Ping Tox.Message)) where
+    method = Method Tox.Ping
+    validateExchange = validateToxExchange
+    makeQueryExtra _ _ _ _ = Tox.QueryNonce <$> randomIO
+    makeResponseExtra _ _ q _ = return $ Tox.ResponseNonce $ Tox.qryNonce $ queryExtra q
+    messageSender q _ = Tox.msgClient q
+    messageResponder _ r = Tox.msgClient r
+
+instance DataHandlers ByteString Tox.Message
+
+instance Default Bool where def = False
+
+getToxPing isPong c n = do
+    q'r <- get :: Get Word8
+    when (bool 0 1 isPong /= q'r) $
+        fail "Tox ping/pong parse fail."
+    n8 <- get :: Get Tox.Nonce8
+    return $ c (n n8) Ping
+
+putToxPing isPong n8 = do
+    put (bool 0 1 isPong :: Word8)
+    put n8
+
+validateToxExchange q r = qnonce == rnonce
+      where
+        qnonce = Tox.qryNonce . queryExtra    . Tox.msgPayload $ q
+        rnonce = Tox.rspNonce . responseExtra . Tox.msgPayload $ r
+
+
+nodeFormatToNodeInfo nf = NodeInfo nid addr u
+ where
+    u    = Tox.nodeIsTCP nf
+    addr = NodeAddr (Tox.nodeIP nf) (Tox.nodePort nf)
+    nid  = Tox.nodePublicKey nf
+
+-- instance Default Bool where def = False