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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.BitTorrent.DHT
( dhtServer
) where
import Control.Applicative
import Control.Concurrent.STM
import Data.ByteString
import Data.Serialize as S
import Data.Function
import Data.Ord
import Data.HashMap.Strict as HM
import Network
import Network.Socket
import Remote.KRPC
import Data.BEncode
import Data.Torrent
import Data.Kademlia.Routing.Table
{-----------------------------------------------------------------------
Node
-----------------------------------------------------------------------}
type NodeId = ByteString
-- WARN is the 'system' random suitable for this?
-- | Generate random NodeID used for the entire session.
-- Distribution of ID's should be as uniform as possible.
--
genNodeID :: IO NodeId
genNodeID = undefined -- randomIO
instance Serialize PortNumber where
get = fromIntegral <$> getWord16be
put = putWord16be . fromIntegral
data NodeAddr = NodeAddr {
nodeIP :: !HostAddress
, nodePort :: !PortNumber
} deriving (Show, Eq)
instance Serialize NodeAddr where
get = NodeAddr <$> getWord32be <*> get
put NodeAddr {..} = do
putWord32be nodeIP
put nodePort
data NodeInfo = NodeInfo {
nodeID :: !NodeId
, nodeAddr :: !NodeAddr
} deriving (Show, Eq)
instance Serialize NodeInfo where
get = NodeInfo <$> getByteString 20 <*> get
put NodeInfo {..} = put nodeID >> put nodeAddr
type CompactInfo = ByteString
decodeCompact :: CompactInfo -> Either String [NodeInfo]
decodeCompact = S.runGet (many get)
encodeCompact :: [NodeId] -> CompactInfo
encodeCompact = S.runPut . mapM_ put
type Distance = NodeId
--type DHT k v = StateT (Table k v) IO
--findNode :: NodeID -> DHT k v [NodeInfo]
--findNode = undefined
genSecret :: IO Secret
genSecret = undefined
type Token = Int
type Secret = Int
token :: NodeAddr -> Secret -> Token
token = return undefined
defaultToken :: Token
defaultToken = 0xdeadbeef
{-----------------------------------------------------------------------
Routing table
-----------------------------------------------------------------------}
-- TODO use more compact routing table
type RoutingTable = HashMap NodeId NodeAddr
type Alpha = Int
kclosest :: Int -> NodeId -> RoutingTable -> [NodeId]
kclosest = undefined
{-----------------------------------------------------------------------
Node session
-----------------------------------------------------------------------}
data NodeSession = NodeSession {
nodeId :: !NodeId
, routingTable :: !(TVar RoutingTable)
, alpha :: !Alpha
}
instance Eq NodeSession where
(==) = (==) `on` nodeId
instance Ord NodeSession where
compare = comparing nodeId
{-----------------------------------------------------------------------
Queries
-----------------------------------------------------------------------}
instance BEncodable PortNumber where
pingM :: Method NodeId NodeId
pingM = method "ping" ["id"] ["id"]
findNodeM :: Method (NodeId, NodeId) (NodeId, CompactInfo)
findNodeM = method "find_node" ["id", "target"] ["id", "nodes"]
-- | Lookup peers by a torrent infohash.
getPeersM :: Method (NodeId, InfoHash) (NodeId, Token, CompactInfo) -- use Map ByteString BEncode
getPeersM = method "get_peers" ["id", "info_hash"] ["id", "token", "nodes"]
-- | Used to announce that the peer, controlling the quering node is
-- downloading a torrent on a port.
announcePeerM :: Method (NodeId, InfoHash, PortNumber, Token) NodeId
announcePeerM = method "announce_peer" ["id", "info_hash", "port", "token"] ["id"]
pingC :: NodeSession -> NodeAddr -> IO ()
pingC NodeSession {..} addr @ NodeAddr {..} = do
nid <- call (nodeIP, nodePort) pingM nodeId
atomically $ modifyTVar' routingTable $ HM.insert nid addr
--getPeerC :: NodeSession -> NodeAddr -> InfoHash -> IO (Either CompactInfo )
getPeerC NodeSession {..} addr @ NodeAddr {..} ih = do
call (nodeIP, nodePort) getPeersM
type ServerHandler a b = NodeSession -> NodeAddr -> a -> IO b
pingS :: ServerHandler NodeId NodeId
pingS NodeSession {..} addr nid = do
atomically $ modifyTVar' routingTable $ HM.insert nid addr
return nodeId
findNodeS :: ServerHandler (NodeId, NodeId) (NodeId, CompactInfo)
findNodeS NodeSession {..} addr (nid, qnid) = do
rt <- atomically $ readTVar routingTable
return (nodeId, encodeCompact $ kclosest alpha qnid rt)
getPeersS :: ServerHandler (NodeId, InfoHash) (NodeId, Token, CompactInfo)
getPeersS NodeSession {..} addr (nid, ih) = do
return (nodeId, defaultToken, error "compact info")
announcePeerS :: ServerHandler (NodeId, InfoHash, PortNumber, Token) NodeId
announcePeerS NodeSession {..} addr (nid, ih, port, token) = do
let right = (error "checkToken")
return nodeId
dhtServer :: PortNumber -> NodeSession -> IO ()
dhtServer p s = server p
[ pingM ==> pingS s undefined
, findNodeM ==> findNodeS s undefined
, getPeersM ==> getPeersS s undefined
, announcePeerM ==> announcePeerS s undefined
]
|
