diff options
-rw-r--r-- | bittorrent.cabal | 3 | ||||
-rw-r--r-- | examples/dhtd.hs | 220 | ||||
-rw-r--r-- | src/Network/BitTorrent/DHT.hs | 65 | ||||
-rw-r--r-- | src/Network/BitTorrent/DHT/Query.hs | 68 | ||||
-rw-r--r-- | src/Network/BitTorrent/DHT/Session.hs | 91 | ||||
-rw-r--r-- | src/Network/DHT/Mainline.hs | 76 | ||||
-rw-r--r-- | src/Network/DHT/Types.hs | 8 | ||||
-rw-r--r-- | src/Network/KRPC/Method.hs | 10 |
8 files changed, 418 insertions, 123 deletions
diff --git a/bittorrent.cabal b/bittorrent.cabal index a358a2b8..c46ed17f 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal | |||
@@ -78,6 +78,7 @@ library | |||
78 | hs-source-dirs: src | 78 | hs-source-dirs: src |
79 | exposed-modules: Network.DatagramServer | 79 | exposed-modules: Network.DatagramServer |
80 | Network.DatagramServer.Mainline | 80 | Network.DatagramServer.Mainline |
81 | Network.DatagramServer.Tox | ||
81 | Network.DatagramServer.Types | 82 | Network.DatagramServer.Types |
82 | Network.DatagramServer.Error | 83 | Network.DatagramServer.Error |
83 | Network.DHT | 84 | Network.DHT |
@@ -392,6 +393,8 @@ executable dhtd | |||
392 | , unix | 393 | , unix |
393 | , containers | 394 | , containers |
394 | , stm | 395 | , stm |
396 | , cereal | ||
397 | , bencoding | ||
395 | if flag(thread-debug) | 398 | if flag(thread-debug) |
396 | build-depends: time | 399 | build-depends: time |
397 | cpp-options: -DTHREAD_DEBUG | 400 | cpp-options: -DTHREAD_DEBUG |
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 8496dd5a..99ff7218 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -1,5 +1,7 @@ | |||
1 | {-# LANGUAGE NondecreasingIndentation #-} | 1 | {-# LANGUAGE NondecreasingIndentation #-} |
2 | {-# LANGUAGE FlexibleContexts #-} | 2 | {-# LANGUAGE FlexibleContexts #-} |
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | 5 | {-# LANGUAGE LambdaCase #-} |
4 | {-# LANGUAGE OverloadedStrings #-} | 6 | {-# LANGUAGE OverloadedStrings #-} |
5 | {-# LANGUAGE ScopedTypeVariables #-} | 7 | {-# LANGUAGE ScopedTypeVariables #-} |
@@ -7,6 +9,7 @@ | |||
7 | {-# LANGUAGE RecordWildCards #-} | 9 | {-# LANGUAGE RecordWildCards #-} |
8 | {-# LANGUAGE PartialTypeSignatures #-} | 10 | {-# LANGUAGE PartialTypeSignatures #-} |
9 | {-# LANGUAGE CPP #-} | 11 | {-# LANGUAGE CPP #-} |
12 | {-# LANGUAGE RankNTypes #-} | ||
10 | 13 | ||
11 | import Control.Arrow | 14 | import Control.Arrow |
12 | import Control.Monad | 15 | import Control.Monad |
@@ -39,6 +42,7 @@ import Network.BitTorrent.DHT.Query | |||
39 | import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..)) | 42 | import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..)) |
40 | import Network.DatagramServer (QueryFailure(..)) | 43 | import Network.DatagramServer (QueryFailure(..)) |
41 | import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf) | 44 | import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf) |
45 | import qualified Network.DatagramServer.Tox as Tox | ||
42 | import qualified Network.DHT.Routing as R | 46 | import qualified Network.DHT.Routing as R |
43 | import Network.BitTorrent.DHT.Session | 47 | import Network.BitTorrent.DHT.Session |
44 | import Network.SocketLike | 48 | import Network.SocketLike |
@@ -53,6 +57,14 @@ import Control.Concurrent | |||
53 | #endif | 57 | #endif |
54 | import Control.Concurrent.STM | 58 | import Control.Concurrent.STM |
55 | import System.Environment | 59 | import System.Environment |
60 | import Data.BEncode (BValue) | ||
61 | import Network.DHT.Types | ||
62 | import Network.DatagramServer.Types | ||
63 | import Data.Bits | ||
64 | import Data.Serialize | ||
65 | import Network.KRPC.Method | ||
66 | import Data.Typeable | ||
67 | import GHC.Generics | ||
56 | 68 | ||
57 | mkNodeAddr :: SockAddr -> NodeAddr IPv4 | 69 | mkNodeAddr :: SockAddr -> NodeAddr IPv4 |
58 | mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr) | 70 | mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr) |
@@ -72,20 +84,27 @@ showReport kvs = do | |||
72 | (k,v) <- kvs | 84 | (k,v) <- kvs |
73 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] | 85 | concat [ printf " %-*s" (colwidth+1) k, v, "\n" ] |
74 | 86 | ||
75 | showEnry :: Show a => (NodeInfo KMessageOf a (), t) -> [Char] | 87 | showEnry :: |
88 | ( Show a | ||
89 | , Pretty (NodeId dht) | ||
90 | ) => (NodeInfo dht a u, t) -> [Char] | ||
76 | showEnry (n,_) = intercalate " " | 91 | showEnry (n,_) = intercalate " " |
77 | [ show $ pPrint (nodeId n) | 92 | [ show $ pPrint (nodeId n) |
78 | , show $ nodeAddr n | 93 | , show $ nodeAddr n |
79 | ] | 94 | ] |
80 | 95 | ||
81 | printTable :: DHT IPv4 () | 96 | printTable :: |
97 | ( Pretty (NodeId dht) | ||
98 | ) => DHT raw dht u IPv4 () | ||
82 | printTable = do | 99 | printTable = do |
83 | t <- showTable | 100 | t <- showTable |
84 | liftIO $ do | 101 | liftIO $ do |
85 | putStrLn t | 102 | putStrLn t |
86 | hFlush stdout | 103 | hFlush stdout |
87 | 104 | ||
88 | showTable :: DHT IPv4 String | 105 | showTable :: |
106 | ( Pretty (NodeId dht) | ||
107 | ) => DHT raw dht u IPv4 String | ||
89 | showTable = do | 108 | showTable = do |
90 | nodes <- R.toList <$> getTable | 109 | nodes <- R.toList <$> getTable |
91 | return $ showReport | 110 | return $ showReport |
@@ -109,7 +128,7 @@ noLogging _ _ = False | |||
109 | allNoise :: LogSource -> LogLevel -> Bool | 128 | allNoise :: LogSource -> LogLevel -> Bool |
110 | allNoise _ _ = True | 129 | allNoise _ _ = True |
111 | 130 | ||
112 | resume :: DHT IPv4 (Maybe B.ByteString) | 131 | resume :: DHT raw dht u IPv4 (Maybe B.ByteString) |
113 | resume = do | 132 | resume = do |
114 | restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat" | 133 | restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat" |
115 | saved_nodes <- | 134 | saved_nodes <- |
@@ -119,7 +138,30 @@ resume = do | |||
119 | restore_attempt | 138 | restore_attempt |
120 | return saved_nodes | 139 | return saved_nodes |
121 | 140 | ||
122 | godht :: String -> (NodeAddr IPv4 -> NodeId _ -> DHT IPv4 b) -> IO b | 141 | godht :: |
142 | ( Eq (QueryMethod dht) | ||
143 | , Show (QueryMethod dht) | ||
144 | , Functor dht | ||
145 | , Ord (TransactionID dht) | ||
146 | , Serialize (TransactionID dht) | ||
147 | , Kademlia dht | ||
148 | , WireFormat raw dht | ||
149 | , DataHandlers raw dht | ||
150 | , SerializableTo raw (Query dht (FindNode dht IPv4)) | ||
151 | , SerializableTo raw (Response dht (NodeFound dht IPv4)) | ||
152 | , SerializableTo raw (Query dht (Ping dht)) | ||
153 | , SerializableTo raw (Response dht (Ping dht)) | ||
154 | , KRPC (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4)) | ||
155 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
156 | , Ord (NodeId dht) | ||
157 | , FiniteBits (NodeId dht) | ||
158 | , Serialize (NodeId dht) | ||
159 | , Show (NodeId dht) | ||
160 | , Pretty (NodeId dht) | ||
161 | , Pretty (NodeInfo dht IPv4 u) | ||
162 | , Default u | ||
163 | , Show u | ||
164 | ) => String -> (NodeAddr IPv4 -> NodeId dht -> DHT raw dht u IPv4 b) -> IO b | ||
123 | godht p f = do | 165 | godht p f = do |
124 | a <- btBindAddr p False | 166 | a <- btBindAddr p False |
125 | dht def { optTimeout = 5 } a noDebugPrints $ do | 167 | dht def { optTimeout = 5 } a noDebugPrints $ do |
@@ -138,21 +180,118 @@ hPutClient h s = hPutStr h ('.' : marshalForClient s) | |||
138 | hPutClientChunk :: Handle -> String -> IO () | 180 | hPutClientChunk :: Handle -> String -> IO () |
139 | hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) | 181 | hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) |
140 | 182 | ||
141 | clientSession :: Node IPv4 -> MVar () -> RestrictedSocket -> Int -> Handle -> IO () | 183 | data GenericDHT ip a |
142 | clientSession st signalQuit sock n h = do | 184 | = GenericDHT |
185 | (forall raw dht u. | ||
186 | ( Eq (QueryMethod dht) | ||
187 | , Show (QueryMethod dht) | ||
188 | , Functor dht | ||
189 | , Ord (TransactionID dht) | ||
190 | , Serialize (TransactionID dht) | ||
191 | , Kademlia dht | ||
192 | , WireFormat raw dht | ||
193 | , DataHandlers raw dht | ||
194 | , SerializableTo raw (Query dht (FindNode dht ip)) | ||
195 | , SerializableTo raw (Response dht (NodeFound dht ip)) | ||
196 | , SerializableTo raw (Query dht (Ping dht)) | ||
197 | , SerializableTo raw (Response dht (Ping dht)) | ||
198 | , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) | ||
199 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
200 | , Ord (NodeId dht) | ||
201 | , FiniteBits (NodeId dht) | ||
202 | , Serialize (NodeId dht) | ||
203 | , Show (NodeId dht) | ||
204 | , Pretty (NodeId dht) | ||
205 | , Pretty (NodeInfo dht ip ()) | ||
206 | , Pretty (NodeInfo dht ip u) | ||
207 | , Default u | ||
208 | , Show u | ||
209 | , Read (NodeId dht) | ||
210 | ) => DHT raw dht u ip a) | ||
211 | | BtDHT (DHT BValue KMessageOf () ip a) | ||
212 | |||
213 | dhtType :: DHT raw dht u ip (Proxy dht) | ||
214 | dhtType = return Proxy | ||
215 | |||
216 | nodeIdType :: NodeId dht -> DHT raw dht u ip () | ||
217 | nodeIdType _ = return () | ||
218 | |||
219 | nodeAddrType :: NodeAddr ip -> DHT raw dht u ip () | ||
220 | nodeAddrType _ = return () | ||
221 | |||
222 | ipType :: f dht ip -> DHT raw dht u ip () | ||
223 | ipType _ = return () | ||
224 | |||
225 | instance Kademlia Tox.Message where | ||
226 | instance Pretty (NodeId Tox.Message) where | ||
227 | instance Pretty (NodeInfo Tox.Message IPv4 ()) where | ||
228 | instance Pretty (NodeInfo Tox.Message IPv4 Bool) where -- TODO | ||
229 | instance Read (NodeId KMessageOf) where -- TODO | ||
230 | instance Read (NodeId Tox.Message) where -- TODO | ||
231 | instance Serialize (FindNode Tox.Message IPv4) where | ||
232 | get = error "TODO get" | ||
233 | put = error "TODO put" | ||
234 | instance Serialize (NodeFound Tox.Message IPv4) where | ||
235 | get = error "TODO get" | ||
236 | put = error "TODO put" | ||
237 | instance Serialize (Ping Tox.Message) where | ||
238 | get = error "TODO get" | ||
239 | put = error "TODO put" | ||
240 | instance Serialize (Query Tox.Message (FindNode Tox.Message IPv4)) where | ||
241 | get = error "TODO get" | ||
242 | put = error "TODO put" | ||
243 | instance Serialize (Query Tox.Message (Ping Tox.Message)) where -- TODO | ||
244 | get = error "TODO get" | ||
245 | put = error "TODO put" | ||
246 | instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
247 | get = error "TODO get" | ||
248 | put = error "TODO put" | ||
249 | instance Serialize (Response Tox.Message (Ping Tox.Message)) where -- TODO | ||
250 | get = error "TODO get" | ||
251 | put = error "TODO put" | ||
252 | instance KRPC (Query Tox.Message (FindNode Tox.Message IPv4)) | ||
253 | (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
254 | instance KRPC (Query Tox.Message (Ping Tox.Message )) | ||
255 | (Response Tox.Message (Ping Tox.Message )) where | ||
256 | instance DataHandlers ByteString Tox.Message where | ||
257 | |||
258 | |||
259 | -- instance Generic (Response Tox.Message (NodeFound Tox.Message IPv4)) where -- TODO | ||
260 | |||
261 | instance Default Bool where def = False | ||
262 | |||
263 | clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool -> RestrictedSocket -> Int -> Handle -> IO () | ||
264 | clientSession bt tox signalQuit isBt sock n h = do | ||
143 | line <- map toLower . dropWhile isSpace <$> hGetLine h | 265 | line <- map toLower . dropWhile isSpace <$> hGetLine h |
144 | let cmd0 action = action >> clientSession st signalQuit sock n h | 266 | let dht :: Either (Node BValue KMessageOf () IPv4) |
145 | cmd action = cmd0 $ join $ runDHT st action | 267 | (Node B.ByteString Tox.Message Bool IPv4) |
268 | dht | isBt = Left bt | ||
269 | | otherwise = Right tox | ||
270 | cmd0 :: IO () -> IO () | ||
271 | cmd0 action = action >> clientSession bt tox signalQuit isBt sock n h | ||
272 | cmd :: GenericDHT IPv4 (IO ()) -> IO () | ||
273 | cmd (GenericDHT action) = cmd0 $ join $ either (flip runDHT action) (flip runDHT action) dht | ||
274 | cmd (BtDHT action) = cmd0 $ join $ runDHT bt action | ||
146 | (c,args) = second (dropWhile isSpace) $ break isSpace line | 275 | (c,args) = second (dropWhile isSpace) $ break isSpace line |
276 | switchNetwork dest = clientSession bt tox signalQuit dest sock n h | ||
147 | case (c,args) of | 277 | case (c,args) of |
148 | 278 | ||
279 | ("bt", _) -> switchNetwork True | ||
280 | |||
281 | ("tox", _) -> switchNetwork False | ||
282 | |||
149 | ("quit", _) -> hPutClient h "" >> hClose h | 283 | ("quit", _) -> hPutClient h "" >> hClose h |
150 | 284 | ||
151 | ("stop", _) -> do hPutClient h "Terminating DHT Daemon." | 285 | ("stop", _) -> do hPutClient h "Terminating DHT Daemon." |
152 | hClose h | 286 | hClose h |
153 | putMVar signalQuit () | 287 | putMVar signalQuit () |
154 | 288 | ||
155 | ("ls", _) -> cmd $ do | 289 | ("pid", _) -> cmd0 $ do |
290 | pid <- getProcessID | ||
291 | hPutClient h (show pid) | ||
292 | |||
293 | -- DHT specific | ||
294 | ("ls", _) -> cmd $ GenericDHT $ do | ||
156 | tbl <- getTable | 295 | tbl <- getTable |
157 | t <- showTable | 296 | t <- showTable |
158 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") | 297 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") |
@@ -163,14 +302,15 @@ clientSession st signalQuit sock n h = do | |||
163 | , showReport | 302 | , showReport |
164 | [ ("node-id", show $ pPrint me) | 303 | [ ("node-id", show $ pPrint me) |
165 | , ("internet address", show ip) | 304 | , ("internet address", show ip) |
166 | , ("buckets", show $ R.shape tbl)] | 305 | , ("buckets", show $ R.shape tbl) |
306 | , ("network", if isBt then "mainline" else "tox") ] | ||
167 | ] | 307 | ] |
168 | ("external-ip", _) -> cmd $ do | 308 | ("external-ip", _) -> cmd $ BtDHT $ do |
169 | ip <- routableAddress | 309 | ip <- routableAddress |
170 | return $ do | 310 | return $ do |
171 | hPutClient h $ maybe "" (takeWhile (/=':') . show) ip | 311 | hPutClient h $ maybe "" (takeWhile (/=':') . show) ip |
172 | 312 | ||
173 | ("swarms", s) -> cmd $ do | 313 | ("swarms", s) -> cmd $ BtDHT $ do |
174 | let fltr = case s of | 314 | let fltr = case s of |
175 | ('-':'v':cs) | all isSpace (take 1 cs) | 315 | ('-':'v':cs) | all isSpace (take 1 cs) |
176 | -> const True | 316 | -> const True |
@@ -181,23 +321,21 @@ clientSession st signalQuit sock n h = do | |||
181 | return $ do | 321 | return $ do |
182 | hPutClient h $ showReport r | 322 | hPutClient h $ showReport r |
183 | 323 | ||
184 | ("peers", s) -> cmd $ case readEither s of | 324 | -- bittorrent only |
325 | ("peers", s) -> cmd $ BtDHT $ case readEither s of | ||
185 | Right ih -> do | 326 | Right ih -> do |
186 | ps <- allPeers ih | 327 | ps <- allPeers ih |
187 | seq ih $ return $ do | 328 | seq ih $ return $ do |
188 | hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps | 329 | hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps |
189 | Left er -> return $ hPutClient h er | 330 | Left er -> return $ hPutClient h er |
190 | 331 | ||
191 | ("pid", _) -> cmd $ return $ do | ||
192 | pid <- getProcessID | ||
193 | hPutClient h (show pid) | ||
194 | #ifdef THREAD_DEBUG | 332 | #ifdef THREAD_DEBUG |
195 | ("threads", _) -> cmd $ return $ do | 333 | ("threads", _) -> cmd0 $ do |
196 | ts <- threadsInformation | 334 | ts <- threadsInformation |
197 | tm <- getCurrentTime | 335 | tm <- getCurrentTime |
198 | let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts | 336 | let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts |
199 | hPutClient h $ showReport r | 337 | hPutClient h $ showReport r |
200 | ("mem", s) -> cmd $ return $ do | 338 | ("mem", s) -> cmd0 $ do |
201 | case s of | 339 | case s of |
202 | "gc" -> do hPutClient h "Performing garbage collection..." | 340 | "gc" -> do hPutClient h "Performing garbage collection..." |
203 | performMajorGC | 341 | performMajorGC |
@@ -230,24 +368,27 @@ clientSession st signalQuit sock n h = do | |||
230 | _ -> hPutClient h "error." | 368 | _ -> hPutClient h "error." |
231 | 369 | ||
232 | #endif | 370 | #endif |
233 | ("closest", s) -> cmd $ do | 371 | -- DHT specific |
372 | ("closest", s) -> cmd $ GenericDHT $ do | ||
234 | let (ns,hs) = second (dropWhile isSpace) $ break isSpace s | 373 | let (ns,hs) = second (dropWhile isSpace) $ break isSpace s |
235 | parse | null hs = do | 374 | parse | null hs = do |
236 | ih <- readEither ns | 375 | ih <- readEither ns |
237 | return (8 :: Int, ih :: InfoHash) | 376 | return (8 :: Int, ih) |
238 | | otherwise = do | 377 | | otherwise = do |
239 | n <- readEither ns | 378 | n <- readEither ns |
240 | ih <- readEither hs | 379 | ih <- readEither hs |
241 | return (n :: Int, ih :: InfoHash) | 380 | return (n :: Int, ih) |
242 | case parse of | 381 | case parse of |
243 | Right (n,ih) -> do | 382 | Right (n,ih) -> do |
383 | nodeIdType ih | ||
244 | tbl <- getTable | 384 | tbl <- getTable |
245 | let nodes = R.kclosest n ih tbl | 385 | let nodes = R.kclosest n ih tbl |
246 | return $ do | 386 | return $ do |
247 | hPutClient h $ unlines $ map (showEnry . (flip (,) 0)) nodes | 387 | hPutClient h $ unlines $ map (showEnry . (flip (,) (error "showEnry"))) nodes |
248 | Left er -> return $ hPutClient h er | 388 | Left er -> return $ hPutClient h er |
249 | 389 | ||
250 | ("ping", s) -> cmd $ do | 390 | -- DHT specific |
391 | ("ping", s) -> cmd $ GenericDHT $ do | ||
251 | case readEither s of | 392 | case readEither s of |
252 | Right addr -> do result <- try $ pingQ addr | 393 | Right addr -> do result <- try $ pingQ addr |
253 | let rs = either (pure . showQueryFail) reportPong result | 394 | let rs = either (pure . showQueryFail) reportPong result |
@@ -255,22 +396,30 @@ clientSession st signalQuit sock n h = do | |||
255 | hPutClient h $ unlines rs | 396 | hPutClient h $ unlines rs |
256 | Left er -> return $ hPutClient h er | 397 | Left er -> return $ hPutClient h er |
257 | 398 | ||
258 | ("find-nodes", s) -> cmd $ do | 399 | -- DHT specific |
400 | ("find-nodes", s) -> cmd $ GenericDHT $ do | ||
259 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s | 401 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s |
260 | parse = do ih <- readEither hs | 402 | parse = do ih <- readEither hs |
261 | a <- readEither as | 403 | a <- readEither as |
262 | -- XXX: using 'InfoHash' only because 'NodeId' currently | 404 | -- XXX: using 'InfoHash' only because 'NodeId' currently |
263 | -- has no 'Read' instance. | 405 | -- has no 'Read' instance. |
264 | return (ih :: InfoHash, a :: NodeAddr IPv4) | 406 | return (ih, a :: NodeAddr IPv4) |
265 | case parse of | 407 | case parse of |
266 | Right (ih,a) -> do | 408 | Right (ih,a) -> do |
267 | result <- try $ queryNode' (a ::NodeAddr IPv4) $ FindNode (R.toNodeId ih) | 409 | nodeIdType ih |
410 | nodeAddrType a | ||
411 | proxy <- dhtType | ||
412 | let fn = findNodeMessage proxy ih | ||
413 | ipType fn | ||
414 | result <- try $ queryNode' a fn | ||
415 | either (const $ return ()) (\(nid,nf,_) -> nodeIdType nid >> ipType nf) result | ||
268 | let rs = either (pure . showQueryFail) reportNodes result | 416 | let rs = either (pure . showQueryFail) reportNodes result |
269 | return $ do | 417 | return $ do |
270 | hPutClient h $ unlines rs | 418 | hPutClient h $ unlines rs |
271 | Left er -> return $ hPutClient h er | 419 | Left er -> return $ hPutClient h er |
272 | 420 | ||
273 | ("get-peers", s) -> cmd $ do | 421 | -- bittorrent only |
422 | ("get-peers", s) -> cmd $ BtDHT $ do | ||
274 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s | 423 | let (hs,as) = second (dropWhile isSpace) $ break isSpace s |
275 | parse = do ih <- readEither hs | 424 | parse = do ih <- readEither hs |
276 | a <- readEither as | 425 | a <- readEither as |
@@ -283,7 +432,8 @@ clientSession st signalQuit sock n h = do | |||
283 | hPutClient h $ showReport rs | 432 | hPutClient h $ showReport rs |
284 | Left er -> return $ hPutClient h er | 433 | Left er -> return $ hPutClient h er |
285 | 434 | ||
286 | ("search-peers", s) -> cmd $ do | 435 | -- bittorrent only |
436 | ("search-peers", s) -> cmd $ BtDHT $ do | ||
287 | case readEither s of | 437 | case readEither s of |
288 | Right ih -> do | 438 | Right ih -> do |
289 | (tid, s) <- isearch ioGetPeers ih | 439 | (tid, s) <- isearch ioGetPeers ih |
@@ -315,10 +465,14 @@ consip' (ReflectedIP ip) xs = ("to", show ip) : xs | |||
315 | 465 | ||
316 | reportPong (info,myip) = maybe id consip myip [show $ pPrint info] | 466 | reportPong (info,myip) = maybe id consip myip [show $ pPrint info] |
317 | 467 | ||
318 | reportNodes :: (NodeId _, NodeFound IPv4, Maybe ReflectedIP) -> [String] | 468 | reportNodes :: |
319 | reportNodes (nid,NodeFound ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) ns | 469 | ( Kademlia dht |
470 | , Pretty (NodeInfo dht ip ()) | ||
471 | , Pretty (NodeId dht) | ||
472 | ) => (NodeId dht, NodeFound dht ip, Maybe ReflectedIP) -> [String] | ||
473 | reportNodes (nid,ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) (foundNodes ns) | ||
320 | 474 | ||
321 | reportPeers :: (NodeId _, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)] | 475 | reportPeers :: (NodeId KMessageOf, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)] |
322 | reportPeers (nid,GotPeers r tok,myip) | 476 | reportPeers (nid,GotPeers r tok,myip) |
323 | = maybe id consip' myip $ ("from", show (pPrint nid)) | 477 | = maybe id consip' myip $ ("from", show (pPrint nid)) |
324 | : ("token", show tok) | 478 | : ("token", show tok) |
@@ -368,7 +522,7 @@ main = do | |||
368 | st <- ask | 522 | st <- ask |
369 | waitForSignal <- liftIO $ do | 523 | waitForSignal <- liftIO $ do |
370 | signalQuit <- newEmptyMVar | 524 | signalQuit <- newEmptyMVar |
371 | srv <- streamServer (withSession $ clientSession st signalQuit) (SockAddrUnix "dht.sock") | 525 | srv <- streamServer (withSession $ clientSession st (error "todo: tox state") signalQuit True) (SockAddrUnix "dht.sock") |
372 | return $ liftIO $ do | 526 | return $ liftIO $ do |
373 | () <- takeMVar signalQuit | 527 | () <- takeMVar signalQuit |
374 | quitListening srv | 528 | quitListening srv |
diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs index 8bc423a3..6d31eab2 100644 --- a/src/Network/BitTorrent/DHT.hs +++ b/src/Network/BitTorrent/DHT.hs | |||
@@ -76,8 +76,13 @@ import Data.Typeable | |||
76 | import Data.Monoid | 76 | import Data.Monoid |
77 | import Network.DatagramServer.Mainline (KMessageOf) | 77 | import Network.DatagramServer.Mainline (KMessageOf) |
78 | import qualified Network.DatagramServer as KRPC (listen, Protocol(..)) | 78 | import qualified Network.DatagramServer as KRPC (listen, Protocol(..)) |
79 | 79 | import Network.DatagramServer.Types | |
80 | 80 | import Network.DHT.Types | |
81 | import Data.Bits | ||
82 | import Data.Default | ||
83 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) | ||
84 | import Network.KRPC.Method | ||
85 | import Network.BitTorrent.DHT.Query (DataHandlers) | ||
81 | 86 | ||
82 | {----------------------------------------------------------------------- | 87 | {----------------------------------------------------------------------- |
83 | -- DHT types | 88 | -- DHT types |
@@ -96,7 +101,31 @@ fullLogging :: LogSource -> LogLevel -> Bool | |||
96 | fullLogging _ _ = True | 101 | fullLogging _ _ = True |
97 | 102 | ||
98 | -- | Run DHT on specified port. <add note about resources> | 103 | -- | Run DHT on specified port. <add note about resources> |
99 | dht :: (Ord ip, Address ip) | 104 | dht :: |
105 | ( Ord ip | ||
106 | , Address ip | ||
107 | , Functor dht | ||
108 | , Ord (NodeId dht) | ||
109 | , FiniteBits (NodeId dht) | ||
110 | , Serialize (NodeId dht) | ||
111 | , Show (NodeId dht) | ||
112 | , SerializableTo raw (Response dht (Ping dht)) | ||
113 | , SerializableTo raw (Query dht (Ping dht)) | ||
114 | , SerializableTo raw (Response dht (NodeFound dht ip)) | ||
115 | , SerializableTo raw (Query dht (FindNode dht ip)) | ||
116 | , Ord (TransactionID dht) | ||
117 | , Serialize (TransactionID dht) | ||
118 | , Eq (QueryMethod dht) | ||
119 | , Show (QueryMethod dht) | ||
120 | , Pretty (NodeInfo dht ip u) | ||
121 | , Kademlia dht | ||
122 | , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) | ||
123 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
124 | , DataHandlers raw dht | ||
125 | , WireFormat raw dht | ||
126 | , Show u | ||
127 | , Default u | ||
128 | ) | ||
100 | => Options -- ^ normally you need to use 'Data.Default.def'; | 129 | => Options -- ^ normally you need to use 'Data.Default.def'; |
101 | -> NodeAddr ip -- ^ address to bind this node; | 130 | -> NodeAddr ip -- ^ address to bind this node; |
102 | -> (LogSource -> LogLevel -> Bool) -- ^ use 'fullLogging' as a noisy default | 131 | -> (LogSource -> LogLevel -> Bool) -- ^ use 'fullLogging' as a noisy default |
@@ -179,7 +208,33 @@ resolveHostName NodeAddr {..} = do | |||
179 | -- | 208 | -- |
180 | -- This operation do block, use | 209 | -- This operation do block, use |
181 | -- 'Control.Concurrent.Async.Lifted.async' if needed. | 210 | -- 'Control.Concurrent.Async.Lifted.async' if needed. |
182 | bootstrap :: forall raw dht u ip. Address ip => Maybe BS.ByteString -> [NodeAddr ip] -> DHT raw dht u ip () | 211 | bootstrap :: forall raw dht u ip. |
212 | ( Ord ip | ||
213 | , Address ip | ||
214 | , Functor dht | ||
215 | , Ord (NodeId dht) | ||
216 | , FiniteBits (NodeId dht) | ||
217 | , Serialize (NodeId dht) | ||
218 | , Show (NodeId dht) | ||
219 | , Pretty (NodeId dht) | ||
220 | , SerializableTo raw (Response dht (Ping dht)) | ||
221 | , SerializableTo raw (Query dht (Ping dht)) | ||
222 | , SerializableTo raw (Response dht (NodeFound dht ip)) | ||
223 | , SerializableTo raw (Query dht (FindNode dht ip)) | ||
224 | , Ord (TransactionID dht) | ||
225 | , Serialize (TransactionID dht) | ||
226 | , Eq (QueryMethod dht) | ||
227 | , Show (QueryMethod dht) | ||
228 | , Pretty (NodeInfo dht ip u) | ||
229 | , Kademlia dht | ||
230 | , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) | ||
231 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
232 | , DataHandlers raw dht | ||
233 | , WireFormat raw dht | ||
234 | , Show u | ||
235 | , Default u | ||
236 | , Serialize u | ||
237 | ) => Maybe BS.ByteString -> [NodeAddr ip] -> DHT raw dht u ip () | ||
183 | bootstrap mbs startNodes = do | 238 | bootstrap mbs startNodes = do |
184 | restored <- | 239 | restored <- |
185 | case decode <$> mbs of | 240 | case decode <$> mbs of |
@@ -192,7 +247,7 @@ bootstrap mbs startNodes = do | |||
192 | let searchAll aliveNodes = do | 247 | let searchAll aliveNodes = do |
193 | nid <- myNodeIdAccordingTo (error "FIXME") | 248 | nid <- myNodeIdAccordingTo (error "FIXME") |
194 | ns <- bgsearch ioFindNodes nid | 249 | ns <- bgsearch ioFindNodes nid |
195 | return ( ns :: [NodeInfo KMessageOf ip ()] ) | 250 | return ( ns :: [NodeInfo dht ip u] ) |
196 | input_nodes <- (restored ++) . T.toList <$> getTable | 251 | input_nodes <- (restored ++) . T.toList <$> getTable |
197 | -- Step 1: Use iterative searches to flesh out the table.. | 252 | -- Step 1: Use iterative searches to flesh out the table.. |
198 | do let knowns = map (map $ nodeAddr . fst) input_nodes | 253 | do let knowns = map (map $ nodeAddr . fst) input_nodes |
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs index e5d9bd5f..67dc4541 100644 --- a/src/Network/BitTorrent/DHT/Query.hs +++ b/src/Network/BitTorrent/DHT/Query.hs | |||
@@ -16,6 +16,8 @@ | |||
16 | {-# LANGUAGE TupleSections #-} | 16 | {-# LANGUAGE TupleSections #-} |
17 | {-# LANGUAGE PartialTypeSignatures #-} | 17 | {-# LANGUAGE PartialTypeSignatures #-} |
18 | {-# LANGUAGE GADTs #-} | 18 | {-# LANGUAGE GADTs #-} |
19 | {-# LANGUAGE RankNTypes #-} | ||
20 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
19 | module Network.BitTorrent.DHT.Query | 21 | module Network.BitTorrent.DHT.Query |
20 | ( -- * Handler | 22 | ( -- * Handler |
21 | -- | To bind specific set of handlers you need to pass | 23 | -- | To bind specific set of handlers you need to pass |
@@ -25,6 +27,7 @@ module Network.BitTorrent.DHT.Query | |||
25 | , getPeersH | 27 | , getPeersH |
26 | , announceH | 28 | , announceH |
27 | , defaultHandlers | 29 | , defaultHandlers |
30 | , DataHandlers | ||
28 | 31 | ||
29 | -- * Query | 32 | -- * Query |
30 | -- ** Basic | 33 | -- ** Basic |
@@ -113,6 +116,7 @@ import Data.Serialize | |||
113 | import System.IO.Unsafe (unsafeInterleaveIO) | 116 | import System.IO.Unsafe (unsafeInterleaveIO) |
114 | import Data.String | 117 | import Data.String |
115 | 118 | ||
119 | |||
116 | {----------------------------------------------------------------------- | 120 | {----------------------------------------------------------------------- |
117 | -- Handlers | 121 | -- Handlers |
118 | -----------------------------------------------------------------------} | 122 | -----------------------------------------------------------------------} |
@@ -215,20 +219,68 @@ kademliaHandlers logger = do | |||
215 | , handler (nameFindNodes dht) $ findNodeH getclosest | 219 | , handler (nameFindNodes dht) $ findNodeH getclosest |
216 | ] | 220 | ] |
217 | 221 | ||
222 | class DataHandlers raw dht where | ||
223 | dataHandlers :: | ||
224 | ( Ord ip , Hashable ip, Typeable ip, Serialize ip) => | ||
225 | (NodeId dht -> IO [NodeInfo dht ip ()]) | ||
226 | -> DHTData dht ip | ||
227 | -> [MethodHandler raw dht ip] | ||
228 | |||
229 | instance DataHandlers BValue KMessageOf where | ||
230 | dataHandlers = bthandlers | ||
231 | |||
232 | bthandlers :: | ||
233 | ( Ord ip , Hashable ip, Typeable ip, Serialize ip) => | ||
234 | (NodeId KMessageOf -> IO [NodeInfo KMessageOf ip ()]) | ||
235 | -> DHTData KMessageOf ip | ||
236 | -> [MethodHandler BValue KMessageOf ip] | ||
237 | bthandlers getclosest dta = | ||
238 | [ MethodHandler "get_peers" $ getPeersH (getpeers dta) (sessionTokens dta) | ||
239 | , MethodHandler "announce_peer" $ announceH (contactInfo dta) (sessionTokens dta) | ||
240 | ] | ||
241 | where | ||
242 | getpeers dta ih = do | ||
243 | ps <- lookupPeers (contactInfo dta) ih | ||
244 | if L.null ps | ||
245 | then Left <$> getclosest (toNodeId ih) | ||
246 | else return (Right ps) | ||
247 | |||
248 | data MethodHandler raw dht ip = | ||
249 | forall a b. ( SerializableTo raw (Response dht b) | ||
250 | , SerializableTo raw (Query dht a) | ||
251 | ) => MethodHandler (QueryMethod dht) (NodeAddr ip -> a -> IO b) | ||
218 | 252 | ||
219 | -- | Includes all default query handlers. | 253 | -- | Includes all default query handlers. |
220 | defaultHandlers :: forall ip. (Eq ip, Ord ip, Address ip) => LogFun -> DHT BValue KMessageOf () ip [NodeHandler] | 254 | defaultHandlers :: forall raw dht u ip. |
255 | ( Ord (TransactionID dht) | ||
256 | , Ord (NodeId dht) | ||
257 | , Show u | ||
258 | , SerializableTo raw (Response dht (Ping dht)) | ||
259 | , SerializableTo raw (Query dht (Ping dht)) | ||
260 | , Show (QueryMethod dht) | ||
261 | , Show (NodeId dht) | ||
262 | , FiniteBits (NodeId dht) | ||
263 | , Default u | ||
264 | , Serialize (TransactionID dht) | ||
265 | , WireFormat raw dht | ||
266 | , Kademlia dht | ||
267 | , KRPC (Query dht (Ping dht)) (Response dht (Ping dht)) | ||
268 | , Functor dht | ||
269 | , Pretty (NodeInfo dht ip u) | ||
270 | , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip)) | ||
271 | , SerializableTo raw (Response dht (NodeFound dht ip)) | ||
272 | , SerializableTo raw (Query dht (FindNode dht ip)) | ||
273 | , Eq ip, Ord ip, Address ip, DataHandlers raw dht | ||
274 | ) => LogFun -> DHT raw dht u ip [Handler IO dht raw] | ||
221 | defaultHandlers logger = do | 275 | defaultHandlers logger = do |
222 | groknode <- insertNode1 | 276 | groknode <- insertNode1 |
223 | mynid <- myNodeIdAccordingTo1 | 277 | mynid <- myNodeIdAccordingTo1 |
224 | let handler :: KRPC (Query KMessageOf a) (Response KMessageOf b) => QueryMethod KMessageOf -> (NodeAddr ip -> a -> IO b) -> NodeHandler | 278 | let handler :: MethodHandler raw dht ip -> Handler IO dht raw |
225 | handler = nodeHandler groknode mynid (logt logger) | 279 | handler (MethodHandler name action) = nodeHandler groknode mynid (logt logger) name action |
226 | toks <- asks sessionTokens | 280 | dta <- asks dhtData |
227 | peers <- asks contactInfo | 281 | getclosest <- getClosest1 |
228 | getpeers <- getPeerList1 | ||
229 | hs <- kademliaHandlers logger | 282 | hs <- kademliaHandlers logger |
230 | return $ hs ++ [ handler "get_peers" $ getPeersH getpeers toks | 283 | return $ hs ++ L.map handler (dataHandlers (fmap (fmap (fmap (const ()))) . getclosest) dta) |
231 | , handler "announce_peer" $ announceH peers toks ] | ||
232 | 284 | ||
233 | {----------------------------------------------------------------------- | 285 | {----------------------------------------------------------------------- |
234 | -- Basic queries | 286 | -- Basic queries |
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs index f96ba707..d94f028f 100644 --- a/src/Network/BitTorrent/DHT/Session.hs +++ b/src/Network/BitTorrent/DHT/Session.hs | |||
@@ -35,9 +35,10 @@ module Network.BitTorrent.DHT.Session | |||
35 | , routingInfo | 35 | , routingInfo |
36 | , routableAddress | 36 | , routableAddress |
37 | , getTimestamp | 37 | , getTimestamp |
38 | , SessionTokens | 38 | -- , SessionTokens |
39 | , sessionTokens | 39 | -- , sessionTokens |
40 | , contactInfo | 40 | -- , contactInfo |
41 | , dhtData | ||
41 | , PeerStore | 42 | , PeerStore |
42 | , manager | 43 | , manager |
43 | 44 | ||
@@ -55,8 +56,8 @@ module Network.BitTorrent.DHT.Session | |||
55 | , runDHT | 56 | , runDHT |
56 | 57 | ||
57 | -- ** Tokens | 58 | -- ** Tokens |
58 | , grantToken | 59 | -- , grantToken |
59 | , checkToken | 60 | -- , checkToken |
60 | 61 | ||
61 | -- ** Routing table | 62 | -- ** Routing table |
62 | , getTable | 63 | , getTable |
@@ -68,6 +69,7 @@ module Network.BitTorrent.DHT.Session | |||
68 | , insertPeer | 69 | , insertPeer |
69 | , getPeerList | 70 | , getPeerList |
70 | , getPeerList1 | 71 | , getPeerList1 |
72 | , lookupPeers | ||
71 | , insertTopic | 73 | , insertTopic |
72 | , deleteTopic | 74 | , deleteTopic |
73 | , getSwarms | 75 | , getSwarms |
@@ -113,6 +115,7 @@ import Data.Time.Clock.POSIX | |||
113 | import Data.Text as Text | 115 | import Data.Text as Text |
114 | import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) | 116 | import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) |
115 | import Data.Serialize as S | 117 | import Data.Serialize as S |
118 | import Network.DHT.Types | ||
116 | 119 | ||
117 | 120 | ||
118 | import Data.Torrent as Torrent | 121 | import Data.Torrent as Torrent |
@@ -228,33 +231,6 @@ instance Default Options where | |||
228 | 231 | ||
229 | seconds :: NominalDiffTime -> Int | 232 | seconds :: NominalDiffTime -> Int |
230 | seconds dt = fromEnum (realToFrac dt :: Uni) | 233 | seconds dt = fromEnum (realToFrac dt :: Uni) |
231 | |||
232 | {----------------------------------------------------------------------- | ||
233 | -- Tokens policy | ||
234 | -----------------------------------------------------------------------} | ||
235 | |||
236 | data SessionTokens = SessionTokens | ||
237 | { tokenMap :: !TokenMap | ||
238 | , lastUpdate :: !UTCTime | ||
239 | , maxInterval :: !NominalDiffTime | ||
240 | } | ||
241 | |||
242 | nullSessionTokens :: IO SessionTokens | ||
243 | nullSessionTokens = SessionTokens | ||
244 | <$> (tokens <$> liftIO randomIO) | ||
245 | <*> liftIO getCurrentTime | ||
246 | <*> pure defaultUpdateInterval | ||
247 | |||
248 | -- TODO invalidate *twice* if needed | ||
249 | invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens | ||
250 | invalidateTokens curTime ts @ SessionTokens {..} | ||
251 | | curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens | ||
252 | { tokenMap = update tokenMap | ||
253 | , lastUpdate = curTime | ||
254 | , maxInterval = maxInterval | ||
255 | } | ||
256 | | otherwise = ts | ||
257 | |||
258 | {----------------------------------------------------------------------- | 234 | {----------------------------------------------------------------------- |
259 | -- Session | 235 | -- Session |
260 | -----------------------------------------------------------------------} | 236 | -----------------------------------------------------------------------} |
@@ -277,9 +253,8 @@ data Node raw dht u ip = Node | |||
277 | , resources :: !InternalState | 253 | , resources :: !InternalState |
278 | , manager :: !(Manager raw dht) -- ^ RPC manager; | 254 | , manager :: !(Manager raw dht) -- ^ RPC manager; |
279 | , routingInfo :: !(TVar (Maybe (R.Info dht ip u))) -- ^ search table; | 255 | , routingInfo :: !(TVar (Maybe (R.Info dht ip u))) -- ^ search table; |
280 | , contactInfo :: !(TVar (PeerStore ip )) -- ^ published by other nodes; | ||
281 | , announceInfo :: !(TVar AnnounceSet ) -- ^ to publish by this node; | 256 | , announceInfo :: !(TVar AnnounceSet ) -- ^ to publish by this node; |
282 | , sessionTokens :: !(TVar SessionTokens ) -- ^ query session IDs. | 257 | , dhtData :: DHTData dht ip |
283 | , loggerFun :: !LogFun | 258 | , loggerFun :: !LogFun |
284 | } | 259 | } |
285 | 260 | ||
@@ -371,6 +346,7 @@ locFromCS cs = case getCallStack cs of | |||
371 | newNode :: ( Address ip | 346 | newNode :: ( Address ip |
372 | , FiniteBits (NodeId dht) | 347 | , FiniteBits (NodeId dht) |
373 | , Serialize (NodeId dht) | 348 | , Serialize (NodeId dht) |
349 | , Kademlia dht | ||
374 | ) | 350 | ) |
375 | => -- [NodeHandler] -- ^ handlers to run on accepted queries; | 351 | => -- [NodeHandler] -- ^ handlers to run on accepted queries; |
376 | Options -- ^ various dht options; | 352 | Options -- ^ various dht options; |
@@ -389,12 +365,12 @@ newNode opts naddr logger mbid = do | |||
389 | s <- getInternalState | 365 | s <- getInternalState |
390 | (_, m) <- allocate (newManager rpcOpts (logt logger) nodeAddr []) closeManager | 366 | (_, m) <- allocate (newManager rpcOpts (logt logger) nodeAddr []) closeManager |
391 | liftIO $ do | 367 | liftIO $ do |
368 | dta <- initializeDHTData | ||
392 | myId <- maybe genNodeId return mbid | 369 | myId <- maybe genNodeId return mbid |
393 | node <- Node opts myId s m | 370 | node <- Node opts myId s m |
394 | <$> atomically (newTVar Nothing) | 371 | <$> atomically (newTVar Nothing) |
395 | <*> newTVarIO def | ||
396 | <*> newTVarIO S.empty | 372 | <*> newTVarIO S.empty |
397 | <*> (newTVarIO =<< nullSessionTokens) | 373 | <*> pure dta |
398 | <*> pure logger | 374 | <*> pure logger |
399 | return node | 375 | return node |
400 | 376 | ||
@@ -415,29 +391,6 @@ runDHT node action = runReaderT (unDHT action) node | |||
415 | -- /pick a random ID/ in the range of the bucket and perform a | 391 | -- /pick a random ID/ in the range of the bucket and perform a |
416 | -- find_nodes search on it. | 392 | -- find_nodes search on it. |
417 | 393 | ||
418 | {----------------------------------------------------------------------- | ||
419 | -- Tokens | ||
420 | -----------------------------------------------------------------------} | ||
421 | |||
422 | tryUpdateSecret :: TVar SessionTokens -> IO () | ||
423 | tryUpdateSecret toks = do | ||
424 | curTime <- liftIO getCurrentTime | ||
425 | liftIO $ atomically $ modifyTVar' toks (invalidateTokens curTime) | ||
426 | |||
427 | grantToken :: Hashable a => TVar SessionTokens -> NodeAddr a -> IO Token | ||
428 | grantToken sessionTokens addr = do | ||
429 | tryUpdateSecret sessionTokens | ||
430 | toks <- readTVarIO sessionTokens | ||
431 | return $ T.lookup addr $ tokenMap toks | ||
432 | |||
433 | -- | Throws 'HandlerError' if the token is invalid or already | ||
434 | -- expired. See 'TokenMap' for details. | ||
435 | checkToken :: Hashable a => TVar SessionTokens -> NodeAddr a -> Token -> IO Bool | ||
436 | checkToken sessionTokens addr questionableToken = do | ||
437 | tryUpdateSecret sessionTokens | ||
438 | toks <- readTVarIO sessionTokens | ||
439 | return $ T.member addr questionableToken (tokenMap toks) | ||
440 | |||
441 | 394 | ||
442 | {----------------------------------------------------------------------- | 395 | {----------------------------------------------------------------------- |
443 | -- Routing table | 396 | -- Routing table |
@@ -475,28 +428,28 @@ getTable = do | |||
475 | let nil = nullTable myId (optBucketCount opts) | 428 | let nil = nullTable myId (optBucketCount opts) |
476 | liftIO (maybe nil R.myBuckets <$> atomically (readTVar var)) | 429 | liftIO (maybe nil R.myBuckets <$> atomically (readTVar var)) |
477 | 430 | ||
478 | getSwarms :: Ord ip => DHT raw dht u ip [ (InfoHash, Int, Maybe ByteString) ] | 431 | getSwarms :: Ord ip => DHT raw KMessageOf u ip [ (InfoHash, Int, Maybe ByteString) ] |
479 | getSwarms = do | 432 | getSwarms = do |
480 | store <- asks contactInfo >>= liftIO . atomically . readTVar | 433 | store <- asks (contactInfo . dhtData) >>= liftIO . atomically . readTVar |
481 | return $ P.knownSwarms store | 434 | return $ P.knownSwarms store |
482 | 435 | ||
483 | savePeerStore :: (Ord ip, Address ip) => DHT raw dht u ip ByteString | 436 | savePeerStore :: (Ord ip, Address ip) => DHT raw KMessageOf u ip ByteString |
484 | savePeerStore = do | 437 | savePeerStore = do |
485 | var <- asks contactInfo | 438 | var <- asks (contactInfo . dhtData) |
486 | peers <- liftIO $ atomically $ readTVar var | 439 | peers <- liftIO $ atomically $ readTVar var |
487 | return $ S.encode peers | 440 | return $ S.encode peers |
488 | 441 | ||
489 | mergeSavedPeers :: (Ord ip, Address ip) => ByteString -> DHT raw dht u ip () | 442 | mergeSavedPeers :: (Ord ip, Address ip) => ByteString -> DHT raw KMessageOf u ip () |
490 | mergeSavedPeers bs = do | 443 | mergeSavedPeers bs = do |
491 | var <- asks contactInfo | 444 | var <- asks (contactInfo . dhtData) |
492 | case S.decode bs of | 445 | case S.decode bs of |
493 | Right newbies -> liftIO $ atomically $ modifyTVar' var (<> newbies) | 446 | Right newbies -> liftIO $ atomically $ modifyTVar' var (<> newbies) |
494 | Left _ -> return () | 447 | Left _ -> return () |
495 | 448 | ||
496 | 449 | ||
497 | allPeers :: Ord ip => InfoHash -> DHT raw dht u ip [ PeerAddr ip ] | 450 | allPeers :: Ord ip => InfoHash -> DHT raw KMessageOf u ip [ PeerAddr ip ] |
498 | allPeers ih = do | 451 | allPeers ih = do |
499 | store <- asks contactInfo >>= liftIO . atomically . readTVar | 452 | store <- asks (contactInfo . dhtData) >>= liftIO . atomically . readTVar |
500 | return $ P.lookup ih store | 453 | return $ P.lookup ih store |
501 | 454 | ||
502 | -- | Find a set of closest nodes from routing table of this node. (in | 455 | -- | Find a set of closest nodes from routing table of this node. (in |
@@ -566,7 +519,7 @@ getTimestamp = do | |||
566 | -- | 519 | -- |
567 | getPeerList :: Ord ip => InfoHash -> DHT raw KMessageOf () ip (PeerList ip) | 520 | getPeerList :: Ord ip => InfoHash -> DHT raw KMessageOf () ip (PeerList ip) |
568 | getPeerList ih = do | 521 | getPeerList ih = do |
569 | var <- asks contactInfo | 522 | var <- asks (contactInfo . dhtData) |
570 | ps <- liftIO $ lookupPeers var ih | 523 | ps <- liftIO $ lookupPeers var ih |
571 | if L.null ps | 524 | if L.null ps |
572 | then Left <$> getClosest ih | 525 | then Left <$> getClosest ih |
@@ -574,7 +527,7 @@ getPeerList ih = do | |||
574 | 527 | ||
575 | getPeerList1 :: Ord ip => DHT raw KMessageOf () ip (InfoHash -> IO (PeerList ip)) | 528 | getPeerList1 :: Ord ip => DHT raw KMessageOf () ip (InfoHash -> IO (PeerList ip)) |
576 | getPeerList1 = do | 529 | getPeerList1 = do |
577 | var <- asks contactInfo | 530 | var <- asks (contactInfo . dhtData) |
578 | getclosest <- getClosest1 | 531 | getclosest <- getClosest1 |
579 | return $ \ih -> do | 532 | return $ \ih -> do |
580 | ps <- lookupPeers var ih | 533 | ps <- lookupPeers var ih |
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs index 29d4231d..aefd7742 100644 --- a/src/Network/DHT/Mainline.hs +++ b/src/Network/DHT/Mainline.hs | |||
@@ -88,6 +88,10 @@ module Network.DHT.Mainline | |||
88 | , Announce (..) | 88 | , Announce (..) |
89 | , Announced (..) | 89 | , Announced (..) |
90 | #endif | 90 | #endif |
91 | , DHTData(..) | ||
92 | , SessionTokens(..) | ||
93 | , grantToken | ||
94 | , checkToken | ||
91 | ) where | 95 | ) where |
92 | 96 | ||
93 | import Control.Applicative | 97 | import Control.Applicative |
@@ -118,13 +122,19 @@ import Network.DatagramServer.Mainline | |||
118 | import Data.Maybe | 122 | import Data.Maybe |
119 | 123 | ||
120 | import Data.Torrent (InfoHash) | 124 | import Data.Torrent (InfoHash) |
121 | import Network.BitTorrent.DHT.Token | 125 | import Network.BitTorrent.DHT.Token as T |
126 | import Network.BitTorrent.DHT.ContactInfo | ||
122 | #ifdef VERSION_bencoding | 127 | #ifdef VERSION_bencoding |
123 | import Network.DatagramServer () | 128 | import Network.DatagramServer () |
124 | #endif | 129 | #endif |
125 | import Network.DatagramServer.Types hiding (Query,Response) | 130 | import Network.DatagramServer.Types hiding (Query,Response) |
126 | import Network.DHT.Types | 131 | import Network.DHT.Types |
127 | import Network.DHT.Routing | 132 | import Network.DHT.Routing |
133 | import Data.Time | ||
134 | import Control.Concurrent.STM | ||
135 | import System.Random | ||
136 | import Data.Hashable | ||
137 | |||
128 | 138 | ||
129 | {----------------------------------------------------------------------- | 139 | {----------------------------------------------------------------------- |
130 | -- envelopes | 140 | -- envelopes |
@@ -472,6 +482,59 @@ bep42 addr (NodeId r) | |||
472 | where msk | BS.length ip == 4 = ip4mask | 482 | where msk | BS.length ip == 4 = ip4mask |
473 | | otherwise = ip6mask | 483 | | otherwise = ip6mask |
474 | 484 | ||
485 | {----------------------------------------------------------------------- | ||
486 | -- Tokens policy | ||
487 | -----------------------------------------------------------------------} | ||
488 | |||
489 | data SessionTokens = SessionTokens | ||
490 | { tokenMap :: !TokenMap | ||
491 | , lastUpdate :: !UTCTime | ||
492 | , maxInterval :: !NominalDiffTime | ||
493 | } | ||
494 | |||
495 | nullSessionTokens :: IO SessionTokens | ||
496 | nullSessionTokens = SessionTokens | ||
497 | <$> (tokens <$> randomIO) | ||
498 | <*> getCurrentTime | ||
499 | <*> pure defaultUpdateInterval | ||
500 | |||
501 | -- TODO invalidate *twice* if needed | ||
502 | invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens | ||
503 | invalidateTokens curTime ts @ SessionTokens {..} | ||
504 | | curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens | ||
505 | { tokenMap = update tokenMap | ||
506 | , lastUpdate = curTime | ||
507 | , maxInterval = maxInterval | ||
508 | } | ||
509 | | otherwise = ts | ||
510 | |||
511 | {----------------------------------------------------------------------- | ||
512 | -- Tokens | ||
513 | -----------------------------------------------------------------------} | ||
514 | |||
515 | tryUpdateSecret :: TVar SessionTokens -> IO () | ||
516 | tryUpdateSecret toks = do | ||
517 | curTime <- getCurrentTime | ||
518 | atomically $ modifyTVar' toks (invalidateTokens curTime) | ||
519 | |||
520 | grantToken :: Hashable a => TVar SessionTokens -> NodeAddr a -> IO Token | ||
521 | grantToken sessionTokens addr = do | ||
522 | tryUpdateSecret sessionTokens | ||
523 | toks <- readTVarIO sessionTokens | ||
524 | return $ T.lookup addr $ tokenMap toks | ||
525 | |||
526 | -- | Throws 'HandlerError' if the token is invalid or already | ||
527 | -- expired. See 'TokenMap' for details. | ||
528 | checkToken :: Hashable a => TVar SessionTokens -> NodeAddr a -> Token -> IO Bool | ||
529 | checkToken sessionTokens addr questionableToken = do | ||
530 | tryUpdateSecret sessionTokens | ||
531 | toks <- readTVarIO sessionTokens | ||
532 | return $ T.member addr questionableToken (tokenMap toks) | ||
533 | |||
534 | |||
535 | -------------------------- | ||
536 | |||
537 | |||
475 | instance Kademlia KMessageOf where | 538 | instance Kademlia KMessageOf where |
476 | data Ping KMessageOf = Ping | 539 | data Ping KMessageOf = Ping |
477 | deriving (Show, Eq, Typeable) | 540 | deriving (Show, Eq, Typeable) |
@@ -479,10 +542,17 @@ instance Kademlia KMessageOf where | |||
479 | deriving (Show, Eq, Typeable) | 542 | deriving (Show, Eq, Typeable) |
480 | newtype NodeFound KMessageOf ip = NodeFound [NodeInfo KMessageOf ip ()] | 543 | newtype NodeFound KMessageOf ip = NodeFound [NodeInfo KMessageOf ip ()] |
481 | deriving (Show, Eq, Typeable) | 544 | deriving (Show, Eq, Typeable) |
545 | data DHTData KMessageOf ip = TorrentData | ||
546 | { contactInfo :: !(TVar (PeerStore ip )) -- ^ published by other nodes; | ||
547 | , sessionTokens :: !(TVar SessionTokens ) -- ^ query session IDs. | ||
548 | } | ||
549 | |||
482 | pingMessage _ = Ping | 550 | pingMessage _ = Ping |
483 | pongMessage _ = Ping | 551 | pongMessage _ = Ping |
484 | findNodeMessage _ k = FindNode (toNodeId k) | 552 | findNodeMessage _ k = FindNode (toNodeId k) |
553 | findWho (FindNode nid) = nid | ||
485 | foundNodes (NodeFound ns) = ns | 554 | foundNodes (NodeFound ns) = ns |
555 | foundNodesMessage ns = NodeFound ns | ||
486 | 556 | ||
487 | dhtAdjustID _ fallback ip0 arrival | 557 | dhtAdjustID _ fallback ip0 arrival |
488 | = fromMaybe fallback $ do | 558 | = fromMaybe fallback $ do |
@@ -494,3 +564,7 @@ instance Kademlia KMessageOf where | |||
494 | 564 | ||
495 | namePing _ = "ping" | 565 | namePing _ = "ping" |
496 | nameFindNodes _ = "find-nodes" | 566 | nameFindNodes _ = "find-nodes" |
567 | |||
568 | initializeDHTData = TorrentData | ||
569 | <$> newTVarIO def | ||
570 | <*> (newTVarIO =<< nullSessionTokens) | ||
diff --git a/src/Network/DHT/Types.hs b/src/Network/DHT/Types.hs index 79f9e1d3..31ae5948 100644 --- a/src/Network/DHT/Types.hs +++ b/src/Network/DHT/Types.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | {-# LANGUAGE ScopedTypeVariables #-} | 2 | {-# LANGUAGE ScopedTypeVariables #-} |
3 | {-# LANGUAGE StandaloneDeriving #-} | 3 | {-# LANGUAGE StandaloneDeriving #-} |
4 | {-# LANGUAGE FlexibleContexts #-} | 4 | {-# LANGUAGE FlexibleContexts #-} |
5 | {-# LANGUAGE DeriveGeneric #-} | ||
5 | module Network.DHT.Types | 6 | module Network.DHT.Types |
6 | ( module Network.DHT.Types | 7 | ( module Network.DHT.Types |
7 | , TableKey | 8 | , TableKey |
@@ -12,6 +13,7 @@ import Network.Socket (SockAddr) | |||
12 | import Network.DatagramServer.Types | 13 | import Network.DatagramServer.Types |
13 | import Network.DHT.Routing | 14 | import Network.DHT.Routing |
14 | import Data.Typeable | 15 | import Data.Typeable |
16 | import GHC.Generics | ||
15 | 17 | ||
16 | data TableParameters msg ip u = TableParameters | 18 | data TableParameters msg ip u = TableParameters |
17 | { maxBuckets :: Int | 19 | { maxBuckets :: Int |
@@ -27,7 +29,7 @@ data Query dht a = Query | |||
27 | { queringNodeId :: NodeId dht -- ^ node id of /quering/ node; | 29 | { queringNodeId :: NodeId dht -- ^ node id of /quering/ node; |
28 | , queryIsReadOnly :: Bool -- ^ node is read-only as per BEP 43 | 30 | , queryIsReadOnly :: Bool -- ^ node is read-only as per BEP 43 |
29 | , queryParams :: a -- ^ query parameters. | 31 | , queryParams :: a -- ^ query parameters. |
30 | } deriving (Typeable) | 32 | } deriving (Typeable,Generic) |
31 | 33 | ||
32 | deriving instance (Eq (NodeId dht), Eq a ) => Eq (Query dht a) | 34 | deriving instance (Eq (NodeId dht), Eq a ) => Eq (Query dht a) |
33 | deriving instance (Show (NodeId dht), Show a ) => Show (Query dht a) | 35 | deriving instance (Show (NodeId dht), Show a ) => Show (Query dht a) |
@@ -37,7 +39,7 @@ deriving instance (Show (NodeId dht), Show a ) => Show (Query dht a) | |||
37 | data Response dht a = Response | 39 | data Response dht a = Response |
38 | { queredNodeId :: NodeId dht -- ^ node id of /quered/ node; | 40 | { queredNodeId :: NodeId dht -- ^ node id of /quered/ node; |
39 | , responseVals :: a -- ^ query result. | 41 | , responseVals :: a -- ^ query result. |
40 | } deriving (Typeable) | 42 | } deriving (Typeable,Generic) |
41 | 43 | ||
42 | deriving instance (Eq (NodeId dht), Eq a ) => Eq (Response dht a) | 44 | deriving instance (Eq (NodeId dht), Eq a ) => Eq (Response dht a) |
43 | deriving instance (Show (NodeId dht), Show a ) => Show (Response dht a) | 45 | deriving instance (Show (NodeId dht), Show a ) => Show (Response dht a) |
@@ -51,6 +53,7 @@ class Kademlia dht where | |||
51 | -- given its ID. | 53 | -- given its ID. |
52 | data FindNode dht ip | 54 | data FindNode dht ip |
53 | data NodeFound dht ip | 55 | data NodeFound dht ip |
56 | data DHTData dht ip | ||
54 | pingMessage :: Proxy dht -> Ping dht | 57 | pingMessage :: Proxy dht -> Ping dht |
55 | pongMessage :: Proxy dht -> Ping dht | 58 | pongMessage :: Proxy dht -> Ping dht |
56 | findNodeMessage :: TableKey dht k => Proxy dht -> k -> FindNode dht ip | 59 | findNodeMessage :: TableKey dht k => Proxy dht -> k -> FindNode dht ip |
@@ -60,3 +63,4 @@ class Kademlia dht where | |||
60 | dhtAdjustID :: Address ip => Proxy dht -> NodeId dht -> SockAddr -> Event dht ip u -> NodeId dht | 63 | dhtAdjustID :: Address ip => Proxy dht -> NodeId dht -> SockAddr -> Event dht ip u -> NodeId dht |
61 | namePing :: Proxy dht -> QueryMethod dht | 64 | namePing :: Proxy dht -> QueryMethod dht |
62 | nameFindNodes :: Proxy dht -> QueryMethod dht | 65 | nameFindNodes :: Proxy dht -> QueryMethod dht |
66 | initializeDHTData :: IO (DHTData dht ip) | ||
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index 3a2bd020..d0eb136a 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs | |||
@@ -89,11 +89,11 @@ showsMethod (Method name) = | |||
89 | -- @ | 89 | -- @ |
90 | -- | 90 | -- |
91 | class ( Typeable req, Typeable resp | 91 | class ( Typeable req, Typeable resp |
92 | #ifdef VERSION_bencoding | 92 | -- #ifdef VERSION_bencoding |
93 | , BEncode req, BEncode resp | 93 | -- , BEncode req, BEncode resp |
94 | #else | 94 | -- #else |
95 | , Serialize req, Serialize resp | 95 | -- , Serialize req, Serialize resp |
96 | #endif | 96 | -- #endif |
97 | ) | 97 | ) |
98 | => KRPC req resp | req -> resp, resp -> req where | 98 | => KRPC req resp | req -> resp, resp -> req where |
99 | 99 | ||