2 files changed, 272 insertions, 0 deletions

diff --git a/examples/dht.hs b/examples/dht.hs
new file mode 100644
index 00000000..feeee9ff
--- /dev/null
+++ b/examples/dht.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Data.Char
+import Network.Socket as Socket
+import System.Console.Haskeline
+import System.Environment
+import System.Exit
+import System.IO
+import System.IO.Unsafe
+import qualified Data.ByteString as B
+
+-- | Reads one character.  If it is not a digit,
+-- then it is discarded and 'Nothing' is returned.
+hReadDigit :: Handle -> IO (Maybe Char)
+hReadDigit h = do c <- hGetChar h
+                  return $ guard (isDigit c) >> pure c
+
+-- | Expected input: "nnn:..."
+-- Here we read the digit sequence "nnn" and drop the colon
+-- as it is the first non-digit.
+hReadInt :: Handle -> IO Int
+hReadInt h = do
+        nstr <- fix $ \readDigits ->
+                        maybe (return []) -- dropped non-digit character
+                              (($ unsafeInterleaveIO readDigits) . fmap . (:))
+                             =<< hReadDigit h
+        readIO nstr :: IO Int
+
+
+-- | Read a length prefixed string from a handle.
+-- The format is "nnn:..." where /nnn/ is an ascii-encoded character count
+-- and /.../ is the sequence of characters
+--
+-- Note: The first byte after the count is ignored and discarded.
+readResponse :: Handle -> IO String
+readResponse h = do
+    n <- hReadInt h
+    sequence $ replicate n (hGetChar h)
+
+-- | Send a command to the dhtd daemon and then print the response.
+sendCommand :: Handle -> String -> InputT IO ()
+sendCommand h cmd = do resp <- liftIO $ do hPutStrLn h cmd
+                                           readResponse h
+                       outputStrLn resp
+
+-- | Get one line of input and send it to the daemon, then run the
+-- passed continuation if it wasn't "quit".
+interactiveMode :: Handle -> InputT IO () -> InputT IO ()
+interactiveMode h repl = do
+    minput <- getInputLine "dht> "
+    case minput of
+       Nothing     -> return ()
+       Just "quit" -> sendCommand h "quit" >> return ()
+       Just cmd    -> sendCommand h cmd >> repl
+
+main :: IO ()
+main = do
+    -- Open the control socket to the daemon.
+    h <- liftIO $ handle (\e -> do hPutStrLn stderr (show (e ::IOError))
+                                   exitFailure)
+                  $ do sock <- socket AF_UNIX Stream defaultProtocol
+                       connect sock (SockAddrUnix "dht.sock")
+                       socketToHandle sock ReadWriteMode
+
+    -- Haskeline's default looks only at our stdin and not our stdout.
+    -- That's a bad idea because we can take input from the command line.
+    behavior <- do
+        useTerminal <- and <$> mapM hIsTerminalDevice [stdin,stdout]
+        return $ if useTerminal then preferTerm else useFileHandle stdin
+
+    runInputTBehaviorWithPrefs behavior defaultPrefs defaultSettings $ do
+
+    -- A command may be specified on the command line
+    -- or else we enter an interactive shell.
+    args <- dropWhile isSpace . unwords <$> liftIO getArgs
+    case args of
+        (_:_) -> sendCommand h args >> sendCommand h "quit"
+        _     -> fix $ interactiveMode h
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
+