diff options
author | joe <joe@jerkface.net> | 2017-07-26 05:19:05 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-07-26 05:19:05 -0400 |
commit | dd6ce8958a9589111f2eef98633fbc9b510647e4 (patch) | |
tree | a8061c86865d42bb507b81a24319452b07c2cc95 /examples/dhtd.hs | |
parent | 8a3dca27bfabc9210ad4982fd87310386e81de40 (diff) |
Applied rewrite to dhtd main program.
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r-- | examples/dhtd.hs | 615 |
1 files changed, 174 insertions, 441 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index ab256831..5c1bbb26 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -1,88 +1,53 @@ | |||
1 | {-# LANGUAGE NondecreasingIndentation #-} | 1 | {-# LANGUAGE CPP #-} |
2 | {-# LANGUAGE FlexibleContexts #-} | 2 | {-# LANGUAGE ExistentialQuantification #-} |
3 | {-# LANGUAGE FlexibleInstances #-} | 3 | {-# LANGUAGE FlexibleContexts #-} |
4 | {-# LANGUAGE MultiParamTypeClasses #-} | 4 | {-# LANGUAGE FlexibleInstances #-} |
5 | {-# LANGUAGE LambdaCase #-} | 5 | {-# LANGUAGE LambdaCase #-} |
6 | {-# LANGUAGE OverloadedStrings #-} | 6 | {-# LANGUAGE MultiParamTypeClasses #-} |
7 | {-# LANGUAGE ScopedTypeVariables #-} | 7 | {-# LANGUAGE NondecreasingIndentation #-} |
8 | {-# LANGUAGE TupleSections #-} | 8 | {-# LANGUAGE OverloadedStrings #-} |
9 | {-# LANGUAGE RecordWildCards #-} | 9 | {-# LANGUAGE PartialTypeSignatures #-} |
10 | {-# LANGUAGE PartialTypeSignatures #-} | 10 | {-# LANGUAGE RankNTypes #-} |
11 | {-# LANGUAGE CPP #-} | 11 | {-# LANGUAGE RecordWildCards #-} |
12 | {-# LANGUAGE RankNTypes #-} | 12 | {-# LANGUAGE ScopedTypeVariables #-} |
13 | {-# LANGUAGE TypeFamilies #-} | 13 | {-# LANGUAGE TupleSections #-} |
14 | {-# LANGUAGE TypeFamilies #-} | ||
14 | 15 | ||
15 | import Control.Arrow | 16 | import Control.Arrow |
17 | import Control.Concurrent.STM | ||
18 | import Control.DeepSeq | ||
19 | import Control.Exception | ||
16 | import Control.Monad | 20 | import Control.Monad |
17 | import Control.Monad.Logger | ||
18 | import Control.Monad.Reader | ||
19 | import Data.Char | 21 | import Data.Char |
20 | import Data.Default | 22 | import Data.List |
21 | import Data.List as L | 23 | import qualified Data.Map as Map |
22 | import Data.Maybe | 24 | import Data.Time.Clock |
23 | import Data.String | ||
24 | import qualified Data.Set as Set | ||
25 | import qualified Data.ByteString as B (ByteString,writeFile,readFile) | ||
26 | ; import Data.ByteString (ByteString) | ||
27 | import qualified Data.ByteString.Char8 as B8 | ||
28 | import System.IO | ||
29 | import System.IO.Error | ||
30 | import Text.PrettyPrint.HughesPJClass | ||
31 | import Text.Printf | ||
32 | import Text.Read hiding (get) | ||
33 | import Control.Monad.Reader.Class | ||
34 | import System.Posix.Process (getProcessID) | ||
35 | import GHC.Stats | 25 | import GHC.Stats |
26 | import Network.Socket | ||
27 | import System.Environment | ||
28 | import System.IO | ||
36 | import System.Mem | 29 | import System.Mem |
37 | import Data.Word | 30 | import System.Posix.Process |
38 | 31 | import Text.Printf | |
39 | import Data.Torrent (InfoHash) | 32 | import Text.Read |
40 | import Network.Address | ||
41 | import Network.BitTorrent.DHT | ||
42 | import Network.BitTorrent.DHT.Search | ||
43 | import Network.BitTorrent.DHT.Query | ||
44 | import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..)) | ||
45 | import Network.DatagramServer (QueryFailure(..)) | ||
46 | import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf) | ||
47 | import qualified Network.DatagramServer.Tox as Tox | ||
48 | import qualified Network.DHT.Routing as R | ||
49 | import Network.BitTorrent.DHT.Session | ||
50 | import Network.SocketLike | ||
51 | import Network.StreamServer | ||
52 | import Control.Exception.Lifted as Lifted | ||
53 | #ifdef THREAD_DEBUG | 33 | #ifdef THREAD_DEBUG |
54 | import Control.Concurrent.Lifted.Instrument | 34 | import Control.Concurrent.Lifted.Instrument |
55 | import Data.Time () | ||
56 | import Data.Time.Clock | ||
57 | #else | 35 | #else |
58 | import Control.Concurrent | 36 | import Control.Concurrent.Lifted |
37 | import GHC.Conc (labelThread) | ||
59 | #endif | 38 | #endif |
60 | import Control.Concurrent.STM | 39 | |
61 | import System.Environment | 40 | import Network.Address hiding (NodeId, NodeInfo(..)) |
62 | import Data.BEncode (BValue) | 41 | import Network.QueryResponse |
63 | import Network.DHT.Types | 42 | import Network.StreamServer |
64 | import Network.DHT.Tox | 43 | import Kademlia |
65 | import Network.DatagramServer.Types | 44 | import qualified Mainline |
66 | import Data.Bits | 45 | import Network.DHT.Routing as R |
67 | import Data.Serialize | 46 | import Data.Aeson as J (ToJSON, FromJSON) |
68 | import Network.KRPC.Method | 47 | import qualified Data.Aeson as J |
69 | import Data.Typeable | 48 | import qualified Data.ByteString.Lazy as L |
70 | import GHC.Generics | 49 | import Control.Concurrent.Async.Pool |
71 | import Data.Bool | 50 | import System.IO.Error |
72 | import System.Random | ||
73 | import Network.DatagramServer.Mainline (PacketDestination(..)) | ||
74 | |||
75 | mkNodeAddr :: SockAddr -> NodeAddr IPv4 | ||
76 | mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr) | ||
77 | (fromMaybe 0 $ sockAddrPort addr) -- FIXME | ||
78 | |||
79 | btBindAddr :: String -> Bool -> IO (NodeAddr IPv4) | ||
80 | btBindAddr s b = mkNodeAddr <$> getBindAddress s b | ||
81 | |||
82 | printReport :: MonadIO m => [(String,String)] -> m () | ||
83 | printReport kvs = liftIO $ do | ||
84 | putStrLn (showReport kvs) | ||
85 | hFlush stdout | ||
86 | 51 | ||
87 | showReport :: [(String,String)] -> String | 52 | showReport :: [(String,String)] -> String |
88 | showReport kvs = do | 53 | showReport kvs = do |
@@ -90,93 +55,6 @@ showReport kvs = do | |||
90 | (k,v) <- kvs | 55 | (k,v) <- kvs |
91 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] | 56 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] |
92 | 57 | ||
93 | showEnry :: | ||
94 | ( Show a | ||
95 | , Pretty (NodeId dht) | ||
96 | ) => (NodeInfo dht a u, t) -> [Char] | ||
97 | showEnry (n,_) = intercalate " " | ||
98 | [ show $ pPrint (nodeId n) | ||
99 | , show $ nodeAddr n | ||
100 | ] | ||
101 | |||
102 | printTable :: | ||
103 | ( Pretty (NodeId dht) | ||
104 | ) => DHT raw dht u IPv4 () | ||
105 | printTable = do | ||
106 | t <- showTable | ||
107 | liftIO $ do | ||
108 | putStrLn t | ||
109 | hFlush stdout | ||
110 | |||
111 | showTable :: | ||
112 | ( Pretty (NodeId dht) | ||
113 | ) => DHT raw dht u IPv4 String | ||
114 | showTable = do | ||
115 | nodes <- R.toList <$> getTable | ||
116 | return $ showReport | ||
117 | $ map (show *** showEnry) | ||
118 | $ concat $ zipWith map (map (,) [0::Int ..]) nodes | ||
119 | |||
120 | bootstrapNodes :: IO [NodeAddr IPv4] | ||
121 | bootstrapNodes = mapMaybe fromAddr | ||
122 | <$> mapM resolveHostName defaultBootstrapNodes | ||
123 | |||
124 | -- ExtendedCaps (Map.singleton | ||
125 | |||
126 | noDebugPrints :: LogSource -> LogLevel -> Bool | ||
127 | noDebugPrints _ = \case LevelDebug -> False | ||
128 | LevelOther _ -> False | ||
129 | _ -> True | ||
130 | |||
131 | noLogging :: LogSource -> LogLevel -> Bool | ||
132 | noLogging _ _ = False | ||
133 | |||
134 | allNoise :: LogSource -> LogLevel -> Bool | ||
135 | allNoise _ _ = True | ||
136 | |||
137 | resume :: DHT raw dht u IPv4 (Maybe B.ByteString) | ||
138 | resume = do | ||
139 | restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat" | ||
140 | saved_nodes <- | ||
141 | either (const $ do liftIO $ putStrLn "Error reading dht-nodes.dat" | ||
142 | return Nothing) | ||
143 | (return . Just) | ||
144 | restore_attempt | ||
145 | return saved_nodes | ||
146 | |||
147 | godht :: | ||
148 | ( Eq (QueryMethod dht) | ||
149 | , Show (QueryMethod dht) | ||
150 | , Functor dht | ||
151 | , Ord (TransactionID dht) | ||
152 | , Serialize (TransactionID dht) | ||
153 | , Kademlia dht | ||
154 | , WireFormat raw dht | ||
155 | , DataHandlers raw dht | ||
156 | , SerializableTo raw (Query dht (FindNode dht IPv4)) | ||
157 | , SerializableTo raw (Response dht (NodeFound dht IPv4)) | ||
158 | , SerializableTo raw (Query dht (Ping dht)) | ||
159 | , SerializableTo raw (Response dht (Ping dht)) | ||
160 | , KRPC dht (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4)) | ||
161 | , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
162 | , Ord (NodeId dht) | ||
163 | , FiniteBits (NodeId dht) | ||
164 | , Serialize (NodeId dht) | ||
165 | , Show (NodeId dht) | ||
166 | , Pretty (NodeId dht) | ||
167 | , Pretty (NodeInfo dht IPv4 u) | ||
168 | , Default u | ||
169 | , Show u | ||
170 | , Typeable dht | ||
171 | ) => String -> (NodeAddr IPv4 -> NodeId dht -> DHT raw dht u IPv4 b) -> IO b | ||
172 | godht p f = do | ||
173 | a <- btBindAddr p False | ||
174 | dht def { optTimeout = 5 } a allNoise $ do | ||
175 | me0 <- asks tentativeNodeId | ||
176 | printReport [("tentative node-id",show $ pPrint me0) | ||
177 | ,("listen-address", show a) | ||
178 | ] | ||
179 | f a me0 | ||
180 | 58 | ||
181 | marshalForClient :: String -> String | 59 | marshalForClient :: String -> String |
182 | marshalForClient s = show (length s) ++ ":" ++ s | 60 | marshalForClient s = show (length s) ++ ":" ++ s |
@@ -184,120 +62,78 @@ marshalForClient s = show (length s) ++ ":" ++ s | |||
184 | hPutClient :: Handle -> String -> IO () | 62 | hPutClient :: Handle -> String -> IO () |
185 | hPutClient h s = hPutStr h ('.' : marshalForClient s) | 63 | hPutClient h s = hPutStr h ('.' : marshalForClient s) |
186 | 64 | ||
187 | hPutClientChunk :: Handle -> String -> IO () | 65 | data DHT = forall ni. ( Show ni |
188 | hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) | 66 | , Read ni |
189 | 67 | , ToJSON ni | |
190 | data GenericDHT ip a | 68 | , FromJSON ni |
191 | = GenericDHT | 69 | ) => |
192 | (forall raw dht u. | 70 | DHT |
193 | ( Eq (QueryMethod dht) | 71 | { dhtBuckets :: TVar (BucketList ni) |
194 | , Show (QueryMethod dht) | 72 | , dhtPing :: ni -> IO Bool |
195 | , Functor dht | 73 | -- dhtClient :: Client err meth tid addr x |
196 | , Ord (TransactionID dht) | 74 | } |
197 | , Serialize (TransactionID dht) | 75 | |
198 | , Kademlia dht | 76 | nodesFileName :: String -> String |
199 | , WireFormat raw dht | 77 | nodesFileName netname = netname ++ "-nodes.json" |
200 | , DataHandlers raw dht | 78 | |
201 | , SerializableTo raw (Query dht (FindNode dht ip)) | 79 | saveNodes :: String -> DHT -> IO () |
202 | , SerializableTo raw (Response dht (NodeFound dht ip)) | 80 | saveNodes netname (DHT var _) = do |
203 | , SerializableTo raw (Query dht (Ping dht)) | 81 | bkts <- atomically $ readTVar var |
204 | , SerializableTo raw (Response dht (Ping dht)) | 82 | let ns = map fst $ concat $ R.toList bkts |
205 | , KRPC dht (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) | 83 | bs = J.encode ns |
206 | , KRPC dht (Query dht (Ping dht)) (Response dht (Ping dht)) | 84 | fname = nodesFileName netname |
207 | , Ord (NodeId dht) | 85 | L.writeFile fname bs |
208 | , FiniteBits (NodeId dht) | 86 | |
209 | , Serialize (NodeId dht) | 87 | loadNodes :: FromJSON ni => String -> IO [ni] |
210 | , Show (NodeId dht) | 88 | loadNodes netname = do |
211 | , Pretty (NodeId dht) | 89 | let fname = nodesFileName netname |
212 | , Pretty (NodeInfo dht ip ()) | 90 | attempt <- tryIOError $ do |
213 | , Pretty (NodeInfo dht ip u) | 91 | J.decode <$> L.readFile fname |
214 | , Default u | 92 | >>= maybe (ioError $ userError "Nothing") return |
215 | , Show u | 93 | either (const $ return []) return attempt |
216 | , Read (NodeId dht) | 94 | |
217 | ) => DHT raw dht u ip a) | 95 | pingNodes :: String -> DHT -> IO Bool |
218 | | BtDHT (DHT BValue KMessageOf () ip a) | 96 | pingNodes netname (DHT _ ping) = do |
219 | 97 | let fname = nodesFileName netname | |
220 | dhtType :: DHT raw dht u ip (Proxy dht) | 98 | attempt <- tryIOError $ do |
221 | dhtType = return Proxy | 99 | J.decode <$> L.readFile fname |
222 | 100 | >>= maybe (ioError $ userError "Nothing") return | |
223 | nodeIdType :: NodeId dht -> DHT raw dht u ip () | 101 | case attempt of |
224 | nodeIdType _ = return () | 102 | Left _ -> return False |
225 | 103 | Right ns -> do fork $ do | |
226 | nodeAddrType :: NodeAddr ip -> DHT raw dht u ip () | 104 | myThreadId >>= flip labelThread ("pinging."++fname) |
227 | nodeAddrType _ = return () | 105 | putStrLn $ "Forked "++show fname |
228 | 106 | withTaskGroup 10 $ \g -> do | |
229 | ipType :: f dht ip -> DHT raw dht u ip () | 107 | mapTasks_ g (map ping ns) |
230 | ipType _ = return () | 108 | putStrLn $ "Load finished "++show fname |
231 | 109 | return True | |
232 | clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool -> RestrictedSocket -> Int -> Handle -> IO () | 110 | |
233 | clientSession bt tox signalQuit isBt sock n h = do | 111 | |
112 | |||
113 | reportTable :: Show ni => BucketList ni -> [(String,String)] | ||
114 | reportTable bkts = map (show *** show . fst) | ||
115 | $ concat | ||
116 | $ zipWith map (map (,) [0::Int ..]) | ||
117 | $ R.toList | ||
118 | $ bkts | ||
119 | |||
120 | clientSession netname dhts signalQuit sock n h = do | ||
234 | line <- map toLower . dropWhile isSpace <$> hGetLine h | 121 | line <- map toLower . dropWhile isSpace <$> hGetLine h |
235 | let dht :: Either (Node BValue KMessageOf () IPv4) | 122 | let (c,args) = second (dropWhile isSpace) $ break isSpace line |
236 | (Node B.ByteString Tox.Message Bool IPv4) | ||
237 | dht | isBt = Left bt | ||
238 | | otherwise = Right tox | ||
239 | cmd0 :: IO () -> IO () | 123 | cmd0 :: IO () -> IO () |
240 | cmd0 action = action >> clientSession bt tox signalQuit isBt sock n h | 124 | cmd0 action = action >> clientSession netname dhts signalQuit sock n h |
241 | cmd :: GenericDHT IPv4 (IO ()) -> IO () | 125 | switchNetwork dest = do hPutClient h ("Network: "++dest) |
242 | cmd (GenericDHT action) = cmd0 $ join $ either (flip runDHT action) (flip runDHT action) dht | 126 | clientSession dest dhts signalQuit sock n h |
243 | cmd (BtDHT action) = cmd0 $ join $ runDHT bt action | ||
244 | (c,args) = second (dropWhile isSpace) $ break isSpace line | ||
245 | switchNetwork dest = hPutClient h ("Network: "++if dest then "mainline" else "tox") >> clientSession bt tox signalQuit dest sock n h | ||
246 | case (c,args) of | 127 | case (c,args) of |
247 | |||
248 | ("bt", _) -> switchNetwork True | ||
249 | |||
250 | ("tox", _) -> switchNetwork False | ||
251 | |||
252 | ("quit", _) -> hPutClient h "" >> hClose h | ||
253 | |||
254 | ("stop", _) -> do hPutClient h "Terminating DHT Daemon." | 128 | ("stop", _) -> do hPutClient h "Terminating DHT Daemon." |
255 | hClose h | 129 | hClose h |
256 | putMVar signalQuit () | 130 | putMVar signalQuit () |
257 | 131 | ||
132 | ("quit", _) -> hPutClient h "" >> hClose h | ||
133 | |||
258 | ("pid", _) -> cmd0 $ do | 134 | ("pid", _) -> cmd0 $ do |
259 | pid <- getProcessID | 135 | pid <- getProcessID |
260 | hPutClient h (show pid) | 136 | hPutClient h (show pid) |
261 | |||
262 | -- DHT specific | ||
263 | ("ls", _) -> cmd $ GenericDHT $ do | ||
264 | tbl <- getTable | ||
265 | t <- showTable | ||
266 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") | ||
267 | ip <- routableAddress | ||
268 | return $ do | ||
269 | hPutClient h $ unlines | ||
270 | [ t | ||
271 | , showReport | ||
272 | [ ("node-id", show $ pPrint me) | ||
273 | , ("internet address", show ip) | ||
274 | , ("buckets", show $ R.shape tbl) | ||
275 | , ("network", if isBt then "mainline" else "tox") ] | ||
276 | ] | ||
277 | ("external-ip", _) -> cmd $ BtDHT $ do | ||
278 | ip <- routableAddress | ||
279 | return $ do | ||
280 | hPutClient h $ maybe "" (takeWhile (/=':') . show) ip | ||
281 | |||
282 | ("swarms", s) -> cmd $ BtDHT $ do | ||
283 | let fltr = case s of | ||
284 | ('-':'v':cs) | all isSpace (take 1 cs) | ||
285 | -> const True | ||
286 | _ -> (\(h,c,n) -> c/=0 ) | ||
287 | ss <- getSwarms | ||
288 | let r = map (\(h,c,n) -> (unwords [show h,show c], maybe "" show n)) | ||
289 | $ filter fltr ss | ||
290 | return $ do | ||
291 | hPutClient h $ showReport r | ||
292 | |||
293 | -- bittorrent only | ||
294 | ("peers", s) -> cmd $ BtDHT $ case readEither s of | ||
295 | Right ih -> do | ||
296 | ps <- allPeers ih | ||
297 | seq ih $ return $ do | ||
298 | hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps | ||
299 | Left er -> return $ hPutClient h er | ||
300 | |||
301 | #ifdef THREAD_DEBUG | 137 | #ifdef THREAD_DEBUG |
302 | ("threads", _) -> cmd0 $ do | 138 | ("threads", _) -> cmd0 $ do |
303 | ts <- threadsInformation | 139 | ts <- threadsInformation |
@@ -337,191 +173,88 @@ clientSession bt tox signalQuit isBt sock n h = do | |||
337 | _ -> hPutClient h "error." | 173 | _ -> hPutClient h "error." |
338 | 174 | ||
339 | #endif | 175 | #endif |
340 | -- DHT specific | 176 | ("ls", _) | Just (DHT var _) <- Map.lookup netname dhts |
341 | ("closest", s) -> cmd $ GenericDHT $ do | 177 | -> cmd0 $ do |
342 | let (ns,hs) = second (dropWhile isSpace) $ break isSpace s | 178 | bkts <- atomically $ readTVar var |
343 | parse | null hs = do | 179 | let r = reportTable bkts |
344 | ih <- readEither ns | 180 | hPutClient h $ |
345 | return (8 :: Int, ih) | 181 | showReport $ |
346 | | otherwise = do | 182 | r ++ [ ("buckets", show $ R.shape bkts) |
347 | n <- readEither ns | 183 | , ("node-id", show $ thisNode bkts) |
348 | ih <- readEither hs | 184 | , ("network", netname) ] |
349 | return (n :: Int, ih) | 185 | |
350 | case parse of | 186 | ("ping", s) | Just (DHT _ ping) <- Map.lookup netname dhts |
351 | Right (n,ih) -> do | 187 | -> cmd0 $ do |
352 | nodeIdType ih | 188 | case readEither s of |
353 | tbl <- getTable | 189 | Right addr -> do result <- ping addr |
354 | let nodes = R.kclosest n ih tbl | 190 | let rs = [" ", show result] |
355 | return $ do | 191 | hPutClient h $ unlines rs |
356 | hPutClient h $ unlines $ map (showEnry . (flip (,) (error "showEnry"))) nodes | 192 | Left er -> hPutClient h er |
357 | Left er -> return $ hPutClient h er | 193 | |
358 | 194 | ("save", _) | Just dht <- Map.lookup netname dhts | |
359 | -- DHT specific | 195 | -> cmd0 $ do |
360 | ("ping", s) -> cmd $ GenericDHT $ do | 196 | saveNodes netname dht |
361 | case readEither s of | 197 | hPutClient h $ "Saved " ++ nodesFileName netname ++ "." |
362 | Right addr -> do result <- try $ pingQ addr | 198 | |
363 | let rs = either (pure . showQueryFail) reportPong result | 199 | ("load", _) | Just dht <- Map.lookup netname dhts |
364 | return $ do | 200 | -> cmd0 $ do |
365 | hPutClient h $ unlines rs | 201 | b <- pingNodes netname dht |
366 | Left er -> return $ hPutClient h er | 202 | if b then hPutClient h $ "Pinging " ++ nodesFileName netname ++ "." |
367 | 203 | else hPutClient h $ "Failed: " ++ nodesFileName netname ++ "." | |
368 | -- DHT specific | 204 | (n, _) | n `elem` Map.keys dhts -> switchNetwork n |
369 | -- | ||
370 | -- Current syntax: | ||
371 | -- find-nodes c55729c4adeb286017f512c7316059e052c98e67 179.197.102.29:59933 | ||
372 | -- | ||
373 | -- | ||
374 | ("find-nodes", s) -> cmd $ GenericDHT $ do | ||
375 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s | ||
376 | parse = do ih <- readEither hs | ||
377 | a <- readEither as | ||
378 | return (ih, a) -- :: NodeAddr IPv4) | ||
379 | case parse of | ||
380 | Right (ih,a) -> do | ||
381 | nodeIdType ih | ||
382 | -- nodeAddrType a | ||
383 | proxy <- dhtType | ||
384 | let fn = findNodeMessage proxy ih | ||
385 | ipType fn | ||
386 | result <- try $ queryNode' a fn | ||
387 | either (const $ return ()) (\(nid,nf,_) -> nodeIdType nid >> ipType nf) result | ||
388 | let rs = either (pure . showQueryFail) reportNodes result | ||
389 | return $ do | ||
390 | hPutClient h $ unlines rs | ||
391 | Left er -> return $ hPutClient h er | ||
392 | |||
393 | -- bittorrent only | ||
394 | ("get-peers", s) -> cmd $ BtDHT $ do | ||
395 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s | ||
396 | parse = do ih <- readEither hs | ||
397 | a <- readEither as | ||
398 | return (ih :: InfoHash, a) | ||
399 | case parse of | ||
400 | Right (ih,a) -> do | ||
401 | result <- try $ queryNode' a $ GetPeers ih | ||
402 | let rs = either (pure . ( (,) "error" ) . showQueryFail) reportPeers result | ||
403 | return $ do | ||
404 | hPutClient h $ showReport rs | ||
405 | Left er -> return $ hPutClient h er | ||
406 | |||
407 | -- bittorrent only | ||
408 | ("search-peers", s) -> cmd $ BtDHT $ do | ||
409 | case readEither s of | ||
410 | Right ih -> do | ||
411 | (tid, s) <- isearch ioGetPeers ih | ||
412 | flip fix Set.empty $ \again shown -> do | ||
413 | (chk,fin) <- liftIO . atomically $ do | ||
414 | r <- (Set.\\ shown) <$> readTVar (searchResults s) | ||
415 | if not $ Set.null r | ||
416 | then (,) r <$> searchIsFinished s | ||
417 | else searchIsFinished s >>= check >> return (Set.empty,True) | ||
418 | let ps = case Set.toList chk of | ||
419 | [] -> "" | ||
420 | _ -> unlines $ map (show . pPrint) $ Set.toList chk | ||
421 | if fin then return $ hPutClient h ps | ||
422 | else do | ||
423 | liftIO $ hPutClientChunk h ps | ||
424 | again (shown `Set.union` chk) | ||
425 | Left er -> return $ hPutClient h er | ||
426 | 205 | ||
427 | _ -> cmd0 $ hPutClient h "error." | 206 | _ -> cmd0 $ hPutClient h "error." |
428 | 207 | ||
429 | defaultPort = error "TODO defaultPort" | 208 | defaultPort = "6881" |
430 | |||
431 | showQueryFail :: QueryFailure -> String | ||
432 | showQueryFail e = show e | ||
433 | |||
434 | consip (ReflectedIP ip) xs = ("(external-ip " ++ show ip ++ ")") : xs | ||
435 | 209 | ||
436 | consip' (ReflectedIP ip) xs = ("to", show ip) : xs | ||
437 | |||
438 | reportPong (info,myip) = maybe id consip myip [show $ pPrint info] | ||
439 | |||
440 | reportNodes :: | ||
441 | ( Kademlia dht | ||
442 | , Pretty (NodeInfo dht ip ()) | ||
443 | , Pretty (NodeId dht) | ||
444 | ) => (NodeId dht, NodeFound dht ip, Maybe ReflectedIP) -> [String] | ||
445 | reportNodes (nid,ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) (foundNodes ns) | ||
446 | |||
447 | reportPeers :: (NodeId KMessageOf, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)] | ||
448 | reportPeers (nid,GotPeers r tok,myip) | ||
449 | = maybe id consip' myip $ ("from", show (pPrint nid)) | ||
450 | : ("token", show tok) | ||
451 | : case r of | ||
452 | Right ps -> map ( ( (,) "peer" ) . show . pPrint ) ps | ||
453 | Left ns -> map ( ( (,) "node" ) . show . pPrint ) ns | ||
454 | |||
455 | main :: IO () | ||
456 | main = do | 210 | main = do |
457 | args <- getArgs | 211 | args <- getArgs |
458 | p <- case take 2 (dropWhile (/="-p") args) of | 212 | p <- case take 2 (dropWhile (/="-p") args) of |
459 | ["-p",port] | not ("-" `isPrefixOf` port) -> return port | 213 | ["-p",port] | not ("-" `isPrefixOf` port) -> return port |
460 | ("-p":_) -> error "Port not specified! (-p PORT)" | 214 | ("-p":_) -> error "Port not specified! (-p PORT)" |
461 | _ -> defaultPort | 215 | _ -> return defaultPort |
462 | 216 | addr <- getBindAddress p True{- ipv6 -} | |
463 | tox_state <- godht (show (succ (read p::Int))) $ \a me0 -> ask | 217 | |
464 | 218 | (bt,btR) <- Mainline.newClient addr | |
465 | godht p $ \a me0 -> do | 219 | quitBt <- forkListener bt |
466 | printTable | 220 | |
467 | bs <- liftIO bootstrapNodes | 221 | tox <- return $ error "TODO: Tox.newClient" |
468 | `onException` | 222 | quitTox <- return $ return () -- TODO: forkListener tox |
469 | (Lifted.ioError $ userError "unable to resolve bootstrap nodes") | 223 | |
470 | saved_nodes <- resume | 224 | let dhts = Map.fromList |
471 | 225 | [ ("bt4", DHT (Mainline.routing4 btR) (Mainline.ping bt)) | |
472 | peers'trial <- liftIO $ tryIOError $ B.readFile "bt-peers.dat" | 226 | , ("bt6", DHT (Mainline.routing6 btR) (Mainline.ping bt)) |
473 | saved_peers <- | 227 | ] |
474 | either (const $ do liftIO $ putStrLn "Error reading bt-peers.dat" | 228 | |
475 | return Nothing) | 229 | waitForSignal <- do |
476 | (return . Just) | ||
477 | peers'trial | ||
478 | |||
479 | maybe (return ()) mergeSavedPeers saved_peers | ||
480 | |||
481 | when (isJust saved_nodes) $ do | ||
482 | b <- isBootstrapped | ||
483 | tbl <- getTable | ||
484 | bc <- optBucketCount <$> asks options | ||
485 | printTable | ||
486 | me <- case concat $ R.toList tbl of | ||
487 | (n,_):_ -> myNodeIdAccordingTo (nodeAddr n) | ||
488 | _ -> return me0 | ||
489 | printReport [("node-id",show $ pPrint me) | ||
490 | ,("listen-address", show a) | ||
491 | ,("bootstrapped", show b) | ||
492 | ,("buckets", show $ R.shape tbl) | ||
493 | ,("optBucketCount", show bc) | ||
494 | ,("dht-nodes.dat", "Running bootstrap...") | ||
495 | ] | ||
496 | |||
497 | st <- ask | ||
498 | waitForSignal <- liftIO $ do | ||
499 | signalQuit <- newEmptyMVar | 230 | signalQuit <- newEmptyMVar |
500 | srv <- streamServer (withSession $ clientSession st tox_state signalQuit True) (SockAddrUnix "dht.sock") | 231 | srv <- streamServer (withSession $ clientSession "bt4" dhts signalQuit) (SockAddrUnix "dht.sock") |
501 | return $ liftIO $ do | 232 | return $ do |
502 | () <- takeMVar signalQuit | 233 | () <- takeMVar signalQuit |
503 | quitListening srv | 234 | quitListening srv |
504 | 235 | ||
505 | bootstrap saved_nodes (map (MainlineNode . toSockAddr) bs) | 236 | let bkts4 = Mainline.routing4 btR |
506 | 237 | btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo] | |
507 | b <- isBootstrapped | 238 | putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4." |
508 | tbl <- getTable | 239 | fallbackNodes4 <- Mainline.bootstrapNodes Mainline.Want_IP4 |
509 | bc <- optBucketCount <$> asks options | 240 | fork $ do |
510 | printTable | 241 | myThreadId >>= flip labelThread "bootstrap.Mainline4" |
511 | ip <- routableAddress | 242 | bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4 |
512 | me <- case concat $ R.toList tbl of | 243 | saveNodes "bt4" (dhts Map.! "bt4") |
513 | (n,_):_ -> myNodeIdAccordingTo (nodeAddr n) | 244 | |
514 | _ -> return me0 | 245 | btSaved6 <- loadNodes "bt6" |
515 | printReport [("node-id",show $ pPrint me) | 246 | putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6." |
516 | ,("internet address", show ip) | 247 | let bkts6 = Mainline.routing6 btR |
517 | ,("listen-address", show a) | 248 | fallbackNodes6 <- Mainline.bootstrapNodes Mainline.Want_IP6 |
518 | ,("bootstrapped", show b) | 249 | fork $ do |
519 | ,("buckets", show $ R.shape tbl) | 250 | myThreadId >>= flip labelThread "bootstrap.Mainline6" |
520 | ,("optBucketCount", show bc) | 251 | bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6 |
521 | ] | 252 | saveNodes "bt6" (dhts Map.! "bt6") |
522 | 253 | ||
523 | waitForSignal -- Await unix socket to signal termination. | 254 | hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4 |
524 | 255 | ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6 | |
525 | snapshot >>= liftIO . B.writeFile "dht-nodes.dat" | 256 | |
526 | savePeerStore >>= liftIO . B.writeFile "bt-peers.dat" | 257 | waitForSignal |
527 | 258 | ||
259 | quitBt | ||
260 | quitTox | ||