diff options
author | joe <joe@jerkface.net> | 2017-01-22 05:31:14 -0500 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-01-22 05:31:14 -0500 |
commit | 8cf4de73d77197032fd8ebfc4e4f3a00b287e0e7 (patch) | |
tree | 6ee5d529caf714851223d2da9f22eb1510d5cfee /examples/dhtd.hs | |
parent | 1c8cbe8fc66466936b4f889b3893ca3c23478631 (diff) |
New: DHT deamon and command-line interface.
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r-- | examples/dhtd.hs | 192 |
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 @@ | |||
1 | {-# LANGUAGE NondecreasingIndentation #-} | ||
2 | {-# LANGUAGE FlexibleContexts #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | ||
4 | {-# LANGUAGE OverloadedStrings #-} | ||
5 | {-# LANGUAGE ScopedTypeVariables #-} | ||
6 | {-# LANGUAGE TupleSections #-} | ||
7 | |||
8 | import Control.Arrow; | ||
9 | import Control.Concurrent | ||
10 | import Control.Exception.Lifted as Lifted | ||
11 | import Control.Monad | ||
12 | import Control.Monad.Logger | ||
13 | import Control.Monad.Reader | ||
14 | import Data.Char | ||
15 | import Data.Default | ||
16 | import Data.List as L | ||
17 | import Data.Maybe | ||
18 | import qualified Data.ByteString as B (ByteString,writeFile,readFile) | ||
19 | ; import Data.ByteString (ByteString) | ||
20 | import System.IO | ||
21 | import System.IO.Error | ||
22 | import Text.PrettyPrint.HughesPJClass | ||
23 | import Text.Printf | ||
24 | import Control.Monad.Reader.Class | ||
25 | |||
26 | import Network.BitTorrent.Address | ||
27 | import Network.BitTorrent.DHT | ||
28 | import qualified Network.BitTorrent.DHT.Routing as R | ||
29 | import Network.BitTorrent.DHT.Session | ||
30 | import Network.SocketLike | ||
31 | import Network.StreamServer | ||
32 | |||
33 | mkNodeAddr :: SockAddr -> NodeAddr IPv4 | ||
34 | mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr) | ||
35 | (fromMaybe 0 $ sockAddrPort addr) -- FIXME | ||
36 | |||
37 | btBindAddr :: String -> Bool -> IO (NodeAddr IPv4) | ||
38 | btBindAddr s b = mkNodeAddr <$> getBindAddress s b | ||
39 | |||
40 | printReport :: MonadIO m => [(String,String)] -> m () | ||
41 | printReport kvs = liftIO $ do | ||
42 | putStrLn (showReport kvs) | ||
43 | hFlush stdout | ||
44 | |||
45 | showReport :: [(String,String)] -> String | ||
46 | showReport kvs = do | ||
47 | let colwidth = maximum $ map (length . fst) kvs | ||
48 | (k,v) <- kvs | ||
49 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] | ||
50 | |||
51 | showEnry :: Show a => (NodeInfo a, t) -> [Char] | ||
52 | showEnry (n,_) = intercalate " " | ||
53 | [ show $ pPrint (nodeId n) | ||
54 | , show $ nodeAddr n | ||
55 | ] | ||
56 | |||
57 | printTable :: DHT IPv4 () | ||
58 | printTable = do | ||
59 | t <- showTable | ||
60 | liftIO $ do | ||
61 | putStrLn t | ||
62 | hFlush stdout | ||
63 | |||
64 | showTable :: DHT IPv4 String | ||
65 | showTable = do | ||
66 | nodes <- R.toList <$> getTable | ||
67 | return $ showReport | ||
68 | $ map (show *** showEnry) | ||
69 | $ concat $ zipWith map (map (,) [0::Int ..]) nodes | ||
70 | |||
71 | bootstrapNodes :: IO [NodeAddr IPv4] | ||
72 | bootstrapNodes = mapMaybe fromAddr | ||
73 | <$> mapM resolveHostName defaultBootstrapNodes | ||
74 | |||
75 | -- ExtendedCaps (Map.singleton | ||
76 | |||
77 | noDebugPrints :: LogSource -> LogLevel -> Bool | ||
78 | noDebugPrints _ = \case LevelDebug -> False | ||
79 | _ -> True | ||
80 | |||
81 | noLogging :: LogSource -> LogLevel -> Bool | ||
82 | noLogging _ _ = False | ||
83 | |||
84 | |||
85 | resume :: DHT IPv4 (Maybe B.ByteString) | ||
86 | resume = do | ||
87 | restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat" | ||
88 | saved_nodes <- | ||
89 | either (const $ do liftIO $ putStrLn "Error reading dht-nodes.dat" | ||
90 | return Nothing) | ||
91 | (return . Just) | ||
92 | restore_attempt | ||
93 | return saved_nodes | ||
94 | |||
95 | godht :: forall b. (NodeAddr IPv4 -> NodeId -> DHT IPv4 b) -> IO b | ||
96 | godht f = do | ||
97 | a <- btBindAddr "8008" False | ||
98 | dht def { optTimeout = 5 } a (const $ const True) $ do | ||
99 | me0 <- asks tentativeNodeId | ||
100 | printReport [("tentative node-id",show $ pPrint me0) | ||
101 | ,("listen-address", show a) | ||
102 | ] | ||
103 | f a me0 | ||
104 | |||
105 | marshalForClient :: String -> String | ||
106 | marshalForClient s = show (length s) ++ ":" ++ s | ||
107 | |||
108 | hPutClient :: Handle -> String -> IO () | ||
109 | hPutClient h s = hPutStr h (marshalForClient s) | ||
110 | |||
111 | clientSession :: Node IPv4 -> MVar () -> RestrictedSocket -> Int -> Handle -> IO () | ||
112 | clientSession st signalQuit sock n h = do | ||
113 | line <- map toLower . dropWhile isSpace <$> hGetLine h | ||
114 | let cmd action = action >> clientSession st signalQuit sock n h | ||
115 | case line of | ||
116 | |||
117 | "quit" -> hPutClient h "goodbye." >> hClose h | ||
118 | |||
119 | "stop" -> do hPutClient h "Terminating DHT Daemon." | ||
120 | hClose h | ||
121 | putMVar signalQuit () | ||
122 | |||
123 | "ls" -> cmd $ join $ runDHT st $ do | ||
124 | tbl <- getTable | ||
125 | t <- showTable | ||
126 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") | ||
127 | ip <- routableAddress | ||
128 | return $ do | ||
129 | hPutClient h $ unlines | ||
130 | [ t | ||
131 | , showReport | ||
132 | [ ("node-id", show $ pPrint me) | ||
133 | , ("internet address", show ip) | ||
134 | , ("buckets", show $ R.shape tbl)] | ||
135 | ] | ||
136 | |||
137 | _ -> cmd $ hPutClient h "error." | ||
138 | |||
139 | main :: IO () | ||
140 | main = do | ||
141 | godht $ \a me0 -> do | ||
142 | printTable | ||
143 | bs <- liftIO bootstrapNodes | ||
144 | `onException` | ||
145 | (Lifted.ioError $ userError "unable to resolve bootstrap nodes") | ||
146 | saved_nodes <- resume | ||
147 | |||
148 | when (isJust saved_nodes) $ do | ||
149 | b <- isBootstrapped | ||
150 | tbl <- getTable | ||
151 | bc <- optBucketCount <$> asks options | ||
152 | printTable | ||
153 | me <- case concat $ R.toList tbl of | ||
154 | (n,_):_ -> myNodeIdAccordingTo (nodeAddr n) | ||
155 | _ -> return me0 | ||
156 | printReport [("node-id",show $ pPrint me) | ||
157 | ,("listen-address", show a) | ||
158 | ,("bootstrapped", show b) | ||
159 | ,("buckets", show $ R.shape tbl) | ||
160 | ,("optBucketCount", show bc) | ||
161 | ,("dht-nodes.dat", "Running bootstrap...") | ||
162 | ] | ||
163 | |||
164 | st <- ask | ||
165 | waitForSignal <- liftIO $ do | ||
166 | signalQuit <- newEmptyMVar | ||
167 | srv <- streamServer (withSession $ clientSession st signalQuit) (SockAddrUnix "dht.sock") | ||
168 | return $ liftIO $ do | ||
169 | () <- takeMVar signalQuit | ||
170 | quitListening srv | ||
171 | |||
172 | bootstrap saved_nodes bs | ||
173 | |||
174 | b <- isBootstrapped | ||
175 | tbl <- getTable | ||
176 | bc <- optBucketCount <$> asks options | ||
177 | printTable | ||
178 | ip <- routableAddress | ||
179 | me <- case concat $ R.toList tbl of | ||
180 | (n,_):_ -> myNodeIdAccordingTo (nodeAddr n) | ||
181 | _ -> return me0 | ||
182 | printReport [("node-id",show $ pPrint me) | ||
183 | ,("internet address", show ip) | ||
184 | ,("listen-address", show a) | ||
185 | ,("bootstrapped", show b) | ||
186 | ,("buckets", show $ R.shape tbl) | ||
187 | ,("optBucketCount", show bc) | ||
188 | ] | ||
189 | snapshot >>= liftIO . B.writeFile "dht-nodes.dat" | ||
190 | |||
191 | waitForSignal | ||
192 | |||