diff options
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r-- | examples/dhtd.hs | 220 |
1 files changed, 187 insertions, 33 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 8496dd5a..99ff7218 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -1,5 +1,7 @@ | |||
1 | {-# LANGUAGE NondecreasingIndentation #-} | 1 | {-# LANGUAGE NondecreasingIndentation #-} |
2 | {-# LANGUAGE FlexibleContexts #-} | 2 | {-# LANGUAGE FlexibleContexts #-} |
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | 5 | {-# LANGUAGE LambdaCase #-} |
4 | {-# LANGUAGE OverloadedStrings #-} | 6 | {-# LANGUAGE OverloadedStrings #-} |
5 | {-# LANGUAGE ScopedTypeVariables #-} | 7 | {-# LANGUAGE ScopedTypeVariables #-} |
@@ -7,6 +9,7 @@ | |||
7 | {-# LANGUAGE RecordWildCards #-} | 9 | {-# LANGUAGE RecordWildCards #-} |
8 | {-# LANGUAGE PartialTypeSignatures #-} | 10 | {-# LANGUAGE PartialTypeSignatures #-} |
9 | {-# LANGUAGE CPP #-} | 11 | {-# LANGUAGE CPP #-} |
12 | {-# LANGUAGE RankNTypes #-} | ||
10 | 13 | ||
11 | import Control.Arrow | 14 | import Control.Arrow |
12 | import Control.Monad | 15 | import Control.Monad |
@@ -39,6 +42,7 @@ import Network.BitTorrent.DHT.Query | |||
39 | import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..)) | 42 | import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..)) |
40 | import Network.DatagramServer (QueryFailure(..)) | 43 | import Network.DatagramServer (QueryFailure(..)) |
41 | import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf) | 44 | import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf) |
45 | import qualified Network.DatagramServer.Tox as Tox | ||
42 | import qualified Network.DHT.Routing as R | 46 | import qualified Network.DHT.Routing as R |
43 | import Network.BitTorrent.DHT.Session | 47 | import Network.BitTorrent.DHT.Session |
44 | import Network.SocketLike | 48 | import Network.SocketLike |
@@ -53,6 +57,14 @@ import Control.Concurrent | |||
53 | #endif | 57 | #endif |
54 | import Control.Concurrent.STM | 58 | import Control.Concurrent.STM |
55 | import System.Environment | 59 | import System.Environment |
60 | import Data.BEncode (BValue) | ||
61 | import Network.DHT.Types | ||
62 | import Network.DatagramServer.Types | ||
63 | import Data.Bits | ||
64 | import Data.Serialize | ||
65 | import Network.KRPC.Method | ||
66 | import Data.Typeable | ||
67 | import GHC.Generics | ||
56 | 68 | ||
57 | mkNodeAddr :: SockAddr -> NodeAddr IPv4 | 69 | mkNodeAddr :: SockAddr -> NodeAddr IPv4 |
58 | mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr) | 70 | mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr) |
@@ -72,20 +84,27 @@ showReport kvs = do | |||
72 | (k,v) <- kvs | 84 | (k,v) <- kvs |
73 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] | 85 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] |
74 | 86 | ||
75 | showEnry :: Show a => (NodeInfo KMessageOf a (), t) -> [Char] | 87 | showEnry :: |
88 | ( Show a | ||
89 | , Pretty (NodeId dht) | ||
90 | ) => (NodeInfo dht a u, t) -> [Char] | ||
76 | showEnry (n,_) = intercalate " " | 91 | showEnry (n,_) = intercalate " " |
77 | [ show $ pPrint (nodeId n) | 92 | [ show $ pPrint (nodeId n) |
78 | , show $ nodeAddr n | 93 | , show $ nodeAddr n |
79 | ] | 94 | ] |
80 | 95 | ||
81 | printTable :: DHT IPv4 () | 96 | printTable :: |
97 | ( Pretty (NodeId dht) | ||
98 | ) => DHT raw dht u IPv4 () | ||
82 | printTable = do | 99 | printTable = do |
83 | t <- showTable | 100 | t <- showTable |
84 | liftIO $ do | 101 | liftIO $ do |
85 | putStrLn t | 102 | putStrLn t |
86 | hFlush stdout | 103 | hFlush stdout |
87 | 104 | ||
88 | showTable :: DHT IPv4 String | 105 | showTable :: |
106 | ( Pretty (NodeId dht) | ||
107 | ) => DHT raw dht u IPv4 String | ||
89 | showTable = do | 108 | showTable = do |
90 | nodes <- R.toList <$> getTable | 109 | nodes <- R.toList <$> getTable |
91 | return $ showReport | 110 | return $ showReport |
@@ -109,7 +128,7 @@ noLogging _ _ = False | |||
109 | allNoise :: LogSource -> LogLevel -> Bool | 128 | allNoise :: LogSource -> LogLevel -> Bool |
110 | allNoise _ _ = True | 129 | allNoise _ _ = True |
111 | 130 | ||
112 | resume :: DHT IPv4 (Maybe B.ByteString) | 131 | resume :: DHT raw dht u IPv4 (Maybe B.ByteString) |
113 | resume = do | 132 | resume = do |
114 | restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat" | 133 | restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat" |
115 | saved_nodes <- | 134 | saved_nodes <- |
@@ -119,7 +138,30 @@ resume = do | |||
119 | restore_attempt | 138 | restore_attempt |
120 | return saved_nodes | 139 | return saved_nodes |
121 | 140 | ||
122 | godht :: String -> (NodeAddr IPv4 -> NodeId _ -> DHT IPv4 b) -> IO b | 141 | godht :: |
142 | ( Eq (QueryMethod dht) | ||
143 | , Show (QueryMethod dht) | ||
144 | , Functor dht | ||
145 | , Ord (TransactionID dht) | ||
146 | , Serialize (TransactionID dht) | ||
147 | , Kademlia dht | ||
148 | , WireFormat raw dht | ||
149 | , DataHandlers raw dht | ||
150 | , SerializableTo raw (Query dht (FindNode dht IPv4)) | ||
151 | , SerializableTo raw (Response dht (NodeFound dht IPv4)) | ||
152 | , SerializableTo raw (Query dht (Ping dht)) | ||
153 | , SerializableTo raw (Response dht (Ping dht)) | ||
154 | , KRPC (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4)) | ||
155 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
156 | , Ord (NodeId dht) | ||
157 | , FiniteBits (NodeId dht) | ||
158 | , Serialize (NodeId dht) | ||
159 | , Show (NodeId dht) | ||
160 | , Pretty (NodeId dht) | ||
161 | , Pretty (NodeInfo dht IPv4 u) | ||
162 | , Default u | ||
163 | , Show u | ||
164 | ) => String -> (NodeAddr IPv4 -> NodeId dht -> DHT raw dht u IPv4 b) -> IO b | ||
123 | godht p f = do | 165 | godht p f = do |
124 | a <- btBindAddr p False | 166 | a <- btBindAddr p False |
125 | dht def { optTimeout = 5 } a noDebugPrints $ do | 167 | dht def { optTimeout = 5 } a noDebugPrints $ do |
@@ -138,21 +180,118 @@ hPutClient h s = hPutStr h ('.' : marshalForClient s) | |||
138 | hPutClientChunk :: Handle -> String -> IO () | 180 | hPutClientChunk :: Handle -> String -> IO () |
139 | hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) | 181 | hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) |
140 | 182 | ||
141 | clientSession :: Node IPv4 -> MVar () -> RestrictedSocket -> Int -> Handle -> IO () | 183 | data GenericDHT ip a |
142 | clientSession st signalQuit sock n h = do | 184 | = GenericDHT |
185 | (forall raw dht u. | ||
186 | ( Eq (QueryMethod dht) | ||
187 | , Show (QueryMethod dht) | ||
188 | , Functor dht | ||
189 | , Ord (TransactionID dht) | ||
190 | , Serialize (TransactionID dht) | ||
191 | , Kademlia dht | ||
192 | , WireFormat raw dht | ||
193 | , DataHandlers raw dht | ||
194 | , SerializableTo raw (Query dht (FindNode dht ip)) | ||
195 | , SerializableTo raw (Response dht (NodeFound dht ip)) | ||
196 | , SerializableTo raw (Query dht (Ping dht)) | ||
197 | , SerializableTo raw (Response dht (Ping dht)) | ||
198 | , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) | ||
199 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
200 | , Ord (NodeId dht) | ||
201 | , FiniteBits (NodeId dht) | ||
202 | , Serialize (NodeId dht) | ||
203 | , Show (NodeId dht) | ||
204 | , Pretty (NodeId dht) | ||
205 | , Pretty (NodeInfo dht ip ()) | ||
206 | , Pretty (NodeInfo dht ip u) | ||
207 | , Default u | ||
208 | , Show u | ||
209 | , Read (NodeId dht) | ||
210 | ) => DHT raw dht u ip a) | ||
211 | | BtDHT (DHT BValue KMessageOf () ip a) | ||
212 | |||
213 | dhtType :: DHT raw dht u ip (Proxy dht) | ||
214 | dhtType = return Proxy | ||
215 | |||
216 | nodeIdType :: NodeId dht -> DHT raw dht u ip () | ||
217 | nodeIdType _ = return () | ||
218 | |||
219 | nodeAddrType :: NodeAddr ip -> DHT raw dht u ip () | ||
220 | nodeAddrType _ = return () | ||
221 | |||
222 | ipType :: f dht ip -> DHT raw dht u ip () | ||
223 | ipType _ = return () | ||
224 | |||
225 | instance Kademlia Tox.Message where | ||
226 | instance Pretty (NodeId Tox.Message) where | ||
227 | instance Pretty (NodeInfo Tox.Message IPv4 ()) where | ||
228 | instance Pretty (NodeInfo Tox.Message IPv4 Bool) where -- TODO | ||
229 | instance Read (NodeId KMessageOf) where -- TODO | ||
230 | instance Read (NodeId Tox.Message) where -- TODO | ||
231 | instance Serialize (FindNode Tox.Message IPv4) where | ||
232 | get = error "TODO get" | ||
233 | put = error "TODO put" | ||
234 | instance Serialize (NodeFound Tox.Message IPv4) where | ||
235 | get = error "TODO get" | ||
236 | put = error "TODO put" | ||
237 | instance Serialize (Ping Tox.Message) where | ||
238 | get = error "TODO get" | ||
239 | put = error "TODO put" | ||
240 | instance Serialize (Query Tox.Message (FindNode Tox.Message IPv4)) where | ||
241 | get = error "TODO get" | ||
242 | put = error "TODO put" | ||
243 | instance Serialize (Query Tox.Message (Ping Tox.Message)) where -- TODO | ||
244 | get = error "TODO get" | ||
245 | put = error "TODO put" | ||
246 | instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
247 | get = error "TODO get" | ||
248 | put = error "TODO put" | ||
249 | instance Serialize (Response Tox.Message (Ping Tox.Message)) where -- TODO | ||
250 | get = error "TODO get" | ||
251 | put = error "TODO put" | ||
252 | instance KRPC (Query Tox.Message (FindNode Tox.Message IPv4)) | ||
253 | (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
254 | instance KRPC (Query Tox.Message (Ping Tox.Message )) | ||
255 | (Response Tox.Message (Ping Tox.Message )) where | ||
256 | instance DataHandlers ByteString Tox.Message where | ||
257 | |||
258 | |||
259 | -- instance Generic (Response Tox.Message (NodeFound Tox.Message IPv4)) where -- TODO | ||
260 | |||
261 | instance Default Bool where def = False | ||
262 | |||
263 | clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool -> RestrictedSocket -> Int -> Handle -> IO () | ||
264 | clientSession bt tox signalQuit isBt sock n h = do | ||
143 | line <- map toLower . dropWhile isSpace <$> hGetLine h | 265 | line <- map toLower . dropWhile isSpace <$> hGetLine h |
144 | let cmd0 action = action >> clientSession st signalQuit sock n h | 266 | let dht :: Either (Node BValue KMessageOf () IPv4) |
145 | cmd action = cmd0 $ join $ runDHT st action | 267 | (Node B.ByteString Tox.Message Bool IPv4) |
268 | dht | isBt = Left bt | ||
269 | | otherwise = Right tox | ||
270 | cmd0 :: IO () -> IO () | ||
271 | cmd0 action = action >> clientSession bt tox signalQuit isBt sock n h | ||
272 | cmd :: GenericDHT IPv4 (IO ()) -> IO () | ||
273 | cmd (GenericDHT action) = cmd0 $ join $ either (flip runDHT action) (flip runDHT action) dht | ||
274 | cmd (BtDHT action) = cmd0 $ join $ runDHT bt action | ||
146 | (c,args) = second (dropWhile isSpace) $ break isSpace line | 275 | (c,args) = second (dropWhile isSpace) $ break isSpace line |
276 | switchNetwork dest = clientSession bt tox signalQuit dest sock n h | ||
147 | case (c,args) of | 277 | case (c,args) of |
148 | 278 | ||
279 | ("bt", _) -> switchNetwork True | ||
280 | |||
281 | ("tox", _) -> switchNetwork False | ||
282 | |||
149 | ("quit", _) -> hPutClient h "" >> hClose h | 283 | ("quit", _) -> hPutClient h "" >> hClose h |
150 | 284 | ||
151 | ("stop", _) -> do hPutClient h "Terminating DHT Daemon." | 285 | ("stop", _) -> do hPutClient h "Terminating DHT Daemon." |
152 | hClose h | 286 | hClose h |
153 | putMVar signalQuit () | 287 | putMVar signalQuit () |
154 | 288 | ||
155 | ("ls", _) -> cmd $ do | 289 | ("pid", _) -> cmd0 $ do |
290 | pid <- getProcessID | ||
291 | hPutClient h (show pid) | ||
292 | |||
293 | -- DHT specific | ||
294 | ("ls", _) -> cmd $ GenericDHT $ do | ||
156 | tbl <- getTable | 295 | tbl <- getTable |
157 | t <- showTable | 296 | t <- showTable |
158 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") | 297 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") |
@@ -163,14 +302,15 @@ clientSession st signalQuit sock n h = do | |||
163 | , showReport | 302 | , showReport |
164 | [ ("node-id", show $ pPrint me) | 303 | [ ("node-id", show $ pPrint me) |
165 | , ("internet address", show ip) | 304 | , ("internet address", show ip) |
166 | , ("buckets", show $ R.shape tbl)] | 305 | , ("buckets", show $ R.shape tbl) |
306 | , ("network", if isBt then "mainline" else "tox") ] | ||
167 | ] | 307 | ] |
168 | ("external-ip", _) -> cmd $ do | 308 | ("external-ip", _) -> cmd $ BtDHT $ do |
169 | ip <- routableAddress | 309 | ip <- routableAddress |
170 | return $ do | 310 | return $ do |
171 | hPutClient h $ maybe "" (takeWhile (/=':') . show) ip | 311 | hPutClient h $ maybe "" (takeWhile (/=':') . show) ip |
172 | 312 | ||
173 | ("swarms", s) -> cmd $ do | 313 | ("swarms", s) -> cmd $ BtDHT $ do |
174 | let fltr = case s of | 314 | let fltr = case s of |
175 | ('-':'v':cs) | all isSpace (take 1 cs) | 315 | ('-':'v':cs) | all isSpace (take 1 cs) |
176 | -> const True | 316 | -> const True |
@@ -181,23 +321,21 @@ clientSession st signalQuit sock n h = do | |||
181 | return $ do | 321 | return $ do |
182 | hPutClient h $ showReport r | 322 | hPutClient h $ showReport r |
183 | 323 | ||
184 | ("peers", s) -> cmd $ case readEither s of | 324 | -- bittorrent only |
325 | ("peers", s) -> cmd $ BtDHT $ case readEither s of | ||
185 | Right ih -> do | 326 | Right ih -> do |
186 | ps <- allPeers ih | 327 | ps <- allPeers ih |
187 | seq ih $ return $ do | 328 | seq ih $ return $ do |
188 | hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps | 329 | hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps |
189 | Left er -> return $ hPutClient h er | 330 | Left er -> return $ hPutClient h er |
190 | 331 | ||
191 | ("pid", _) -> cmd $ return $ do | ||
192 | pid <- getProcessID | ||
193 | hPutClient h (show pid) | ||
194 | #ifdef THREAD_DEBUG | 332 | #ifdef THREAD_DEBUG |
195 | ("threads", _) -> cmd $ return $ do | 333 | ("threads", _) -> cmd0 $ do |
196 | ts <- threadsInformation | 334 | ts <- threadsInformation |
197 | tm <- getCurrentTime | 335 | tm <- getCurrentTime |
198 | let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts | 336 | let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts |
199 | hPutClient h $ showReport r | 337 | hPutClient h $ showReport r |
200 | ("mem", s) -> cmd $ return $ do | 338 | ("mem", s) -> cmd0 $ do |
201 | case s of | 339 | case s of |
202 | "gc" -> do hPutClient h "Performing garbage collection..." | 340 | "gc" -> do hPutClient h "Performing garbage collection..." |
203 | performMajorGC | 341 | performMajorGC |
@@ -230,24 +368,27 @@ clientSession st signalQuit sock n h = do | |||
230 | _ -> hPutClient h "error." | 368 | _ -> hPutClient h "error." |
231 | 369 | ||
232 | #endif | 370 | #endif |
233 | ("closest", s) -> cmd $ do | 371 | -- DHT specific |
372 | ("closest", s) -> cmd $ GenericDHT $ do | ||
234 | let (ns,hs) = second (dropWhile isSpace) $ break isSpace s | 373 | let (ns,hs) = second (dropWhile isSpace) $ break isSpace s |
235 | parse | null hs = do | 374 | parse | null hs = do |
236 | ih <- readEither ns | 375 | ih <- readEither ns |
237 | return (8 :: Int, ih :: InfoHash) | 376 | return (8 :: Int, ih) |
238 | | otherwise = do | 377 | | otherwise = do |
239 | n <- readEither ns | 378 | n <- readEither ns |
240 | ih <- readEither hs | 379 | ih <- readEither hs |
241 | return (n :: Int, ih :: InfoHash) | 380 | return (n :: Int, ih) |
242 | case parse of | 381 | case parse of |
243 | Right (n,ih) -> do | 382 | Right (n,ih) -> do |
383 | nodeIdType ih | ||
244 | tbl <- getTable | 384 | tbl <- getTable |
245 | let nodes = R.kclosest n ih tbl | 385 | let nodes = R.kclosest n ih tbl |
246 | return $ do | 386 | return $ do |
247 | hPutClient h $ unlines $ map (showEnry . (flip (,) 0)) nodes | 387 | hPutClient h $ unlines $ map (showEnry . (flip (,) (error "showEnry"))) nodes |
248 | Left er -> return $ hPutClient h er | 388 | Left er -> return $ hPutClient h er |
249 | 389 | ||
250 | ("ping", s) -> cmd $ do | 390 | -- DHT specific |
391 | ("ping", s) -> cmd $ GenericDHT $ do | ||
251 | case readEither s of | 392 | case readEither s of |
252 | Right addr -> do result <- try $ pingQ addr | 393 | Right addr -> do result <- try $ pingQ addr |
253 | let rs = either (pure . showQueryFail) reportPong result | 394 | let rs = either (pure . showQueryFail) reportPong result |
@@ -255,22 +396,30 @@ clientSession st signalQuit sock n h = do | |||
255 | hPutClient h $ unlines rs | 396 | hPutClient h $ unlines rs |
256 | Left er -> return $ hPutClient h er | 397 | Left er -> return $ hPutClient h er |
257 | 398 | ||
258 | ("find-nodes", s) -> cmd $ do | 399 | -- DHT specific |
400 | ("find-nodes", s) -> cmd $ GenericDHT $ do | ||
259 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s | 401 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s |
260 | parse = do ih <- readEither hs | 402 | parse = do ih <- readEither hs |
261 | a <- readEither as | 403 | a <- readEither as |
262 | -- XXX: using 'InfoHash' only because 'NodeId' currently | 404 | -- XXX: using 'InfoHash' only because 'NodeId' currently |
263 | -- has no 'Read' instance. | 405 | -- has no 'Read' instance. |
264 | return (ih :: InfoHash, a :: NodeAddr IPv4) | 406 | return (ih, a :: NodeAddr IPv4) |
265 | case parse of | 407 | case parse of |
266 | Right (ih,a) -> do | 408 | Right (ih,a) -> do |
267 | result <- try $ queryNode' (a ::NodeAddr IPv4) $ FindNode (R.toNodeId ih) | 409 | nodeIdType ih |
410 | nodeAddrType a | ||
411 | proxy <- dhtType | ||
412 | let fn = findNodeMessage proxy ih | ||
413 | ipType fn | ||
414 | result <- try $ queryNode' a fn | ||
415 | either (const $ return ()) (\(nid,nf,_) -> nodeIdType nid >> ipType nf) result | ||
268 | let rs = either (pure . showQueryFail) reportNodes result | 416 | let rs = either (pure . showQueryFail) reportNodes result |
269 | return $ do | 417 | return $ do |
270 | hPutClient h $ unlines rs | 418 | hPutClient h $ unlines rs |
271 | Left er -> return $ hPutClient h er | 419 | Left er -> return $ hPutClient h er |
272 | 420 | ||
273 | ("get-peers", s) -> cmd $ do | 421 | -- bittorrent only |
422 | ("get-peers", s) -> cmd $ BtDHT $ do | ||
274 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s | 423 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s |
275 | parse = do ih <- readEither hs | 424 | parse = do ih <- readEither hs |
276 | a <- readEither as | 425 | a <- readEither as |
@@ -283,7 +432,8 @@ clientSession st signalQuit sock n h = do | |||
283 | hPutClient h $ showReport rs | 432 | hPutClient h $ showReport rs |
284 | Left er -> return $ hPutClient h er | 433 | Left er -> return $ hPutClient h er |
285 | 434 | ||
286 | ("search-peers", s) -> cmd $ do | 435 | -- bittorrent only |
436 | ("search-peers", s) -> cmd $ BtDHT $ do | ||
287 | case readEither s of | 437 | case readEither s of |
288 | Right ih -> do | 438 | Right ih -> do |
289 | (tid, s) <- isearch ioGetPeers ih | 439 | (tid, s) <- isearch ioGetPeers ih |
@@ -315,10 +465,14 @@ consip' (ReflectedIP ip) xs = ("to", show ip) : xs | |||
315 | 465 | ||
316 | reportPong (info,myip) = maybe id consip myip [show $ pPrint info] | 466 | reportPong (info,myip) = maybe id consip myip [show $ pPrint info] |
317 | 467 | ||
318 | reportNodes :: (NodeId _, NodeFound IPv4, Maybe ReflectedIP) -> [String] | 468 | reportNodes :: |
319 | reportNodes (nid,NodeFound ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) ns | 469 | ( Kademlia dht |
470 | , Pretty (NodeInfo dht ip ()) | ||
471 | , Pretty (NodeId dht) | ||
472 | ) => (NodeId dht, NodeFound dht ip, Maybe ReflectedIP) -> [String] | ||
473 | reportNodes (nid,ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) (foundNodes ns) | ||
320 | 474 | ||
321 | reportPeers :: (NodeId _, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)] | 475 | reportPeers :: (NodeId KMessageOf, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)] |
322 | reportPeers (nid,GotPeers r tok,myip) | 476 | reportPeers (nid,GotPeers r tok,myip) |
323 | = maybe id consip' myip $ ("from", show (pPrint nid)) | 477 | = maybe id consip' myip $ ("from", show (pPrint nid)) |
324 | : ("token", show tok) | 478 | : ("token", show tok) |
@@ -368,7 +522,7 @@ main = do | |||
368 | st <- ask | 522 | st <- ask |
369 | waitForSignal <- liftIO $ do | 523 | waitForSignal <- liftIO $ do |
370 | signalQuit <- newEmptyMVar | 524 | signalQuit <- newEmptyMVar |
371 | srv <- streamServer (withSession $ clientSession st signalQuit) (SockAddrUnix "dht.sock") | 525 | srv <- streamServer (withSession $ clientSession st (error "todo: tox state") signalQuit True) (SockAddrUnix "dht.sock") |
372 | return $ liftIO $ do | 526 | return $ liftIO $ do |
373 | () <- takeMVar signalQuit | 527 | () <- takeMVar signalQuit |
374 | quitListening srv | 528 | quitListening srv |