1 files changed, 192 insertions, 0 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
new file mode 100644
index 00000000..6bf48595
--- /dev/null
+++ b/examples/dhtd.hs
@@ -0,0 +1,192 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+
+import Control.Arrow;
+import Control.Concurrent
+import Control.Exception.Lifted as Lifted
+import Control.Monad
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Data.Char
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import qualified Data.ByteString as B (ByteString,writeFile,readFile)
+        ; import Data.ByteString (ByteString)
+import System.IO
+import System.IO.Error
+import Text.PrettyPrint.HughesPJClass
+import Text.Printf
+import Control.Monad.Reader.Class
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT
+import qualified Network.BitTorrent.DHT.Routing as R
+import Network.BitTorrent.DHT.Session
+import Network.SocketLike
+import Network.StreamServer
+
+mkNodeAddr :: SockAddr -> NodeAddr IPv4
+mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr)
+                           (fromMaybe 0 $ sockAddrPort addr) -- FIXME
+
+btBindAddr :: String -> Bool -> IO (NodeAddr IPv4)
+btBindAddr s b = mkNodeAddr <$> getBindAddress s b
+
+printReport :: MonadIO m => [(String,String)] -> m ()
+printReport kvs = liftIO $ do
+    putStrLn (showReport kvs)
+    hFlush stdout
+
+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" ]
+
+showEnry :: Show a => (NodeInfo a, t) -> [Char]
+showEnry (n,_) = intercalate " "
+    [ show $ pPrint (nodeId n)
+    , show $ nodeAddr n
+    ]
+
+printTable :: DHT IPv4 ()
+printTable = do
+    t <- showTable
+    liftIO $ do
+        putStrLn t
+        hFlush stdout
+
+showTable :: DHT IPv4 String
+showTable = do
+    nodes <- R.toList <$> getTable
+    return $ showReport
+           $ map (show *** showEnry)
+           $ concat $ zipWith map (map (,) [0::Int ..]) nodes
+
+bootstrapNodes :: IO [NodeAddr IPv4]
+bootstrapNodes = mapMaybe fromAddr
+                <$> mapM resolveHostName defaultBootstrapNodes
+
+-- ExtendedCaps (Map.singleton
+
+noDebugPrints :: LogSource -> LogLevel -> Bool
+noDebugPrints _ = \case LevelDebug -> False
+                        _          -> True
+
+noLogging :: LogSource -> LogLevel -> Bool
+noLogging _ _ = False
+
+
+resume :: DHT IPv4 (Maybe B.ByteString)
+resume = do
+    restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat"
+    saved_nodes <-
+        either (const $ do liftIO $ putStrLn "Error reading dht-nodes.dat"
+                           return Nothing)
+               (return . Just)
+            restore_attempt
+    return saved_nodes
+
+godht :: forall b. (NodeAddr IPv4 -> NodeId -> DHT IPv4 b) -> IO b
+godht f = do
+    a <- btBindAddr "8008" False
+    dht def { optTimeout = 5 } a (const $ const True) $ do
+        me0 <- asks tentativeNodeId
+        printReport [("tentative node-id",show $ pPrint me0)
+                   ,("listen-address", show a)
+                   ]
+        f a me0
+
+marshalForClient :: String -> String
+marshalForClient s = show (length s) ++ ":" ++ s
+
+hPutClient :: Handle -> String -> IO ()
+hPutClient h s = hPutStr h (marshalForClient s)
+
+clientSession :: Node IPv4 -> MVar () -> RestrictedSocket -> Int -> Handle -> IO ()
+clientSession st signalQuit sock n h = do
+    line <- map toLower . dropWhile isSpace <$> hGetLine h
+    let cmd action = action >> clientSession st signalQuit sock n h
+    case line of
+
+        "quit" -> hPutClient h "goodbye." >> hClose h
+
+        "stop" -> do hPutClient h "Terminating DHT Daemon."
+                     hClose h
+                     putMVar signalQuit ()
+
+        "ls" -> cmd $ join $ runDHT st $ do
+                    tbl <- getTable
+                    t <- showTable
+                    me <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+                    ip <- routableAddress
+                    return $ do
+                    hPutClient h $ unlines
+                        [ t
+                        , showReport
+                            [ ("node-id", show $ pPrint me)
+                            , ("internet address", show ip)
+                            , ("buckets", show $ R.shape tbl)]
+                        ]
+
+        _    -> cmd $ hPutClient h "error."
+
+main :: IO ()
+main = do
+    godht $ \a me0 -> do
+    printTable
+    bs <- liftIO bootstrapNodes
+            `onException`
+                 (Lifted.ioError $ userError "unable to resolve bootstrap nodes")
+    saved_nodes <- resume
+
+    when (isJust saved_nodes) $ do
+        b <- isBootstrapped
+        tbl <- getTable
+        bc <- optBucketCount <$> asks options
+        printTable
+        me <- case concat $ R.toList tbl of
+                (n,_):_ -> myNodeIdAccordingTo (nodeAddr n)
+                _       -> return me0
+        printReport [("node-id",show $ pPrint me)
+                   ,("listen-address", show a)
+                   ,("bootstrapped", show b)
+                   ,("buckets", show $ R.shape tbl)
+                   ,("optBucketCount", show bc)
+                   ,("dht-nodes.dat", "Running bootstrap...")
+                   ]
+
+    st <- ask
+    waitForSignal <- liftIO $ do
+        signalQuit <- newEmptyMVar
+        srv <- streamServer (withSession $ clientSession st signalQuit) (SockAddrUnix "dht.sock")
+        return $ liftIO $ do
+            () <- takeMVar signalQuit
+            quitListening srv
+
+    bootstrap saved_nodes bs
+
+    b <- isBootstrapped
+    tbl <- getTable
+    bc <- optBucketCount <$> asks options
+    printTable
+    ip <- routableAddress
+    me <- case concat $ R.toList tbl of
+            (n,_):_ -> myNodeIdAccordingTo (nodeAddr n)
+            _       -> return me0
+    printReport [("node-id",show $ pPrint me)
+               ,("internet address", show ip)
+               ,("listen-address", show a)
+               ,("bootstrapped", show b)
+               ,("buckets", show $ R.shape tbl)
+               ,("optBucketCount", show bc)
+               ]
+    snapshot >>= liftIO . B.writeFile "dht-nodes.dat"
+
+    waitForSignal
+