diff options
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r-- | examples/dhtd.hs | 91 |
1 files changed, 1 insertions, 90 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index d9b02c41..15db79ea 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -61,6 +61,7 @@ import Control.Concurrent.STM | |||
61 | import System.Environment | 61 | import System.Environment |
62 | import Data.BEncode (BValue) | 62 | import Data.BEncode (BValue) |
63 | import Network.DHT.Types | 63 | import Network.DHT.Types |
64 | import Network.DHT.Tox | ||
64 | import Network.DatagramServer.Types | 65 | import Network.DatagramServer.Types |
65 | import Data.Bits | 66 | import Data.Bits |
66 | import Data.Serialize | 67 | import Data.Serialize |
@@ -227,96 +228,6 @@ nodeAddrType _ = return () | |||
227 | ipType :: f dht ip -> DHT raw dht u ip () | 228 | ipType :: f dht ip -> DHT raw dht u ip () |
228 | ipType _ = return () | 229 | ipType _ = return () |
229 | 230 | ||
230 | instance Kademlia Tox.Message where | ||
231 | data DHTData Tox.Message ip = ToxData | ||
232 | namePing _ = Tox.Ping | ||
233 | nameFindNodes _ = Tox.GetNodes | ||
234 | initializeDHTData = return ToxData | ||
235 | |||
236 | instance Pretty (NodeId Tox.Message) where | ||
237 | pPrint (Tox.NodeId nid) = encodeHexDoc nid | ||
238 | |||
239 | getToxPing isPong c n = do | ||
240 | q'r <- get :: Get Word8 | ||
241 | when (bool 0 1 isPong /= q'r) $ | ||
242 | fail "Tox ping/pong parse fail." | ||
243 | n8 <- get :: Get Tox.Nonce8 | ||
244 | return $ c (n n8) Ping | ||
245 | |||
246 | putToxPing isPong n8 = do | ||
247 | put (bool 0 1 isPong :: Word8) | ||
248 | put n8 | ||
249 | |||
250 | instance Serialize (Query Tox.Message (Ping Tox.Message)) where | ||
251 | get = getToxPing False Network.DHT.Types.Query Tox.QueryNonce | ||
252 | put (Network.DHT.Types.Query extra Ping) = putToxPing False (Tox.qryNonce extra) | ||
253 | instance Serialize (Response Tox.Message (Ping Tox.Message)) where | ||
254 | get = getToxPing True Network.DHT.Types.Response Tox.ResponseNonce | ||
255 | put (Network.DHT.Types.Response extra Ping) = putToxPing True (Tox.rspNonce extra) | ||
256 | |||
257 | nodeFormatToNodeInfo nf = NodeInfo nid addr u | ||
258 | where | ||
259 | u = Tox.nodeIsTCP nf | ||
260 | addr = NodeAddr (Tox.nodeIP nf) (Tox.nodePort nf) | ||
261 | nid = Tox.nodePublicKey nf | ||
262 | |||
263 | instance Serialize (Query Tox.Message (FindNode Tox.Message ip)) where | ||
264 | get = do | ||
265 | nid <- get | ||
266 | n8 <- get | ||
267 | return $ Network.DHT.Types.Query (Tox.QueryNonce n8) (FindNode nid) | ||
268 | put (Network.DHT.Types.Query (Tox.QueryNonce n8) (FindNode nid)) = do | ||
269 | put nid | ||
270 | put n8 | ||
271 | instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
272 | get = do | ||
273 | num <- get :: Get Word8 | ||
274 | when (num > 4) $ fail "Too many nodes in Tox get-nodes reply" | ||
275 | ns0 <- sequence $ replicate (fromIntegral num) (nodeFormatToNodeInfo <$> get) | ||
276 | -- TODO: Allow tcp and ipv6. For now filtering to udp ip4... | ||
277 | let ns = flip mapMaybe ns0 $ \(NodeInfo nid addr u) -> do | ||
278 | guard $ not u | ||
279 | ip4 <- fromAddr addr | ||
280 | return $ NodeInfo nid ip4 () | ||
281 | n8 <- get | ||
282 | return $ Network.DHT.Types.Response (Tox.ResponseNonce n8) $ NodeFound ns | ||
283 | put (Network.DHT.Types.Response (Tox.ResponseNonce n8) (NodeFound ns)) = do | ||
284 | put ( fromIntegral (length ns) :: Word8 ) | ||
285 | forM_ ns $ \(NodeInfo nid ip4 ()) -> do | ||
286 | put Tox.NodeFormat { nodePublicKey = nid | ||
287 | , nodeIsTCP = False | ||
288 | , nodeIP = IPv4 (nodeHost ip4) | ||
289 | , nodePort = nodePort ip4 | ||
290 | } | ||
291 | put n8 | ||
292 | |||
293 | validateToxExchange q r = qnonce == rnonce | ||
294 | where | ||
295 | qnonce = Tox.qryNonce . queryExtra . Tox.msgPayload $ q | ||
296 | rnonce = Tox.rspNonce . responseExtra . Tox.msgPayload $ r | ||
297 | |||
298 | instance KRPC Tox.Message (Query Tox.Message (FindNode Tox.Message IPv4)) | ||
299 | (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
300 | method = Method Tox.GetNodes | ||
301 | validateExchange = validateToxExchange | ||
302 | makeQueryExtra _ _ _ _ = Tox.QueryNonce <$> randomIO | ||
303 | makeResponseExtra _ _ q _ = return $ Tox.ResponseNonce $ Tox.qryNonce $ queryExtra q | ||
304 | messageSender q _ = Tox.msgClient q | ||
305 | messageResponder _ r = Tox.msgClient r | ||
306 | |||
307 | instance KRPC Tox.Message (Query Tox.Message (Ping Tox.Message)) | ||
308 | (Response Tox.Message (Ping Tox.Message)) where | ||
309 | method = Method Tox.Ping | ||
310 | validateExchange = validateToxExchange | ||
311 | makeQueryExtra _ _ _ _ = Tox.QueryNonce <$> randomIO | ||
312 | makeResponseExtra _ _ q _ = return $ Tox.ResponseNonce $ Tox.qryNonce $ queryExtra q | ||
313 | messageSender q _ = Tox.msgClient q | ||
314 | messageResponder _ r = Tox.msgClient r | ||
315 | |||
316 | instance DataHandlers ByteString Tox.Message | ||
317 | |||
318 | instance Default Bool where def = False | ||
319 | |||
320 | clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool -> RestrictedSocket -> Int -> Handle -> IO () | 231 | clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool -> RestrictedSocket -> Int -> Handle -> IO () |
321 | clientSession bt tox signalQuit isBt sock n h = do | 232 | clientSession bt tox signalQuit isBt sock n h = do |
322 | line <- map toLower . dropWhile isSpace <$> hGetLine h | 233 | line <- map toLower . dropWhile isSpace <$> hGetLine h |