summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Tracker
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Tracker')
-rw-r--r--src/Network/BitTorrent/Tracker/Protocol.hs30
1 files changed, 12 insertions, 18 deletions
diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs
index d61a269c..e844f8b8 100644
--- a/src/Network/BitTorrent/Tracker/Protocol.hs
+++ b/src/Network/BitTorrent/Tracker/Protocol.hs
@@ -73,11 +73,8 @@ data Event = Started
73-- the torrent. The most important, requests are used by the tracker 73-- the torrent. The most important, requests are used by the tracker
74-- to keep track lists of active peer for a particular torrent. 74-- to keep track lists of active peer for a particular torrent.
75-- 75--
76data TRequest = TRequest { -- TODO peer here -- TODO detach announce 76data TRequest = TRequest { -- TODO peer here
77 reqAnnounce :: !URI 77 reqInfoHash :: !InfoHash
78 -- ^ Announce url of the torrent usually obtained from 'Torrent'.
79
80 , reqInfoHash :: !InfoHash
81 -- ^ Hash of info part of the torrent usually obtained from 78 -- ^ Hash of info part of the torrent usually obtained from
82 -- 'Torrent'. 79 -- 'Torrent'.
83 80
@@ -162,7 +159,6 @@ instance BEncodable TResponse where
162 <*> d >--? "complete" 159 <*> d >--? "complete"
163 <*> d >--? "incomplete" 160 <*> d >--? "incomplete"
164 <*> getPeers (M.lookup "peers" d) 161 <*> getPeers (M.lookup "peers" d)
165
166 where 162 where
167 getPeers :: Maybe BEncode -> Result [PeerAddr] 163 getPeers :: Maybe BEncode -> Result [PeerAddr]
168 getPeers (Just (BList l)) = fromBEncode (BList l) 164 getPeers (Just (BList l)) = fromBEncode (BList l)
@@ -196,9 +192,9 @@ instance URLEncode TRequest where
196 ] 192 ]
197 where s :: String -> String; s = id; {-# INLINE s #-} 193 where s :: String -> String; s = id; {-# INLINE s #-}
198 194
199encodeRequest :: TRequest -> URI 195encodeRequest :: URI -> TRequest -> URI
200encodeRequest req = URL.urlEncode req 196encodeRequest announce req = URL.urlEncode req
201 `addToURI` reqAnnounce req 197 `addToURI` announce
202 `addHashToURI` reqInfoHash req 198 `addHashToURI` reqInfoHash req
203 199
204{----------------------------------------------------------------------- 200{-----------------------------------------------------------------------
@@ -259,9 +255,7 @@ instance Serialize TRequest where
259 port <- get 255 port <- get
260 256
261 return $ TRequest { 257 return $ TRequest {
262 -- TODO remove reqAnnounce field from TRequest 258 reqInfoHash = ih
263 reqAnnounce = error "tracker request decode"
264 , reqInfoHash = ih
265 , reqPeerId = pid 259 , reqPeerId = pid
266 , reqPort = port 260 , reqPort = port
267 , reqUploaded = fromIntegral up 261 , reqUploaded = fromIntegral up
@@ -322,9 +316,9 @@ mkHTTPRequest uri = Request uri GET [] ""
322-- announce list. This function throws 'IOException' if it couldn't 316-- announce list. This function throws 'IOException' if it couldn't
323-- send request or receive response or decode response. 317-- send request or receive response or decode response.
324-- 318--
325askTracker :: TRequest -> IO TResponse 319askTracker :: URI -> TRequest -> IO TResponse
326askTracker req = do 320askTracker announce req = do
327 let r = mkHTTPRequest (encodeRequest req) 321 let r = mkHTTPRequest (encodeRequest announce req)
328 322
329 rawResp <- simpleHTTP r 323 rawResp <- simpleHTTP r
330 respBody <- getResponseBody rawResp 324 respBody <- getResponseBody rawResp
@@ -339,7 +333,7 @@ askTracker req = do
339 333
340-- | The same as the 'askTracker' but ignore response. Used in 334-- | The same as the 'askTracker' but ignore response. Used in
341-- conjunction with 'Stopped'. 335-- conjunction with 'Stopped'.
342leaveTracker :: TRequest -> IO () 336leaveTracker :: URI -> TRequest -> IO ()
343leaveTracker req = do 337leaveTracker announce req = do
344 let r = mkHTTPRequest (encodeRequest req) 338 let r = mkHTTPRequest (encodeRequest announce req)
345 void $ simpleHTTP r >>= getResponseBody 339 void $ simpleHTTP r >>= getResponseBody