diff options
-rw-r--r-- | bittorrent.cabal | 1 | ||||
-rw-r--r-- | src/Network/BitTorrent/Tracker/RPC/Message.hs | 2 | ||||
-rw-r--r-- | src/Network/BitTorrent/Tracker/RPC/UDP.hs | 18 | ||||
-rw-r--r-- | tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs | 53 |
4 files changed, 62 insertions, 12 deletions
diff --git a/bittorrent.cabal b/bittorrent.cabal index 4d11b346..ebecaa26 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal | |||
@@ -162,6 +162,7 @@ test-suite spec | |||
162 | , filepath | 162 | , filepath |
163 | , time | 163 | , time |
164 | , convertible | 164 | , convertible |
165 | , data-default | ||
165 | 166 | ||
166 | , aeson | 167 | , aeson |
167 | , cereal | 168 | , cereal |
diff --git a/src/Network/BitTorrent/Tracker/RPC/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs index 18c1a4c7..a0691f37 100644 --- a/src/Network/BitTorrent/Tracker/RPC/Message.hs +++ b/src/Network/BitTorrent/Tracker/RPC/Message.hs | |||
@@ -482,6 +482,7 @@ parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage | |||
482 | 482 | ||
483 | type ScrapeQuery = [InfoHash] | 483 | type ScrapeQuery = [InfoHash] |
484 | 484 | ||
485 | -- TODO rename to ScrapeEntry | ||
485 | -- | Overall information about particular torrent. | 486 | -- | Overall information about particular torrent. |
486 | data ScrapeInfo = ScrapeInfo { | 487 | data ScrapeInfo = ScrapeInfo { |
487 | -- | Number of seeders - peers with the entire file. | 488 | -- | Number of seeders - peers with the entire file. |
@@ -501,6 +502,7 @@ data ScrapeInfo = ScrapeInfo { | |||
501 | $(deriveJSON (L.map toLower . L.dropWhile isLower) ''ScrapeInfo) | 502 | $(deriveJSON (L.map toLower . L.dropWhile isLower) ''ScrapeInfo) |
502 | 503 | ||
503 | -- TODO hash map | 504 | -- TODO hash map |
505 | -- TODO rename to ScrapeInfo | ||
504 | -- | Scrape info about a set of torrents. | 506 | -- | Scrape info about a set of torrents. |
505 | type Scrape = Map InfoHash ScrapeInfo | 507 | type Scrape = Map InfoHash ScrapeInfo |
506 | 508 | ||
diff --git a/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs index beff6b4f..0336db8d 100644 --- a/src/Network/BitTorrent/Tracker/RPC/UDP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs | |||
@@ -39,7 +39,7 @@ import Data.Text.Encoding | |||
39 | import Data.Time | 39 | import Data.Time |
40 | import Data.Word | 40 | import Data.Word |
41 | import Text.Read (readMaybe) | 41 | import Text.Read (readMaybe) |
42 | import Network.Socket hiding (Connected) | 42 | import Network.Socket hiding (Connected, connect) |
43 | import Network.Socket.ByteString as BS | 43 | import Network.Socket.ByteString as BS |
44 | import Network.URI | 44 | import Network.URI |
45 | import System.Entropy | 45 | import System.Entropy |
@@ -290,8 +290,8 @@ connectUDP tracker = do | |||
290 | Failed msg -> throwIO $ userError $ T.unpack msg | 290 | Failed msg -> throwIO $ userError $ T.unpack msg |
291 | _ -> throwIO $ userError "message type mismatch" | 291 | _ -> throwIO $ userError "message type mismatch" |
292 | 292 | ||
293 | initialTracker :: URI -> IO UDPTracker | 293 | connect :: URI -> IO UDPTracker |
294 | initialTracker uri = do | 294 | connect uri = do |
295 | tracker <- UDPTracker uri <$> (newIORef =<< initialConnection) | 295 | tracker <- UDPTracker uri <$> (newIORef =<< initialConnection) |
296 | connId <- connectUDP tracker | 296 | connId <- connectUDP tracker |
297 | updateConnection connId tracker | 297 | updateConnection connId tracker |
@@ -305,20 +305,20 @@ freshConnection tracker @ UDPTracker {..} = do | |||
305 | connId <- connectUDP tracker | 305 | connId <- connectUDP tracker |
306 | updateConnection connId tracker | 306 | updateConnection connId tracker |
307 | 307 | ||
308 | announce :: UDPTracker -> AnnounceQuery -> IO AnnounceInfo | 308 | announce :: AnnounceQuery -> UDPTracker -> IO AnnounceInfo |
309 | announce tracker ann = do | 309 | announce ann tracker = do |
310 | freshConnection tracker | 310 | freshConnection tracker |
311 | resp <- transaction tracker (Announce ann) | 311 | resp <- transaction tracker (Announce ann) |
312 | case resp of | 312 | case resp of |
313 | Announced info -> return info | 313 | Announced info -> return info |
314 | _ -> fail "announce: response type mismatch" | 314 | _ -> fail "announce: response type mismatch" |
315 | 315 | ||
316 | scrape :: UDPTracker -> ScrapeQuery -> IO Scrape | 316 | scrape :: ScrapeQuery -> UDPTracker -> IO Scrape |
317 | scrape tracker scr = do | 317 | scrape ihs tracker = do |
318 | freshConnection tracker | 318 | freshConnection tracker |
319 | resp <- transaction tracker (Scrape scr) | 319 | resp <- transaction tracker (Scrape ihs) |
320 | case resp of | 320 | case resp of |
321 | Scraped info -> return $ M.fromList $ L.zip scr info | 321 | Scraped info -> return $ M.fromList $ L.zip ihs info |
322 | _ -> fail "scrape: response type mismatch" | 322 | _ -> fail "scrape: response type mismatch" |
323 | 323 | ||
324 | {----------------------------------------------------------------------- | 324 | {----------------------------------------------------------------------- |
diff --git a/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs index 4cbaa09d..1a893011 100644 --- a/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs +++ b/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs | |||
@@ -1,7 +1,54 @@ | |||
1 | {-# LANGUAGE RecordWildCards #-} | ||
1 | module Network.BitTorrent.Tracker.RPC.UDPSpec (spec) where | 2 | module Network.BitTorrent.Tracker.RPC.UDPSpec (spec) where |
3 | |||
4 | import Control.Applicative | ||
5 | import Control.Monad | ||
6 | import Data.Default | ||
7 | import Data.List as L | ||
8 | import Data.Maybe | ||
9 | import Network.URI | ||
2 | import Test.Hspec | 10 | import Test.Hspec |
11 | import Test.QuickCheck | ||
12 | |||
13 | import Network.BitTorrent.Core.PeerAddr | ||
14 | import Network.BitTorrent.Tracker.RPC.Message | ||
15 | import Network.BitTorrent.Tracker.RPC.UDP | ||
16 | import Network.BitTorrent.Tracker.RPC.MessageSpec () | ||
17 | |||
18 | |||
19 | arbitrarySample :: Arbitrary a => IO a | ||
20 | arbitrarySample = L.head <$> sample' arbitrary | ||
21 | |||
22 | trackerURIs :: [URI] | ||
23 | trackerURIs = | ||
24 | [ fromJust $ parseURI "udp://tracker.openbittorrent.com:80/announce" | ||
25 | , fromJust $ parseURI "udp://tracker.publicbt.com:80/announce" | ||
26 | ] | ||
27 | |||
28 | -- relation with query: peer id, numwant | ||
29 | validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation | ||
30 | validateInfo AnnounceQuery {..} AnnounceInfo {..} = do | ||
31 | respComplete `shouldSatisfy` isJust | ||
32 | respIncomplete `shouldSatisfy` isJust | ||
33 | respMinInterval `shouldSatisfy` isNothing | ||
34 | respWarning `shouldSatisfy` isNothing | ||
35 | peerList `shouldSatisfy` L.all (isNothing . peerID) | ||
36 | fromJust respComplete + fromJust respIncomplete `shouldBe` L.length peerList | ||
37 | where | ||
38 | peerList = getPeerList respPeers | ||
39 | |||
3 | 40 | ||
4 | spec :: Spec | 41 | spec :: Spec |
5 | spec = | 42 | spec = do |
6 | describe "UDP tracker client RPC" $ do | 43 | forM_ trackerURIs $ \ uri -> |
7 | return () \ No newline at end of file | 44 | context (show uri) $ do |
45 | describe "announce" $ do | ||
46 | it "have valid response" $ do | ||
47 | query <- arbitrarySample | ||
48 | connect uri >>= announce query >>= validateInfo query | ||
49 | |||
50 | describe "scrape" $ do | ||
51 | it "have valid response" $ do | ||
52 | xs <- connect uri >>= scrape [def] | ||
53 | return () | ||
54 | -- L.length xs `shouldSatisfy` (>= 1) | ||