Add tests for http tracker protocol

5 files changed, 38 insertions, 29 deletions

diff --git a/bittorrent.cabal b/bittorrent.cabal
index 7177a899..51da7d4f 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -170,6 +170,9 @@ test-suite spec
                      , network
                      , text
 
+                     , mtl
+                     , resourcet
+
                      , hspec
                      , QuickCheck
                      , quickcheck-instances
diff --git a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
index 81208590..2006ae70 100644
--- a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
@@ -51,8 +51,15 @@ data Connection = Connection
 putConnection :: Connection -> IO ()
 putConnection = undefined
 
-connect :: URI -> IO Connection
-connect = undefined
+-- TODO share manager between several threads
+connect :: URI -> ResourceT IO Connection
+connect uri = do
+  (_, m) <- allocate (newManager def) closeManager
+  return Connection
+    { announceURI = uri
+    , manager     = m
+    , connProxy   = Nothing
+    }
 
 setSimpleQuery :: SimpleQuery -> Request m -> Request m
 setSimpleQuery q r = r
diff --git a/src/Network/BitTorrent/Tracker/RPC/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs
index e91d223e..26868ead 100644
--- a/src/Network/BitTorrent/Tracker/RPC/Message.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/Message.hs
@@ -475,9 +475,6 @@ parseFailureMessage e = BS.concat $ case e of
 parseFailureStatus :: ParamParseFailure -> Status
 parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage
 
---type AnnounceResponse = Either Status AnnounceInfo -- TODO
---type TrackerResponse = () -- TODO
-
 {-----------------------------------------------------------------------
   Scrape message
 -----------------------------------------------------------------------}
diff --git a/tests/Network/BitTorrent/Tracker/RPC/MessageSpec.hs b/tests/Network/BitTorrent/Tracker/RPC/MessageSpec.hs
index 8e95286a..f8cf052a 100644
--- a/tests/Network/BitTorrent/Tracker/RPC/MessageSpec.hs
+++ b/tests/Network/BitTorrent/Tracker/RPC/MessageSpec.hs
@@ -1,7 +1,14 @@
+{-# LANGUAGE RecordWildCards  #-}
 {-# OPTIONS -fno-warn-orphans #-}
-module Network.BitTorrent.Tracker.RPC.MessageSpec (spec) where
+module Network.BitTorrent.Tracker.RPC.MessageSpec
+       ( spec
+       , validateInfo
+       , arbitrarySample
+       ) where
 
 import Control.Applicative
+import Data.List as L
+import Data.Maybe
 import Data.Word
 import Network
 import Test.Hspec
@@ -11,7 +18,8 @@ import Data.Torrent.InfoHashSpec ()
 import Data.Torrent.ProgressSpec ()
 import Network.BitTorrent.Core.PeerIdSpec ()
 
-import Network.BitTorrent.Tracker.RPC.Message
+import Network.BitTorrent.Tracker.RPC.Message as Message
+import Network.BitTorrent.Core.PeerAddr
 
 
 --prop_bencode :: Eq a => BEncode a => a -> Bool
@@ -31,6 +39,21 @@ instance Arbitrary AnnounceQuery where
     <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
     <*> arbitrary <*> arbitrary <*> arbitrary
 
+validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation
+validateInfo _ Message.Failure {..} = error "validateInfo: failure"
+validateInfo AnnounceQuery {..}  AnnounceInfo {..} = do
+    respComplete    `shouldSatisfy` isJust
+    respIncomplete  `shouldSatisfy` isJust
+    respMinInterval `shouldSatisfy` isNothing
+    respWarning     `shouldSatisfy` isNothing
+    peerList `shouldSatisfy` L.all (isNothing . peerID)
+    fromJust respComplete + fromJust respIncomplete `shouldBe` L.length peerList
+  where
+    peerList = getPeerList respPeers
+
+arbitrarySample :: Arbitrary a => IO a
+arbitrarySample = L.head <$> sample' arbitrary
+
 spec :: Spec
 spec = do
   describe "Announce" $ do
diff --git a/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
index 73cf07f3..4954ee25 100644
--- a/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
+++ b/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
@@ -1,44 +1,23 @@
 {-# LANGUAGE RecordWildCards #-}
 module Network.BitTorrent.Tracker.RPC.UDPSpec (spec) where
 
-import Control.Applicative
 import Control.Monad
 import Data.Default
 import Data.List as L
 import Data.Maybe
 import Network.URI
 import Test.Hspec
-import Test.QuickCheck
 
-import Network.BitTorrent.Core.PeerAddr
-import Network.BitTorrent.Tracker.RPC.Message as Message
+import Network.BitTorrent.Tracker.RPC.MessageSpec hiding (spec)
 import Network.BitTorrent.Tracker.RPC.UDP
-import Network.BitTorrent.Tracker.RPC.MessageSpec ()
 
 
-arbitrarySample :: Arbitrary a => IO a
-arbitrarySample = L.head <$> sample' arbitrary
-
 trackerURIs :: [URI]
 trackerURIs =
   [ fromJust $ parseURI "udp://tracker.openbittorrent.com:80/announce"
   , fromJust $ parseURI "udp://tracker.publicbt.com:80/announce"
   ]
 
--- relation with query: peer id, numwant
-validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation
-validateInfo _ Message.Failure {..} = error "validateInfo: failure"
-validateInfo AnnounceQuery {..}  AnnounceInfo {..} = do
-    respComplete    `shouldSatisfy` isJust
-    respIncomplete  `shouldSatisfy` isJust
-    respMinInterval `shouldSatisfy` isNothing
-    respWarning     `shouldSatisfy` isNothing
-    peerList `shouldSatisfy` L.all (isNothing . peerID)
-    fromJust respComplete + fromJust respIncomplete `shouldBe` L.length peerList
-  where
-    peerList = getPeerList respPeers
-
-
 spec :: Spec
 spec = do
   forM_ trackerURIs $ \ uri ->