summaryrefslogtreecommitdiff
path: root/examples
diff options
context:
space:
mode:
Diffstat (limited to 'examples')
-rw-r--r--examples/dhtd.hs615
1 files changed, 174 insertions, 441 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index ab256831..5c1bbb26 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1,88 +1,53 @@
1{-# LANGUAGE NondecreasingIndentation #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE MultiParamTypeClasses #-} 4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE LambdaCase #-} 5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE NondecreasingIndentation #-}
8{-# LANGUAGE TupleSections #-} 8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE RecordWildCards #-} 9{-# LANGUAGE PartialTypeSignatures #-}
10{-# LANGUAGE PartialTypeSignatures #-} 10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE CPP #-} 11{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE RankNTypes #-} 12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TypeFamilies #-} 13{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TypeFamilies #-}
14 15
15import Control.Arrow 16import Control.Arrow
17import Control.Concurrent.STM
18import Control.DeepSeq
19import Control.Exception
16import Control.Monad 20import Control.Monad
17import Control.Monad.Logger
18import Control.Monad.Reader
19import Data.Char 21import Data.Char
20import Data.Default 22import Data.List
21import Data.List as L 23import qualified Data.Map as Map
22import Data.Maybe 24import Data.Time.Clock
23import Data.String
24import qualified Data.Set as Set
25import qualified Data.ByteString as B (ByteString,writeFile,readFile)
26 ; import Data.ByteString (ByteString)
27import qualified Data.ByteString.Char8 as B8
28import System.IO
29import System.IO.Error
30import Text.PrettyPrint.HughesPJClass
31import Text.Printf
32import Text.Read hiding (get)
33import Control.Monad.Reader.Class
34import System.Posix.Process (getProcessID)
35import GHC.Stats 25import GHC.Stats
26import Network.Socket
27import System.Environment
28import System.IO
36import System.Mem 29import System.Mem
37import Data.Word 30import System.Posix.Process
38 31import Text.Printf
39import Data.Torrent (InfoHash) 32import Text.Read
40import Network.Address
41import Network.BitTorrent.DHT
42import Network.BitTorrent.DHT.Search
43import Network.BitTorrent.DHT.Query
44import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..))
45import Network.DatagramServer (QueryFailure(..))
46import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf)
47import qualified Network.DatagramServer.Tox as Tox
48import qualified Network.DHT.Routing as R
49import Network.BitTorrent.DHT.Session
50import Network.SocketLike
51import Network.StreamServer
52import Control.Exception.Lifted as Lifted
53#ifdef THREAD_DEBUG 33#ifdef THREAD_DEBUG
54import Control.Concurrent.Lifted.Instrument 34import Control.Concurrent.Lifted.Instrument
55import Data.Time ()
56import Data.Time.Clock
57#else 35#else
58import Control.Concurrent 36import Control.Concurrent.Lifted
37import GHC.Conc (labelThread)
59#endif 38#endif
60import Control.Concurrent.STM 39
61import System.Environment 40import Network.Address hiding (NodeId, NodeInfo(..))
62import Data.BEncode (BValue) 41import Network.QueryResponse
63import Network.DHT.Types 42import Network.StreamServer
64import Network.DHT.Tox 43import Kademlia
65import Network.DatagramServer.Types 44import qualified Mainline
66import Data.Bits 45import Network.DHT.Routing as R
67import Data.Serialize 46import Data.Aeson as J (ToJSON, FromJSON)
68import Network.KRPC.Method 47import qualified Data.Aeson as J
69import Data.Typeable 48import qualified Data.ByteString.Lazy as L
70import GHC.Generics 49import Control.Concurrent.Async.Pool
71import Data.Bool 50import System.IO.Error
72import System.Random
73import Network.DatagramServer.Mainline (PacketDestination(..))
74
75mkNodeAddr :: SockAddr -> NodeAddr IPv4
76mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr)
77 (fromMaybe 0 $ sockAddrPort addr) -- FIXME
78
79btBindAddr :: String -> Bool -> IO (NodeAddr IPv4)
80btBindAddr s b = mkNodeAddr <$> getBindAddress s b
81
82printReport :: MonadIO m => [(String,String)] -> m ()
83printReport kvs = liftIO $ do
84 putStrLn (showReport kvs)
85 hFlush stdout
86 51
87showReport :: [(String,String)] -> String 52showReport :: [(String,String)] -> String
88showReport kvs = do 53showReport kvs = do
@@ -90,93 +55,6 @@ showReport kvs = do
90 (k,v) <- kvs 55 (k,v) <- kvs
91 concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] 56 concat [ printf " %-*s" (colwidth+1) k, v, "\n" ]
92 57
93showEnry ::
94 ( Show a
95 , Pretty (NodeId dht)
96 ) => (NodeInfo dht a u, t) -> [Char]
97showEnry (n,_) = intercalate " "
98 [ show $ pPrint (nodeId n)
99 , show $ nodeAddr n
100 ]
101
102printTable ::
103 ( Pretty (NodeId dht)
104 ) => DHT raw dht u IPv4 ()
105printTable = do
106 t <- showTable
107 liftIO $ do
108 putStrLn t
109 hFlush stdout
110
111showTable ::
112 ( Pretty (NodeId dht)
113 ) => DHT raw dht u IPv4 String
114showTable = do
115 nodes <- R.toList <$> getTable
116 return $ showReport
117 $ map (show *** showEnry)
118 $ concat $ zipWith map (map (,) [0::Int ..]) nodes
119
120bootstrapNodes :: IO [NodeAddr IPv4]
121bootstrapNodes = mapMaybe fromAddr
122 <$> mapM resolveHostName defaultBootstrapNodes
123
124-- ExtendedCaps (Map.singleton
125
126noDebugPrints :: LogSource -> LogLevel -> Bool
127noDebugPrints _ = \case LevelDebug -> False
128 LevelOther _ -> False
129 _ -> True
130
131noLogging :: LogSource -> LogLevel -> Bool
132noLogging _ _ = False
133
134allNoise :: LogSource -> LogLevel -> Bool
135allNoise _ _ = True
136
137resume :: DHT raw dht u IPv4 (Maybe B.ByteString)
138resume = do
139 restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat"
140 saved_nodes <-
141 either (const $ do liftIO $ putStrLn "Error reading dht-nodes.dat"
142 return Nothing)
143 (return . Just)
144 restore_attempt
145 return saved_nodes
146
147godht ::
148 ( Eq (QueryMethod dht)
149 , Show (QueryMethod dht)
150 , Functor dht
151 , Ord (TransactionID dht)
152 , Serialize (TransactionID dht)
153 , Kademlia dht
154 , WireFormat raw dht
155 , DataHandlers raw dht
156 , SerializableTo raw (Query dht (FindNode dht IPv4))
157 , SerializableTo raw (Response dht (NodeFound dht IPv4))
158 , SerializableTo raw (Query dht (Ping dht))
159 , SerializableTo raw (Response dht (Ping dht))
160 , KRPC dht (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4))
161 , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht))
162 , Ord (NodeId dht)
163 , FiniteBits (NodeId dht)
164 , Serialize (NodeId dht)
165 , Show (NodeId dht)
166 , Pretty (NodeId dht)
167 , Pretty (NodeInfo dht IPv4 u)
168 , Default u
169 , Show u
170 , Typeable dht
171 ) => String -> (NodeAddr IPv4 -> NodeId dht -> DHT raw dht u IPv4 b) -> IO b
172godht p f = do
173 a <- btBindAddr p False
174 dht def { optTimeout = 5 } a allNoise $ do
175 me0 <- asks tentativeNodeId
176 printReport [("tentative node-id",show $ pPrint me0)
177 ,("listen-address", show a)
178 ]
179 f a me0
180 58
181marshalForClient :: String -> String 59marshalForClient :: String -> String
182marshalForClient s = show (length s) ++ ":" ++ s 60marshalForClient s = show (length s) ++ ":" ++ s
@@ -184,120 +62,78 @@ marshalForClient s = show (length s) ++ ":" ++ s
184hPutClient :: Handle -> String -> IO () 62hPutClient :: Handle -> String -> IO ()
185hPutClient h s = hPutStr h ('.' : marshalForClient s) 63hPutClient h s = hPutStr h ('.' : marshalForClient s)
186 64
187hPutClientChunk :: Handle -> String -> IO () 65data DHT = forall ni. ( Show ni
188hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) 66 , Read ni
189 67 , ToJSON ni
190data GenericDHT ip a 68 , FromJSON ni
191 = GenericDHT 69 ) =>
192 (forall raw dht u. 70 DHT
193 ( Eq (QueryMethod dht) 71 { dhtBuckets :: TVar (BucketList ni)
194 , Show (QueryMethod dht) 72 , dhtPing :: ni -> IO Bool
195 , Functor dht 73 -- dhtClient :: Client err meth tid addr x
196 , Ord (TransactionID dht) 74 }
197 , Serialize (TransactionID dht) 75
198 , Kademlia dht 76nodesFileName :: String -> String
199 , WireFormat raw dht 77nodesFileName netname = netname ++ "-nodes.json"
200 , DataHandlers raw dht 78
201 , SerializableTo raw (Query dht (FindNode dht ip)) 79saveNodes :: String -> DHT -> IO ()
202 , SerializableTo raw (Response dht (NodeFound dht ip)) 80saveNodes netname (DHT var _) = do
203 , SerializableTo raw (Query dht (Ping dht)) 81 bkts <- atomically $ readTVar var
204 , SerializableTo raw (Response dht (Ping dht)) 82 let ns = map fst $ concat $ R.toList bkts
205 , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) 83 bs = J.encode ns
206 , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht)) 84 fname = nodesFileName netname
207 , Ord (NodeId dht) 85 L.writeFile fname bs
208 , FiniteBits (NodeId dht) 86
209 , Serialize (NodeId dht) 87loadNodes :: FromJSON ni => String -> IO [ni]
210 , Show (NodeId dht) 88loadNodes netname = do
211 , Pretty (NodeId dht) 89 let fname = nodesFileName netname
212 , Pretty (NodeInfo dht ip ()) 90 attempt <- tryIOError $ do
213 , Pretty (NodeInfo dht ip u) 91 J.decode <$> L.readFile fname
214 , Default u 92 >>= maybe (ioError $ userError "Nothing") return
215 , Show u 93 either (const $ return []) return attempt
216 , Read (NodeId dht) 94
217 ) => DHT raw dht u ip a) 95pingNodes :: String -> DHT -> IO Bool
218 | BtDHT (DHT BValue KMessageOf () ip a) 96pingNodes netname (DHT _ ping) = do
219 97 let fname = nodesFileName netname
220dhtType :: DHT raw dht u ip (Proxy dht) 98 attempt <- tryIOError $ do
221dhtType = return Proxy 99 J.decode <$> L.readFile fname
222 100 >>= maybe (ioError $ userError "Nothing") return
223nodeIdType :: NodeId dht -> DHT raw dht u ip () 101 case attempt of
224nodeIdType _ = return () 102 Left _ -> return False
225 103 Right ns -> do fork $ do
226nodeAddrType :: NodeAddr ip -> DHT raw dht u ip () 104 myThreadId >>= flip labelThread ("pinging."++fname)
227nodeAddrType _ = return () 105 putStrLn $ "Forked "++show fname
228 106 withTaskGroup 10 $ \g -> do
229ipType :: f dht ip -> DHT raw dht u ip () 107 mapTasks_ g (map ping ns)
230ipType _ = return () 108 putStrLn $ "Load finished "++show fname
231 109 return True
232clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool -> RestrictedSocket -> Int -> Handle -> IO () 110
233clientSession bt tox signalQuit isBt sock n h = do 111
112
113reportTable :: Show ni => BucketList ni -> [(String,String)]
114reportTable bkts = map (show *** show . fst)
115 $ concat
116 $ zipWith map (map (,) [0::Int ..])
117 $ R.toList
118 $ bkts
119
120clientSession netname dhts signalQuit sock n h = do
234 line <- map toLower . dropWhile isSpace <$> hGetLine h 121 line <- map toLower . dropWhile isSpace <$> hGetLine h
235 let dht :: Either (Node BValue KMessageOf () IPv4) 122 let (c,args) = second (dropWhile isSpace) $ break isSpace line
236 (Node B.ByteString Tox.Message Bool IPv4)
237 dht | isBt = Left bt
238 | otherwise = Right tox
239 cmd0 :: IO () -> IO () 123 cmd0 :: IO () -> IO ()
240 cmd0 action = action >> clientSession bt tox signalQuit isBt sock n h 124 cmd0 action = action >> clientSession netname dhts signalQuit sock n h
241 cmd :: GenericDHT IPv4 (IO ()) -> IO () 125 switchNetwork dest = do hPutClient h ("Network: "++dest)
242 cmd (GenericDHT action) = cmd0 $ join $ either (flip runDHT action) (flip runDHT action) dht 126 clientSession dest dhts signalQuit sock n h
243 cmd (BtDHT action) = cmd0 $ join $ runDHT bt action
244 (c,args) = second (dropWhile isSpace) $ break isSpace line
245 switchNetwork dest = hPutClient h ("Network: "++if dest then "mainline" else "tox") >> clientSession bt tox signalQuit dest sock n h
246 case (c,args) of 127 case (c,args) of
247
248 ("bt", _) -> switchNetwork True
249
250 ("tox", _) -> switchNetwork False
251
252 ("quit", _) -> hPutClient h "" >> hClose h
253
254 ("stop", _) -> do hPutClient h "Terminating DHT Daemon." 128 ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
255 hClose h 129 hClose h
256 putMVar signalQuit () 130 putMVar signalQuit ()
257 131
132 ("quit", _) -> hPutClient h "" >> hClose h
133
258 ("pid", _) -> cmd0 $ do 134 ("pid", _) -> cmd0 $ do
259 pid <- getProcessID 135 pid <- getProcessID
260 hPutClient h (show pid) 136 hPutClient h (show pid)
261
262 -- DHT specific
263 ("ls", _) -> cmd $ GenericDHT $ do
264 tbl <- getTable
265 t <- showTable
266 me <- myNodeIdAccordingTo (read "8.8.8.8:6881")
267 ip <- routableAddress
268 return $ do
269 hPutClient h $ unlines
270 [ t
271 , showReport
272 [ ("node-id", show $ pPrint me)
273 , ("internet address", show ip)
274 , ("buckets", show $ R.shape tbl)
275 , ("network", if isBt then "mainline" else "tox") ]
276 ]
277 ("external-ip", _) -> cmd $ BtDHT $ do
278 ip <- routableAddress
279 return $ do
280 hPutClient h $ maybe "" (takeWhile (/=':') . show) ip
281
282 ("swarms", s) -> cmd $ BtDHT $ do
283 let fltr = case s of
284 ('-':'v':cs) | all isSpace (take 1 cs)
285 -> const True
286 _ -> (\(h,c,n) -> c/=0 )
287 ss <- getSwarms
288 let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n))
289 $ filter fltr ss
290 return $ do
291 hPutClient h $ showReport r
292
293 -- bittorrent only
294 ("peers", s) -> cmd $ BtDHT $ case readEither s of
295 Right ih -> do
296 ps <- allPeers ih
297 seq ih $ return $ do
298 hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps
299 Left er -> return $ hPutClient h er
300
301#ifdef THREAD_DEBUG 137#ifdef THREAD_DEBUG
302 ("threads", _) -> cmd0 $ do 138 ("threads", _) -> cmd0 $ do
303 ts <- threadsInformation 139 ts <- threadsInformation
@@ -337,191 +173,88 @@ clientSession bt tox signalQuit isBt sock n h = do
337 _ -> hPutClient h "error." 173 _ -> hPutClient h "error."
338 174
339#endif 175#endif
340 -- DHT specific 176 ("ls", _) | Just (DHT var _) <- Map.lookup netname dhts
341 ("closest", s) -> cmd $ GenericDHT $ do 177 -> cmd0 $ do
342 let (ns,hs) = second (dropWhile isSpace) $ break isSpace s 178 bkts <- atomically $ readTVar var
343 parse | null hs = do 179 let r = reportTable bkts
344 ih <- readEither ns 180 hPutClient h $
345 return (8 :: Int, ih) 181 showReport $
346 | otherwise = do 182 r ++ [ ("buckets", show $ R.shape bkts)
347 n <- readEither ns 183 , ("node-id", show $ thisNode bkts)
348 ih <- readEither hs 184 , ("network", netname) ]
349 return (n :: Int, ih) 185
350 case parse of 186 ("ping", s) | Just (DHT _ ping) <- Map.lookup netname dhts
351 Right (n,ih) -> do 187 -> cmd0 $ do
352 nodeIdType ih 188 case readEither s of
353 tbl <- getTable 189 Right addr -> do result <- ping addr
354 let nodes = R.kclosest n ih tbl 190 let rs = [" ", show result]
355 return $ do 191 hPutClient h $ unlines rs
356 hPutClient h $ unlines $ map (showEnry . (flip (,) (error "showEnry"))) nodes 192 Left er -> hPutClient h er
357 Left er -> return $ hPutClient h er 193
358 194 ("save", _) | Just dht <- Map.lookup netname dhts
359 -- DHT specific 195 -> cmd0 $ do
360 ("ping", s) -> cmd $ GenericDHT $ do 196 saveNodes netname dht
361 case readEither s of 197 hPutClient h $ "Saved " ++ nodesFileName netname ++ "."
362 Right addr -> do result <- try $ pingQ addr 198
363 let rs = either (pure . showQueryFail) reportPong result 199 ("load", _) | Just dht <- Map.lookup netname dhts
364 return $ do 200 -> cmd0 $ do
365 hPutClient h $ unlines rs 201 b <- pingNodes netname dht
366 Left er -> return $ hPutClient h er 202 if b then hPutClient h $ "Pinging " ++ nodesFileName netname ++ "."
367 203 else hPutClient h $ "Failed: " ++ nodesFileName netname ++ "."
368 -- DHT specific 204 (n, _) | n `elem` Map.keys dhts -> switchNetwork n
369 --
370 -- Current syntax:
371 -- find-nodes c55729c4adeb286017f512c7316059e052c98e67 179.197.102.29:59933
372 --
373 --
374 ("find-nodes", s) -> cmd $ GenericDHT $ do
375 let (hs,as) = second (dropWhile isSpace) $ break isSpace s
376 parse = do ih <- readEither hs
377 a <- readEither as
378 return (ih, a) -- :: NodeAddr IPv4)
379 case parse of
380 Right (ih,a) -> do
381 nodeIdType ih
382 -- nodeAddrType a
383 proxy <- dhtType
384 let fn = findNodeMessage proxy ih
385 ipType fn
386 result <- try $ queryNode' a fn
387 either (const $ return ()) (\(nid,nf,_) -> nodeIdType nid >> ipType nf) result
388 let rs = either (pure . showQueryFail) reportNodes result
389 return $ do
390 hPutClient h $ unlines rs
391 Left er -> return $ hPutClient h er
392
393 -- bittorrent only
394 ("get-peers", s) -> cmd $ BtDHT $ do
395 let (hs,as) = second (dropWhile isSpace) $ break isSpace s
396 parse = do ih <- readEither hs
397 a <- readEither as
398 return (ih :: InfoHash, a)
399 case parse of
400 Right (ih,a) -> do
401 result <- try $ queryNode' a $ GetPeers ih
402 let rs = either (pure . ( (,) "error" ) . showQueryFail) reportPeers result
403 return $ do
404 hPutClient h $ showReport rs
405 Left er -> return $ hPutClient h er
406
407 -- bittorrent only
408 ("search-peers", s) -> cmd $ BtDHT $ do
409 case readEither s of
410 Right ih -> do
411 (tid, s) <- isearch ioGetPeers ih
412 flip fix Set.empty $ \again shown -> do
413 (chk,fin) <- liftIO . atomically $ do
414 r <- (Set.\\ shown) <$> readTVar (searchResults s)
415 if not $ Set.null r
416 then (,) r <$> searchIsFinished s
417 else searchIsFinished s >>= check >> return (Set.empty,True)
418 let ps = case Set.toList chk of
419 [] -> ""
420 _ -> unlines $ map (show . pPrint) $ Set.toList chk
421 if fin then return $ hPutClient h ps
422 else do
423 liftIO $ hPutClientChunk h ps
424 again (shown `Set.union` chk)
425 Left er -> return $ hPutClient h er
426 205
427 _ -> cmd0 $ hPutClient h "error." 206 _ -> cmd0 $ hPutClient h "error."
428 207
429defaultPort = error "TODO defaultPort" 208defaultPort = "6881"
430
431showQueryFail :: QueryFailure -> String
432showQueryFail e = show e
433
434consip (ReflectedIP ip) xs = ("(external-ip " ++ show ip ++ ")") : xs
435 209
436consip' (ReflectedIP ip) xs = ("to", show ip) : xs
437
438reportPong (info,myip) = maybe id consip myip [show $ pPrint info]
439
440reportNodes ::
441 ( Kademlia dht
442 , Pretty (NodeInfo dht ip ())
443 , Pretty (NodeId dht)
444 ) => (NodeId dht, NodeFound dht ip, Maybe ReflectedIP) -> [String]
445reportNodes (nid,ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) (foundNodes ns)
446
447reportPeers :: (NodeId KMessageOf, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)]
448reportPeers (nid,GotPeers r tok,myip)
449 = maybe id consip' myip $ ("from", show (pPrint nid))
450 : ("token", show tok)
451 : case r of
452 Right ps -> map ( ( (,) "peer" ) . show . pPrint ) ps
453 Left ns -> map ( ( (,) "node" ) . show . pPrint ) ns
454
455main :: IO ()
456main = do 210main = do
457 args <- getArgs 211 args <- getArgs
458 p <- case take 2 (dropWhile (/="-p") args) of 212 p <- case take 2 (dropWhile (/="-p") args) of
459 ["-p",port] | not ("-" `isPrefixOf` port) -> return port 213 ["-p",port] | not ("-" `isPrefixOf` port) -> return port
460 ("-p":_) -> error "Port not specified! (-p PORT)" 214 ("-p":_) -> error "Port not specified! (-p PORT)"
461 _ -> defaultPort 215 _ -> return defaultPort
462 216 addr <- getBindAddress p True{- ipv6 -}
463 tox_state <- godht (show (succ (read p::Int))) $ \a me0 -> ask 217
464 218 (bt,btR) <- Mainline.newClient addr
465 godht p $ \a me0 -> do 219 quitBt <- forkListener bt
466 printTable 220
467 bs <- liftIO bootstrapNodes 221 tox <- return $ error "TODO: Tox.newClient"
468 `onException` 222 quitTox <- return $ return () -- TODO: forkListener tox
469 (Lifted.ioError $ userError "unable to resolve bootstrap nodes") 223
470 saved_nodes <- resume 224 let dhts = Map.fromList
471 225 [ ("bt4", DHT (Mainline.routing4 btR) (Mainline.ping bt))
472 peers'trial <- liftIO $ tryIOError $ B.readFile "bt-peers.dat" 226 , ("bt6", DHT (Mainline.routing6 btR) (Mainline.ping bt))
473 saved_peers <- 227 ]
474 either (const $ do liftIO $ putStrLn "Error reading bt-peers.dat" 228
475 return Nothing) 229 waitForSignal <- do
476 (return . Just)
477 peers'trial
478
479 maybe (return ()) mergeSavedPeers saved_peers
480
481 when (isJust saved_nodes) $ do
482 b <- isBootstrapped
483 tbl <- getTable
484 bc <- optBucketCount <$> asks options
485 printTable
486 me <- case concat $ R.toList tbl of
487 (n,_):_ -> myNodeIdAccordingTo (nodeAddr n)
488 _ -> return me0
489 printReport [("node-id",show $ pPrint me)
490 ,("listen-address", show a)
491 ,("bootstrapped", show b)
492 ,("buckets", show $ R.shape tbl)
493 ,("optBucketCount", show bc)
494 ,("dht-nodes.dat", "Running bootstrap...")
495 ]
496
497 st <- ask
498 waitForSignal <- liftIO $ do
499 signalQuit <- newEmptyMVar 230 signalQuit <- newEmptyMVar
500 srv <- streamServer (withSession $ clientSession st tox_state signalQuit True) (SockAddrUnix "dht.sock") 231 srv <- streamServer (withSession $ clientSession "bt4" dhts signalQuit) (SockAddrUnix "dht.sock")
501 return $ liftIO $ do 232 return $ do
502 () <- takeMVar signalQuit 233 () <- takeMVar signalQuit
503 quitListening srv 234 quitListening srv
504 235
505 bootstrap saved_nodes (map (MainlineNode . toSockAddr) bs) 236 let bkts4 = Mainline.routing4 btR
506 237 btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo]
507 b <- isBootstrapped 238 putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4."
508 tbl <- getTable 239 fallbackNodes4 <- Mainline.bootstrapNodes Mainline.Want_IP4
509 bc <- optBucketCount <$> asks options 240 fork $ do
510 printTable 241 myThreadId >>= flip labelThread "bootstrap.Mainline4"
511 ip <- routableAddress 242 bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4
512 me <- case concat $ R.toList tbl of 243 saveNodes "bt4" (dhts Map.! "bt4")
513 (n,_):_ -> myNodeIdAccordingTo (nodeAddr n) 244
514 _ -> return me0 245 btSaved6 <- loadNodes "bt6"
515 printReport [("node-id",show $ pPrint me) 246 putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6."
516 ,("internet address", show ip) 247 let bkts6 = Mainline.routing6 btR
517 ,("listen-address", show a) 248 fallbackNodes6 <- Mainline.bootstrapNodes Mainline.Want_IP6
518 ,("bootstrapped", show b) 249 fork $ do
519 ,("buckets", show $ R.shape tbl) 250 myThreadId >>= flip labelThread "bootstrap.Mainline6"
520 ,("optBucketCount", show bc) 251 bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6
521 ] 252 saveNodes "bt6" (dhts Map.! "bt6")
522 253
523 waitForSignal -- Await unix socket to signal termination. 254 hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4
524 255 ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6
525 snapshot >>= liftIO . B.writeFile "dht-nodes.dat" 256
526 savePeerStore >>= liftIO . B.writeFile "bt-peers.dat" 257 waitForSignal
527 258
259 quitBt
260 quitTox
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 09:26:38 +0000