~ Fix bugs in tracker communication.

* Fix tracker interval timeout: threadDelay use argument is microseconds
  while tracker response is seconds.

* Fix stopped request: tracker might response with empty body.

2 files changed, 24 insertions, 6 deletions

diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
index e1f9ff76..6bf6de4b 100644
--- a/src/Network/BitTorrent/Tracker.hs
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -164,8 +164,14 @@ getPeerList = getChanContents . sePeers
 getProgress :: TSession -> IO Progress
 getProgress = readTVarIO . seProgress
 
+sec :: Int
+sec = 1000 * 1000
+
 waitInterval :: TSession -> IO ()
-waitInterval = readIORef . seInterval >=> threadDelay
+waitInterval se @ TSession {..} = do
+  delay <- readIORef seInterval
+  print delay
+  threadDelay (delay * sec)
 
 withTracker :: Progress -> TConnection -> (TSession -> IO a) -> IO a
 withTracker initProgress conn action = bracket start end (action . fst)
@@ -174,7 +180,7 @@ withTracker initProgress conn action = bracket start end (action . fst)
       resp <- askTracker (startedReq conn initProgress)
       print resp
       se   <- newSession initProgress (respInterval resp) (respPeers resp)
-      tid  <- forkIO (syncSession se)
+      tid  <- forkIO (return ()) -- (syncSession se)
       return (se, tid)
 
     syncSession se @ TSession {..} = forever $ do
@@ -197,7 +203,8 @@ withTracker initProgress conn action = bracket start end (action . fst)
     end (se, tid) = do
       killThread tid
       pr <- getProgress se
-      askTracker $ stoppedReq conn pr
+      print  "stopping"
+      leaveTracker $ stoppedReq conn pr
 
 
 
diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs
index 13127e7c..efc709e2 100644
--- a/src/Network/BitTorrent/Tracker/Protocol.hs
+++ b/src/Network/BitTorrent/Tracker/Protocol.hs
@@ -22,7 +22,7 @@
 -- TODO: add "compact" field to TRequest
 module Network.BitTorrent.Tracker.Protocol
        ( Event(..), TRequest(..), TResponse(..)
-       , askTracker
+       , askTracker, leaveTracker
 
          -- * Defaults
        , defaultPorts, defaultNumWant
@@ -217,6 +217,9 @@ defaultPorts = [6881..6889]
 defaultNumWant :: Int
 defaultNumWant = 25
 
+mkHTTPRequest :: URI -> Request ByteString
+mkHTTPRequest uri = Request uri GET [] ""
+
 -- | Send request and receive response from the tracker specified in
 -- announce list. This function throws 'IOException' if it couldn't
 -- send request or receive response or decode response.
@@ -230,11 +233,19 @@ askTracker req = do
     print $ respBody
     checkResult $ decoded respBody
   where
-    mkHTTPRequest :: URI -> Request ByteString
-    mkHTTPRequest uri = Request uri GET [] ""
 
     checkResult (Left err)
       = ioError $ userError $ err ++ " in tracker response"
     checkResult (Right (Failure err))
       = ioError $ userError $ show err ++ " in tracker response"
     checkResult (Right resp)          = return resp
+
+-- | The same as the 'askTracker' but ignore response. Used in
+-- conjunction with 'Stopped'.
+leaveTracker :: TRequest -> IO ()
+leaveTracker req = do
+  let r = mkHTTPRequest (encodeRequest req)
+
+  rawResp  <- simpleHTTP r
+  respBody <- getResponseBody rawResp
+  return ()