{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} import Control.Arrow import Control.Concurrent.STM import Control.DeepSeq import Control.Exception import Control.Monad import Data.Char import Data.Hashable import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import Data.Time.Clock import GHC.Conc (threadStatus,ThreadStatus(..)) import GHC.Stats import Network.Socket import System.Environment import System.IO import System.Mem import System.Posix.Process import Text.PrettyPrint.HughesPJClass import Text.Printf import Text.Read #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent.Lifted import GHC.Conc (labelThread) #endif import Network.Address hiding (NodeId, NodeInfo(..)) import Network.Kademlia.Search import Network.QueryResponse import Network.StreamServer import Network.Kademlia import qualified Network.BitTorrent.MainlineDHT as Mainline import qualified Network.Tox as Tox import Network.Kademlia.Routing as R import Data.Aeson as J (ToJSON, FromJSON) import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as L import Control.Concurrent.Tasks import System.IO.Error import qualified Data.Serialize as S import Network.BitTorrent.DHT.ContactInfo as Peers import qualified Data.MinMaxPSQ as MM import Data.Wrapper.PSQ as PSQ (pattern (:->)) import qualified Data.Wrapper.PSQ as PSQ import Data.Ord import Data.Time.Clock.POSIX import qualified Network.Tox.DHT.Transport as Tox import qualified Network.Tox.DHT.Handlers as Tox import qualified Network.Tox.Onion.Handlers as Tox import Data.Typeable showReport :: [(String,String)] -> String showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs showColumns :: [[[Char]]] -> [Char] showColumns rows = do let cols = transpose rows ws = map (maximum . map (succ . length)) cols fs <- rows _ <- take 1 fs -- Guard against empty rows so that 'last' is safe. " " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n" marshalForClient :: String -> String marshalForClient s = show (length s) ++ ":" ++ s -- | Writes a message and signals ready for next command. hPutClient :: Handle -> String -> IO () hPutClient h s = hPutStr h ('.' : marshalForClient s) -- | Writes message, but signals there is more to come. hPutClientChunk :: Handle -> String -> IO () hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) data DHTQuery nid ni = forall addr r tok. ( Ord addr , Typeable r )=> DHTQuery { qsearch :: Search nid addr tok ni r , qhandler :: ni -> nid -> IO ([ni], [r], tok) , qshowR :: r -> String , qshowTok :: tok -> Maybe String } data DHTSearch nid ni = forall addr tok r. DHTSearch { searchThread :: ThreadId , searchState :: SearchState nid addr tok ni r , searchShowTok :: tok -> Maybe String , searchResults :: TVar (Set.Set String) } data DHT = forall nid ni. ( Show ni , Read ni , ToJSON ni , FromJSON ni , Ord ni , Hashable ni , Show nid , Ord nid , Hashable nid , Typeable ni , S.Serialize nid ) => DHT { dhtBuckets :: TVar (BucketList ni) , dhtPing :: ni -> IO Bool , dhtQuery :: Map.Map String (DHTQuery nid ni) , dhtParseId :: String -> Either String nid , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni)) , dhtFallbackNodes :: IO [ni] } nodesFileName :: String -> String nodesFileName netname = netname ++ "-nodes.json" saveNodes :: String -> DHT -> IO () saveNodes netname DHT{dhtBuckets} = do bkts <- atomically $ readTVar dhtBuckets let ns = map fst $ concat $ R.toList bkts bs = J.encode ns fname = nodesFileName netname L.writeFile fname bs loadNodes :: FromJSON ni => String -> IO [ni] loadNodes netname = do let fname = nodesFileName netname attempt <- tryIOError $ do J.decode <$> L.readFile fname >>= maybe (ioError $ userError "Nothing") return either (const $ return []) return attempt pingNodes :: String -> DHT -> IO Bool pingNodes netname DHT{dhtPing} = do let fname = nodesFileName netname attempt <- tryIOError $ do J.decode <$> L.readFile fname >>= maybe (ioError $ userError "Nothing") return case attempt of Left _ -> return False Right ns -> do fork $ do myThreadId >>= flip labelThread ("pinging."++fname) putStrLn $ "Forked "++show fname withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do mapM_ (\n -> forkTask g (show n) $ void $ dhtPing n) (ns `asTypeOf` []) putStrLn $ "Load finished "++show fname return True reportTable :: Show ni => BucketList ni -> [(String,String)] reportTable bkts = map (show *** show . fst) $ concat $ zipWith map (map (,) [0::Int ..]) $ R.toList $ bkts reportResult :: String -> (r -> String) -> (tok -> Maybe String) -> (ni -> String) -> Handle -> Either String ([ni],[r],tok) -> IO () reportResult meth showR showTok showN h (Left e) = hPutClient h e reportResult meth showR showTok showN h (Right (ns,rs,tok)) = do hPutClient h $ showReport report where report = intercalate [("","")] [ tok_r , node_r , result_r ] tok_r = maybe [] (pure . ("token:",)) $ showTok tok node_r = map ( ("n",) . showN ) ns result_r | (meth=="node") = [] | otherwise = map ( (take 1 meth,) . showR ) rs -- example: -- * 10 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535 -- - 1 peer 141d6c6ee2810f46d28bbe8373d4f454a4122535 -- 22 node 141d6c6ee2810f46d28bbe8373d4f454a4122535 -- -- key: '*' in progress -- '-' stopped -- ' ' finished showSearches :: ( Show nid , Ord nid , Hashable nid , Ord ni , Hashable ni ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String showSearches searches = do tups <- forM (Map.toList searches) $ \((meth,nid),DHTSearch{..}) -> do (is'fin, cnt) <- atomically $ (,) <$> searchIsFinished searchState <*> (Set.size <$> readTVar searchResults) tstat <- threadStatus searchThread let stat = case tstat of _ | is'fin -> ' ' ThreadFinished -> '-' ThreadDied -> '-' _ -> '*' return (stat,show cnt,meth,show nid) let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups return $ do -- List monad. (stat,cnt,meth,nid) <- tups printf " %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid forkSearch :: ( Ord nid , Hashable nid , Ord ni , Hashable ni , Show nid ) => String -> nid -> DHTQuery nid ni -> TVar (Map.Map (String,nid) (DHTSearch nid ni)) -> TVar (BucketList ni) -> ThreadId -> TVar (Maybe (IO ())) -> STM () forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets tid kvar = do ns <- R.kclosest (searchSpace qsearch) searchK nid <$> readTVar dhtBuckets st <- newSearch qsearch nid ns results <- newTVar Set.empty let storeResult r = modifyTVar' results (Set.insert (qshowR r)) >> return True new = DHTSearch { searchThread = tid , searchState = st , searchShowTok = qshowTok , searchResults = results } modifyTVar' dhtSearches $ Map.insert (method,nid) new writeTVar kvar $ Just $ searchLoop qsearch nid storeResult st reportSearchResults :: (Show t, Ord t1, Ord t, Hashable t) => String -> Handle -> DHTSearch t1 t -> IO () reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = do (ns,rs) <- atomically $ do mm <- readTVar $ searchInformant searchState rset <- readTVar searchResults let ns = map (\(MM.Binding ni tok _) -> (ni,tok)) $ MM.toList mm rs = Set.toList rset return (ns,rs) let n'width = succ $ maximum $ map (length . show . fst) ns showN (n,tok) = take n'width (show n ++ repeat ' ') ++ (fromMaybe "" $ searchShowTok tok) ns' = map showN ns reportResult meth id (const Nothing) id h (Right (ns',rs,())) data Session = Session { netname :: String , dhts :: Map.Map String DHT , externalAddresses :: IO [SockAddr] , swarms :: Mainline.SwarmsDatabase , toxkeys :: TVar Tox.AnnouncedKeys , signalQuit :: MVar () } clientSession :: Session -> t1 -> t -> Handle -> IO () clientSession s@Session{..} sock cnum h = do line <- map toLower . dropWhile isSpace <$> hGetLine h let (c,args) = second (dropWhile isSpace) $ break isSpace line cmd0 :: IO () -> IO () cmd0 action = action >> clientSession s sock cnum h switchNetwork dest = do hPutClient h ("Network: "++dest) clientSession s{netname=dest} sock cnum h case (c,args) of ("stop", _) -> do hPutClient h "Terminating DHT Daemon." hClose h putMVar signalQuit () ("quit", _) -> hPutClient h "" >> hClose h ("pid", _) -> cmd0 $ do pid <- getProcessID hPutClient h (show pid) ("external-ip", _) -> cmd0 $ do unlines . map (either show show . either4or6) <$> externalAddresses >>= hPutClient h #ifdef THREAD_DEBUG ("threads", _) -> cmd0 $ do ts <- threadsInformation tm <- getCurrentTime r <- forM ts $ \(tid,PerThread{..}) -> do stat <- threadStatus tid let showStat (ThreadBlocked reason) = show reason showStat stat = show stat return [show lbl,show (diffUTCTime tm startTime),showStat stat] hPutClient h $ showColumns r #endif ("mem", s) -> cmd0 $ do case s of "gc" -> do hPutClient h "Performing garbage collection..." performMajorGC "" -> do is_enabled <- getGCStatsEnabled if is_enabled then do GCStats{..} <- getGCStats let r = [ ("bytesAllocated", show bytesAllocated) , ("numGcs", show numGcs) , ("maxBytesUsed", show maxBytesUsed) , ("numByteUsageSamples", show numByteUsageSamples) , ("cumulativeBytesUsed", show cumulativeBytesUsed) , ("bytesCopied", show bytesCopied) , ("currentBytesUsed", show currentBytesUsed) , ("currentBytesSlop", show currentBytesSlop) , ("maxBytesSlop", show maxBytesSlop) , ("peakMegabytesAllocated", show peakMegabytesAllocated) , ("mutatorCpuSeconds", show mutatorCpuSeconds) , ("mutatorWallSeconds", show mutatorWallSeconds) , ("gcCpuSeconds", show gcCpuSeconds) , ("gcWallSeconds", show gcWallSeconds) , ("cpuSeconds", show cpuSeconds) , ("wallSeconds", show wallSeconds) , ("parTotBytesCopied", show parTotBytesCopied) , ("parMaxBytesCopied", show parMaxBytesCopied) ] hPutClient h $ showReport r else hPutClient h "Run with +RTS -T to obtain live memory-usage information." _ -> hPutClient h "error." ("ls", _) | Just DHT{dhtBuckets} <- Map.lookup netname dhts -> cmd0 $ do bkts <- atomically $ readTVar dhtBuckets let r = reportTable bkts hPutClient h $ showReport $ r ++ [ ("buckets", show $ R.shape bkts) , ("node-id", show $ thisNode bkts) , ("network", netname) ] ("ping", s) | Just DHT{dhtPing} <- Map.lookup netname dhts -> cmd0 $ do case readEither s of Right addr -> do result <- dhtPing addr let rs = [" ", show result] hPutClient h $ unlines rs Left er -> hPutClient h er ("g", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do -- arguments: method -- nid -- (optional dest-ni) self <- atomically $ thisNode <$> readTVar dhtBuckets let (method,xs) = break isSpace $ dropWhile isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs destination = dropWhile isSpace ys goQuery qry = either (hPutClient h . ("Bad search target: "++)) (goTarget qry) $ dhtParseId nidstr goTarget DHTQuery{..} nid = go nid >>= reportResult method qshowR qshowTok show h where go | null destination = fmap Right . qhandler self | otherwise = case readEither destination of Right ni -> fmap (maybe (Left "Timeout.") Right) . flip (searchQuery qsearch) ni Left e -> const $ return $ Left ("Bad destination: "++e) maybe (hPutClient h ("Unsupported method: "++method)) goQuery $ Map.lookup method dhtQuery ("s", s) | Just dht@DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let (method,xs) = break isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs presentSearches = hPutClient h =<< showSearches =<< atomically (readTVar dhtSearches) goTarget qry nid = do kvar <- atomically $ newTVar Nothing -- Forking a thread, but it may ubruptly quit if the following -- STM action decides not to add a new search. This is so that -- I can store the ThreadId into new DHTSearch structure. tid <- fork $ join $ atomically (readTVar kvar >>= maybe retry return) join $ atomically $ do schs <- readTVar dhtSearches case Map.lookup (method,nid) schs of Nothing -> do forkSearch method nid qry dhtSearches dhtBuckets tid kvar return $ presentSearches Just sch -> do writeTVar kvar (Just $ return ()) return $ reportSearchResults method h sch goQuery qry = either (hPutClient h . ("Bad search target: "++)) (goTarget qry) $ dhtParseId nidstr if null method then presentSearches else maybe (hPutClient h ("Unsupported method: "++method)) goQuery $ Map.lookup method dhtQuery ("x", s) | Just DHT{..} <- Map.lookup netname dhts -> cmd0 $ do let (method,xs) = break isSpace s (nidstr,ys) = break isSpace $ dropWhile isSpace xs go nid = join $ atomically $ do schs <- readTVar dhtSearches case Map.lookup (method,nid) schs of Nothing -> return $ hPutClient h "No match." Just DHTSearch{searchThread} -> do modifyTVar' dhtSearches (Map.delete (method,nid)) return $ do killThread searchThread hPutClient h "Removed search." either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr ("save", _) | Just dht <- Map.lookup netname dhts -> cmd0 $ do saveNodes netname dht hPutClient h $ "Saved " ++ nodesFileName netname ++ "." ("load", _) | Just dht <- Map.lookup netname dhts -> cmd0 $ do b <- pingNodes netname dht if b then hPutClient h $ "Pinging " ++ nodesFileName netname ++ "." else hPutClient h $ "Failed: " ++ nodesFileName netname ++ "." ("swarms", s) -> cmd0 $ do let fltr = case s of ('-':'v':cs) | all isSpace (take 1 cs) -> const True _ -> (\(h,c,n) -> c/=0 ) ss <- atomically $ Peers.knownSwarms <$> readTVar (Mainline.contactInfo swarms) let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n)) $ filter fltr ss hPutClient h $ showReport r ("peers", s) -> cmd0 $ case readEither s of Right ih -> do ps <- atomically $ Peers.lookup ih <$> readTVar (Mainline.contactInfo swarms) hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps Left er -> hPutClient h er ("keys", s) -> cmd0 $ do keydb <- atomically $ readTVar toxkeys now <- getPOSIXTime let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb) mkentry (k :-> Down tm) = [ show cnt, show k, show (now - tm) ] where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb) hPutClient h $ showColumns entries (n, _) | n `elem` Map.keys dhts -> switchNetwork n _ -> cmd0 $ hPutClient h "error." readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr] readExternals nodeAddr vars = do as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars let unspecified (SockAddrInet _ 0) = True unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True unspecified _ = False -- TODO: Filter to only global addresses? return $ filter (not . unspecified) as data Options = Options { portbt :: String , porttox :: String , ip6bt :: Bool , ip6tox :: Bool } deriving (Eq,Show) sensibleDefaults :: Options sensibleDefaults = Options { portbt = "6881" , porttox = "33445" , ip6bt = True , ip6tox = True } -- bt=,tox= -- -4 parseArgs :: [String] -> Options -> Options parseArgs [] opts = opts parseArgs ("-4":args) opts = parseArgs args opts { ip6bt = False , ip6tox = False } parseArgs (arg:args) opts = parseArgs args opts { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports } where ports = map ( (dropWhile (==',') *** dropWhile (=='=')) . break (=='=') ) $ groupBy (const (/= ',')) arg main :: IO () main = do args <- getArgs let opts = parseArgs args sensibleDefaults print opts swarms <- Mainline.newSwarmsDatabase -- Restore peer database before forking the listener thread. peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat") either (hPutStrLn stderr . ("bt-peers.dat: "++)) (atomically . writeTVar (Mainline.contactInfo swarms)) (peerdb >>= S.decodeLazy) (quitBt,btdhts,btips) <- case portbt opts of "" -> return (return (), Map.empty,return []) p -> do addr <- getBindAddress p (ip6bt opts) (bt,btR) <- Mainline.newClient swarms addr quitBt <- forkListener "bt" (clientNet bt) mainlineSearches <- atomically $ newTVar Map.empty let mainlineDHT bkts wantip = DHT { dhtBuckets = bkts btR , dhtPing = Mainline.ping bt , dhtQuery = Map.fromList [ ("node", DHTQuery (Mainline.nodeSearch bt) (\ni -> fmap Mainline.unwrapNodes . Mainline.findNodeH btR ni . flip Mainline.FindNode (Just Want_Both)) show (const Nothing)) , ("peer", DHTQuery (Mainline.peerSearch bt) (\ni -> fmap Mainline.unwrapPeers . Mainline.getPeersH btR swarms ni . flip Mainline.GetPeers (Just Want_Both) . (read . show)) -- TODO: InfoHash -> NodeId (show . pPrint) (Just . show)) ] , dhtParseId = readEither :: String -> Either String Mainline.NodeId , dhtSearches = mainlineSearches , dhtFallbackNodes = Mainline.bootstrapNodes wantip } dhts = Map.fromList $ ("bt4", mainlineDHT Mainline.routing4 Want_IP4) : if ip6bt opts then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ] else [] ips :: IO [SockAddr] ips = readExternals Mainline.nodeAddr [ Mainline.routing4 btR , Mainline.routing6 btR ] return (quitBt,dhts,ips) keysdb <- Tox.newKeysDatabase (quitTox,toxdhts,toxips) <- case porttox opts of "" -> return (return (), Map.empty, return []) toxport -> do addrTox <- getBindAddress toxport (ip6tox opts) tox <- Tox.newTox keysdb addrTox quitTox <- Tox.forkTox tox toxSearches <- atomically $ newTVar Map.empty let toxDHT bkts = DHT { dhtBuckets = bkts (Tox.toxRouting tox) , dhtPing = Tox.ping (Tox.toxDHT tox) , dhtQuery = Map.fromList [ ("node", DHTQuery (Tox.nodeSearch $ Tox.toxDHT tox) (\ni -> fmap Tox.unwrapNodes . Tox.getNodesH (Tox.toxRouting tox) ni . Tox.GetNodes) show (const Nothing)) ] , dhtParseId = readEither :: String -> Either String Tox.NodeId , dhtSearches = toxSearches , dhtFallbackNodes = return [] } dhts = Map.fromList $ ("tox4", toxDHT Tox.routing4) : if ip6tox opts then [ ("tox6", toxDHT Tox.routing6) ] else [] ips :: IO [SockAddr] ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox , Tox.routing6 $ Tox.toxRouting tox ] return (quitTox, dhts, ips) let dhts = Map.union btdhts toxdhts waitForSignal <- do signalQuit <- newEmptyMVar let session = clientSession $ Session { netname = concat $ take 1 $ Map.keys dhts -- initial default DHT , dhts = dhts -- all DHTs , signalQuit = signalQuit , swarms = swarms , toxkeys = keysdb , externalAddresses = liftM2 (++) btips toxips } srv <- streamServer (withSession session) (SockAddrUnix "dht.sock") return $ do () <- takeMVar signalQuit quitListening srv forM_ (Map.toList dhts) $ \(netname, dht@DHT { dhtBuckets = bkts , dhtQuery = qrys , dhtPing = ping , dhtFallbackNodes = getBootstrapNodes }) -> do btSaved <- loadNodes netname -- :: IO [Mainline.NodeInfo] putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"." fallbackNodes <- getBootstrapNodes let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni isNodesSearch Refl sch = sch fork $ do myThreadId >>= flip labelThread ("bootstrap."++netname) case Map.lookup "node" qrys of Just DHTQuery { qsearch = srch } -> do case eqT of Just witness -> bootstrap (isNodesSearch witness srch) bkts ping btSaved fallbackNodes _ -> error $ "Missing node-search for "++netname++"." saveNodes netname dht Nothing -> return () return () {- let bkts4 = Mainline.routing4 btR (fallbackNodes4,fallbackNodes6) <- case portbt opts of [] -> return ([],[]) _ -> do btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo] putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4." fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4 fork $ do myThreadId >>= flip labelThread "bootstrap.Mainline4" bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4 saveNodes "bt4" (dhts Map.! "bt4") fallbackNodes6 <- case ip6bt opts of True -> do btSaved6 <- loadNodes "bt6" putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6." let bkts6 = Mainline.routing6 btR fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6 fork $ do myThreadId >>= flip labelThread "bootstrap.Mainline6" bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6 saveNodes "bt6" (dhts Map.! "bt6") return fallbackNodes6 False -> return [] return (fallbackNodes4,fallbackNodes6) (toxSaved4, toxSaved6) <- case porttox opts of [] -> return ([],[]) _ -> do toxSaved4 <- loadNodes "tox4" putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4" fork $ do myThreadId >>= flip labelThread "bootstrap.Tox4" bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing4 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved4 [] saveNodes "tox4" (dhts Map.! "tox4") toxSaved6 <- case ip6tox opts of True -> do toxSaved6 <- loadNodes "tox6" putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6" fork $ do myThreadId >>= flip labelThread "bootstrap.Tox6" bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing6 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved6 [] saveNodes "tox6" (dhts Map.! "tox6") return toxSaved6 False -> return [] return (toxSaved4,toxSaved6) hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4 ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6 -} waitForSignal quitBt quitTox swarmsdb <- atomically $ readTVar (Mainline.contactInfo swarms) L.writeFile "bt-peers.dat" $ S.encodeLazy swarmsdb