blob: d6fc866f5bad09003dc43eaecf25a63e955e3a34 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
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
|
