diff options
Diffstat (limited to 'src/Network/BitTorrent/Tracker/RPC/UDP.hs')
-rw-r--r-- | src/Network/BitTorrent/Tracker/RPC/UDP.hs | 147 |
1 files changed, 0 insertions, 147 deletions
diff --git a/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs index 0c9c3367..35e8b7b6 100644 --- a/src/Network/BitTorrent/Tracker/RPC/UDP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs | |||
@@ -15,7 +15,6 @@ | |||
15 | {-# LANGUAGE FlexibleInstances #-} | 15 | {-# LANGUAGE FlexibleInstances #-} |
16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | 16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} |
17 | {-# LANGUAGE DeriveDataTypeable #-} | 17 | {-# LANGUAGE DeriveDataTypeable #-} |
18 | {-# LANGUAGE TypeFamilies #-} | ||
19 | module Network.BitTorrent.Tracker.RPC.UDP | 18 | module Network.BitTorrent.Tracker.RPC.UDP |
20 | ( -- * Manager | 19 | ( -- * Manager |
21 | Options (..) | 20 | Options (..) |
@@ -52,7 +51,6 @@ import Text.Read (readMaybe) | |||
52 | import Network.Socket hiding (Connected, connect, listen) | 51 | import Network.Socket hiding (Connected, connect, listen) |
53 | import Network.Socket.ByteString as BS | 52 | import Network.Socket.ByteString as BS |
54 | import Network.URI | 53 | import Network.URI |
55 | import System.Entropy | ||
56 | import System.Timeout | 54 | import System.Timeout |
57 | import Numeric | 55 | import Numeric |
58 | 56 | ||
@@ -259,151 +257,6 @@ getTrackerAddr _ uri | |||
259 | | otherwise = throwIO (UnrecognizedScheme (uriScheme uri)) | 257 | | otherwise = throwIO (UnrecognizedScheme (uriScheme uri)) |
260 | 258 | ||
261 | {----------------------------------------------------------------------- | 259 | {----------------------------------------------------------------------- |
262 | Tokens | ||
263 | -----------------------------------------------------------------------} | ||
264 | |||
265 | genToken :: IO Word64 | ||
266 | genToken = do | ||
267 | bs <- getEntropy 8 | ||
268 | either err return $ runGet getWord64be bs | ||
269 | where | ||
270 | err = error "genToken: impossible happen" | ||
271 | |||
272 | -- | Connection Id is used for entire tracker session. | ||
273 | newtype ConnectionId = ConnectionId Word64 | ||
274 | deriving (Eq, Serialize) | ||
275 | |||
276 | instance Show ConnectionId where | ||
277 | showsPrec _ (ConnectionId cid) = showString "0x" <> showHex cid | ||
278 | |||
279 | initialConnectionId :: ConnectionId | ||
280 | initialConnectionId = ConnectionId 0x41727101980 | ||
281 | |||
282 | -- | Transaction Id is used within a UDP RPC. | ||
283 | newtype TransactionId = TransactionId Word32 | ||
284 | deriving (Eq, Ord, Enum, Bounded, Serialize) | ||
285 | |||
286 | instance Show TransactionId where | ||
287 | showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid | ||
288 | |||
289 | genTransactionId :: IO TransactionId | ||
290 | genTransactionId = (TransactionId . fromIntegral) <$> genToken | ||
291 | |||
292 | {----------------------------------------------------------------------- | ||
293 | Transactions | ||
294 | -----------------------------------------------------------------------} | ||
295 | |||
296 | data Request = Connect | ||
297 | | Announce AnnounceQuery | ||
298 | | Scrape ScrapeQuery | ||
299 | deriving Show | ||
300 | |||
301 | data Response = Connected ConnectionId | ||
302 | | Announced AnnounceInfo | ||
303 | | Scraped [ScrapeEntry] | ||
304 | | Failed Text | ||
305 | deriving Show | ||
306 | |||
307 | responseName :: Response -> String | ||
308 | responseName (Connected _) = "connected" | ||
309 | responseName (Announced _) = "announced" | ||
310 | responseName (Scraped _) = "scraped" | ||
311 | responseName (Failed _) = "failed" | ||
312 | |||
313 | data family Transaction a | ||
314 | data instance Transaction Request = TransactionQ | ||
315 | { connIdQ :: {-# UNPACK #-} !ConnectionId | ||
316 | , transIdQ :: {-# UNPACK #-} !TransactionId | ||
317 | , request :: !Request | ||
318 | } deriving Show | ||
319 | data instance Transaction Response = TransactionR | ||
320 | { transIdR :: {-# UNPACK #-} !TransactionId | ||
321 | , response :: !Response | ||
322 | } deriving Show | ||
323 | |||
324 | -- TODO newtype | ||
325 | newtype MessageId = MessageId Word32 | ||
326 | deriving (Show, Eq, Num, Serialize) | ||
327 | |||
328 | connectId, announceId, scrapeId, errorId :: MessageId | ||
329 | connectId = 0 | ||
330 | announceId = 1 | ||
331 | scrapeId = 2 | ||
332 | errorId = 3 | ||
333 | |||
334 | instance Serialize (Transaction Request) where | ||
335 | put TransactionQ {..} = do | ||
336 | case request of | ||
337 | Connect -> do | ||
338 | put initialConnectionId | ||
339 | put connectId | ||
340 | put transIdQ | ||
341 | |||
342 | Announce ann -> do | ||
343 | put connIdQ | ||
344 | put announceId | ||
345 | put transIdQ | ||
346 | put ann | ||
347 | |||
348 | Scrape hashes -> do | ||
349 | put connIdQ | ||
350 | put scrapeId | ||
351 | put transIdQ | ||
352 | forM_ hashes put | ||
353 | |||
354 | get = do | ||
355 | cid <- get | ||
356 | mid <- get | ||
357 | TransactionQ cid <$> get <*> getBody mid | ||
358 | where | ||
359 | getBody :: MessageId -> Get Request | ||
360 | getBody msgId | ||
361 | | msgId == connectId = pure Connect | ||
362 | | msgId == announceId = Announce <$> get | ||
363 | | msgId == scrapeId = Scrape <$> many get | ||
364 | | otherwise = fail errMsg | ||
365 | where | ||
366 | errMsg = "unknown request: " ++ show msgId | ||
367 | |||
368 | instance Serialize (Transaction Response) where | ||
369 | put TransactionR {..} = do | ||
370 | case response of | ||
371 | Connected conn -> do | ||
372 | put connectId | ||
373 | put transIdR | ||
374 | put conn | ||
375 | |||
376 | Announced info -> do | ||
377 | put announceId | ||
378 | put transIdR | ||
379 | put info | ||
380 | |||
381 | Scraped infos -> do | ||
382 | put scrapeId | ||
383 | put transIdR | ||
384 | forM_ infos put | ||
385 | |||
386 | Failed info -> do | ||
387 | put errorId | ||
388 | put transIdR | ||
389 | put (encodeUtf8 info) | ||
390 | |||
391 | |||
392 | get = do | ||
393 | mid <- get | ||
394 | TransactionR <$> get <*> getBody mid | ||
395 | where | ||
396 | getBody :: MessageId -> Get Response | ||
397 | getBody msgId | ||
398 | | msgId == connectId = Connected <$> get | ||
399 | | msgId == announceId = Announced <$> get | ||
400 | | msgId == scrapeId = Scraped <$> many get | ||
401 | | msgId == errorId = (Failed . decodeUtf8) <$> get | ||
402 | | otherwise = fail msg | ||
403 | where | ||
404 | msg = "unknown response: " ++ show msgId | ||
405 | |||
406 | {----------------------------------------------------------------------- | ||
407 | Connection | 260 | Connection |
408 | -----------------------------------------------------------------------} | 261 | -----------------------------------------------------------------------} |
409 | 262 | ||