{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} import Control.Arrow import Control.Concurrent.STM import Control.DeepSeq import Control.Exception import Control.Monad import Data.Char import Data.List import qualified Data.Map as Map import Data.Time.Clock import GHC.Stats import Network.Socket import System.Environment import System.IO import System.Mem import System.Posix.Process 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.QueryResponse import Network.StreamServer import Kademlia import qualified Mainline import Network.DHT.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.Async.Pool import System.IO.Error showReport :: [(String,String)] -> String showReport kvs = do let colwidth = maximum $ map (length . fst) kvs (k,v) <- kvs concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] marshalForClient :: String -> String marshalForClient s = show (length s) ++ ":" ++ s hPutClient :: Handle -> String -> IO () hPutClient h s = hPutStr h ('.' : marshalForClient s) data DHT = forall ni. ( Show ni , Read ni , ToJSON ni , FromJSON ni ) => DHT { dhtBuckets :: TVar (BucketList ni) , dhtPing :: ni -> IO Bool -- dhtClient :: Client err meth tid addr x } nodesFileName :: String -> String nodesFileName netname = netname ++ "-nodes.json" saveNodes :: String -> DHT -> IO () saveNodes netname (DHT var _) = do bkts <- atomically $ readTVar var 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 _ ping) = 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 10 $ \g -> do mapTasks_ g (map ping ns) 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 clientSession netname dhts signalQuit sock n 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 netname dhts signalQuit sock n h switchNetwork dest = do hPutClient h ("Network: "++dest) clientSession dest dhts signalQuit sock n 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) #ifdef THREAD_DEBUG ("threads", _) -> cmd0 $ do ts <- threadsInformation tm <- getCurrentTime let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts hPutClient h $ showReport r ("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." #endif ("ls", _) | Just (DHT var _) <- Map.lookup netname dhts -> cmd0 $ do bkts <- atomically $ readTVar var let r = reportTable bkts hPutClient h $ showReport $ r ++ [ ("buckets", show $ R.shape bkts) , ("node-id", show $ thisNode bkts) , ("network", netname) ] ("ping", s) | Just (DHT _ ping) <- Map.lookup netname dhts -> cmd0 $ do case readEither s of Right addr -> do result <- ping addr let rs = [" ", show result] hPutClient h $ unlines rs Left er -> hPutClient h er ("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 ++ "." (n, _) | n `elem` Map.keys dhts -> switchNetwork n _ -> cmd0 $ hPutClient h "error." defaultPort = "6881" main = do args <- getArgs p <- case take 2 (dropWhile (/="-p") args) of ["-p",port] | not ("-" `isPrefixOf` port) -> return port ("-p":_) -> error "Port not specified! (-p PORT)" _ -> return defaultPort addr <- getBindAddress p True{- ipv6 -} (bt,btR) <- Mainline.newClient addr quitBt <- forkListener bt tox <- return $ error "TODO: Tox.newClient" quitTox <- return $ return () -- TODO: forkListener tox let dhts = Map.fromList [ ("bt4", DHT (Mainline.routing4 btR) (Mainline.ping bt)) , ("bt6", DHT (Mainline.routing6 btR) (Mainline.ping bt)) ] waitForSignal <- do signalQuit <- newEmptyMVar srv <- streamServer (withSession $ clientSession "bt4" dhts signalQuit) (SockAddrUnix "dht.sock") return $ do () <- takeMVar signalQuit quitListening srv let bkts4 = Mainline.routing4 btR btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo] putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4." fallbackNodes4 <- Mainline.bootstrapNodes Mainline.Want_IP4 fork $ do myThreadId >>= flip labelThread "bootstrap.Mainline4" bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4 saveNodes "bt4" (dhts Map.! "bt4") btSaved6 <- loadNodes "bt6" putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6." let bkts6 = Mainline.routing6 btR fallbackNodes6 <- Mainline.bootstrapNodes Mainline.Want_IP6 fork $ do myThreadId >>= flip labelThread "bootstrap.Mainline6" bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6 saveNodes "bt6" (dhts Map.! "bt6") hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4 ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6 waitForSignal quitBt quitTox