path: root/examples/dhtd.hs

{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# 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

-- | 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 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

data Session = Session
    { netname           :: String
    , dhts              :: Map.Map String DHT
    , externalAddresses :: IO [SockAddr]
    , signalQuit        :: MVar ()
    }

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 show <$> externalAddresses
                        >>= hPutClient h
#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."


readExternals :: [TVar (BucketList Mainline.NodeInfo)] -> IO [SockAddr]
readExternals vars = do
    as <- atomically $ mapM (fmap (Mainline.nodeAddr . selfNode) . readTVar) vars
    -- TODO: Filter to only global addresses?
    return as

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
        let session = clientSession $ Session
                { netname           = "bt4" -- initial default DHT
                , dhts              = dhts  -- all DHTs
                , signalQuit        = signalQuit
                , externalAddresses = readExternals
                                        [ Mainline.routing4 btR
                                        , Mainline.routing6 btR
                                        ]
                }
        srv <- streamServer (withSession session) (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