summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Network/BitTorrent/Tracker.hs103
-rw-r--r--src/Network/BitTorrent/Tracker/HTTP.hs72
-rw-r--r--src/Network/BitTorrent/Tracker/Protocol.hs16
-rw-r--r--src/Network/BitTorrent/Tracker/UDP.hs9
4 files changed, 97 insertions, 103 deletions
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
index c707cedd..0501f428 100644
--- a/src/Network/BitTorrent/Tracker.hs
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -41,7 +41,7 @@ import Network.URI
41 41
42import Data.Torrent.Metainfo 42import Data.Torrent.Metainfo
43import Network.BitTorrent.Peer 43import Network.BitTorrent.Peer
44import Network.BitTorrent.Tracker.Protocol 44import Network.BitTorrent.Tracker.Protocol as Tracker
45import Network.BitTorrent.Tracker.HTTP 45import Network.BitTorrent.Tracker.HTTP
46 46
47{----------------------------------------------------------------------- 47{-----------------------------------------------------------------------
@@ -83,9 +83,8 @@ genericReq ses pr = AnnounceQuery {
83-- 'startedReq'. It includes necessary 'Started' event field. 83-- 'startedReq'. It includes necessary 'Started' event field.
84-- 84--
85startedReq :: TConnection -> Progress -> AnnounceQuery 85startedReq :: TConnection -> Progress -> AnnounceQuery
86startedReq ses pr = (genericReq ses pr) { 86startedReq ses pr = (genericReq ses pr)
87 reqIP = Nothing 87 { reqNumWant = Just defaultNumWant
88 , reqNumWant = Just defaultNumWant
89 , reqEvent = Just Started 88 , reqEvent = Just Started
90 } 89 }
91 90
@@ -94,9 +93,8 @@ startedReq ses pr = (genericReq ses pr) {
94-- so new peers could connect to the client. 93-- so new peers could connect to the client.
95-- 94--
96regularReq :: Int -> TConnection -> Progress -> AnnounceQuery 95regularReq :: Int -> TConnection -> Progress -> AnnounceQuery
97regularReq numWant ses pr = (genericReq ses pr) { 96regularReq numWant ses pr = (genericReq ses pr)
98 reqIP = Nothing 97 { reqNumWant = Just numWant
99 , reqNumWant = Just numWant
100 , reqEvent = Nothing 98 , reqEvent = Nothing
101 } 99 }
102 100
@@ -104,9 +102,8 @@ regularReq numWant ses pr = (genericReq ses pr) {
104-- gracefully. 102-- gracefully.
105-- 103--
106stoppedReq :: TConnection -> Progress -> AnnounceQuery 104stoppedReq :: TConnection -> Progress -> AnnounceQuery
107stoppedReq ses pr = (genericReq ses pr) { 105stoppedReq ses pr = (genericReq ses pr)
108 reqIP = Nothing 106 { reqNumWant = Nothing
109 , reqNumWant = Nothing
110 , reqEvent = Just Stopped 107 , reqEvent = Just Stopped
111 } 108 }
112 109
@@ -115,9 +112,8 @@ stoppedReq ses pr = (genericReq ses pr) {
115-- complete. 112-- complete.
116-- 113--
117completedReq :: TConnection -> Progress -> AnnounceQuery 114completedReq :: TConnection -> Progress -> AnnounceQuery
118completedReq ses pr = (genericReq ses pr) { 115completedReq ses pr = (genericReq ses pr)
119 reqIP = Nothing 116 { reqNumWant = Nothing
120 , reqNumWant = Nothing
121 , reqEvent = Just Completed 117 , reqEvent = Just Completed
122 } 118 }
123 119
@@ -153,6 +149,7 @@ data TSession = TSession {
153 seProgress :: TVar Progress 149 seProgress :: TVar Progress
154 , seInterval :: IORef TimeInterval 150 , seInterval :: IORef TimeInterval
155 , sePeers :: BoundedChan PeerAddr 151 , sePeers :: BoundedChan PeerAddr
152 , seTracker :: HTTPTracker
156 } 153 }
157 154
158type PeerCount = Int 155type PeerCount = Int
@@ -167,8 +164,9 @@ getProgress :: TSession -> IO Progress
167getProgress = readTVarIO . seProgress 164getProgress = readTVarIO . seProgress
168 165
169newSession :: PeerCount -> Progress -> TimeInterval -> [PeerAddr] 166newSession :: PeerCount -> Progress -> TimeInterval -> [PeerAddr]
167 -> HTTPTracker
170 -> IO TSession 168 -> IO TSession
171newSession chanSize pr i ps 169newSession chanSize pr i ps tr
172 | chanSize < 1 170 | chanSize < 1
173 = throwIO $ userError "size of chan should be more that 1" 171 = throwIO $ userError "size of chan should be more that 1"
174 172
@@ -183,6 +181,7 @@ newSession chanSize pr i ps
183 TSession <$> newTVarIO pr 181 TSession <$> newTVarIO pr
184 <*> newIORef i 182 <*> newIORef i
185 <*> pure chan 183 <*> pure chan
184 <*> pure tr
186 185
187waitInterval :: TSession -> IO () 186waitInterval :: TSession -> IO ()
188waitInterval TSession {..} = do 187waitInterval TSession {..} = do
@@ -191,39 +190,45 @@ waitInterval TSession {..} = do
191 where 190 where
192 sec = 1000 * 1000 :: Int 191 sec = 1000 * 1000 :: Int
193 192
193announceLoop :: IO (BoundedChan PeerAddr)
194announceLoop = undefined
195
196openSession :: Progress -> TConnection -> IO TSession
197openSession initProgress conn = do
198 t <- Tracker.connect (tconnAnnounce conn)
199 resp <- Tracker.announce t (startedReq conn initProgress)
200 newSession defaultChanSize initProgress
201 (respInterval resp) (respPeers resp) t
202
203closeSession :: TConnection -> TSession -> IO ()
204closeSession conn se @ TSession {..} = do
205 pr <- getProgress se
206 Tracker.announce seTracker (stoppedReq conn pr)
207 return ()
208
209syncSession :: TConnection -> TSession -> IO ()
210syncSession conn se @ TSession {..} = forever $ do
211 waitInterval se
212 pr <- getProgress se
213 resp <- tryJust isIOException $ do
214 Tracker.announce seTracker (regularReq defaultNumWant conn pr)
215 case resp of
216 Left _ -> return ()
217 Right (AnnounceInfo {..}) -> do
218 writeIORef seInterval respInterval
219
220 -- we rely on the fact that union on lists is not
221 -- commutative: this implements the heuristic "old peers
222 -- in head"
223 old <- BC.getChanContents sePeers
224 let combined = L.union old respPeers
225 BC.writeList2Chan sePeers combined
226 where
227 isIOException :: IOException -> Maybe IOException
228 isIOException = return
229
194withTracker :: Progress -> TConnection -> (TSession -> IO a) -> IO a 230withTracker :: Progress -> TConnection -> (TSession -> IO a) -> IO a
195withTracker initProgress conn action = bracket start end (action . fst) 231withTracker initProgress conn
196 where 232 = bracket
197 start = do 233 (openSession initProgress conn)
198 resp <- askTracker (tconnAnnounce conn) (startedReq conn initProgress) 234 (closeSession conn)
199 se <- newSession defaultChanSize initProgress
200 (respInterval resp) (respPeers resp)
201
202 tid <- forkIO (syncSession se)
203 return (se, tid)
204
205 syncSession se @ TSession {..} = forever $ do
206 waitInterval se
207 pr <- getProgress se
208 resp <- tryJust isIOException $ do
209 askTracker (tconnAnnounce conn) (regularReq defaultNumWant conn pr)
210 case resp of
211 Right (AnnounceInfo {..}) -> do
212 writeIORef seInterval respInterval
213
214 -- we rely on the fact that union on lists is not
215 -- commutative: this implements the heuristic "old peers
216 -- in head"
217 old <- BC.getChanContents sePeers
218 let combined = L.union old respPeers
219 BC.writeList2Chan sePeers combined
220
221 _ -> return ()
222 where
223 isIOException :: IOException -> Maybe IOException
224 isIOException = return
225
226 end (se, tid) = do
227 killThread tid
228 pr <- getProgress se
229 leaveTracker (tconnAnnounce conn) (stoppedReq conn pr)
diff --git a/src/Network/BitTorrent/Tracker/HTTP.hs b/src/Network/BitTorrent/Tracker/HTTP.hs
index 8d3a6412..ce517b34 100644
--- a/src/Network/BitTorrent/Tracker/HTTP.hs
+++ b/src/Network/BitTorrent/Tracker/HTTP.hs
@@ -14,17 +14,17 @@
14-- <https://wiki.theory.org/BitTorrentSpecification#Tracker_HTTP.2FHTTPS_Protocol> 14-- <https://wiki.theory.org/BitTorrentSpecification#Tracker_HTTP.2FHTTPS_Protocol>
15-- 15--
16module Network.BitTorrent.Tracker.HTTP 16module Network.BitTorrent.Tracker.HTTP
17 ( askTracker, leaveTracker 17 ( HTTPTracker
18 , scrapeURL, scrape, scrapeOne 18
19 -- * Extra
20 , scrapeURL
19 ) where 21 ) where
20 22
21import Control.Applicative 23import Control.Exception
22import Control.Monad
23import Data.BEncode 24import Data.BEncode
24import Data.ByteString as B 25import Data.ByteString as B
25import Data.ByteString.Char8 as BC 26import Data.ByteString.Char8 as BC
26import Data.List as L 27import Data.List as L
27import Data.Map as M
28import Data.Monoid 28import Data.Monoid
29import Data.URLEncoded as URL 29import Data.URLEncoded as URL
30import Network.URI 30import Network.URI
@@ -34,37 +34,34 @@ import Data.Torrent.Metainfo hiding (announce)
34import Network.BitTorrent.Tracker.Protocol 34import Network.BitTorrent.Tracker.Protocol
35 35
36 36
37data HTTPTracker = HTTPTracker URI 37data HTTPTracker = HTTPTracker
38 { announceURI :: URI
39 } deriving Show
38 40
39instance Tracker URI where 41instance Tracker HTTPTracker where
40 announce = askTracker 42 connect = return . HTTPTracker
41 scrape_ uri ihs = do 43 announce = announceHTTP
42 e <- scrape uri ihs 44 scrape = scrapeHTTP
43 case e of
44 Left str -> error str
45 Right si -> return si
46 45
47{----------------------------------------------------------------------- 46{-----------------------------------------------------------------------
48 Announce 47 Announce
49-----------------------------------------------------------------------} 48-----------------------------------------------------------------------}
50 49
51encodeRequest :: URI -> AnnounceQuery -> URI 50encodeRequest :: URI -> AnnounceQuery -> URI
52encodeRequest announce req = URL.urlEncode req 51encodeRequest announceURI req = URL.urlEncode req
53 `addToURI` announce 52 `addToURI` announceURI
54 `addHashToURI` reqInfoHash req 53 `addHashToURI` reqInfoHash req
55 54
56mkGET :: URI -> Request ByteString 55mkGET :: URI -> Request ByteString
57mkGET uri = Request uri GET [] "" 56mkGET uri = Request uri GET [] ""
58 57
59-- TODO rename to something like "announceBlahBlah"
60
61-- | Send request and receive response from the tracker specified in 58-- | Send request and receive response from the tracker specified in
62-- announce list. This function throws 'IOException' if it couldn't 59-- announce list. This function throws 'IOException' if it couldn't
63-- send request or receive response or decode response. 60-- send request or receive response or decode response.
64-- 61--
65askTracker :: URI -> AnnounceQuery -> IO AnnounceInfo 62announceHTTP :: HTTPTracker -> AnnounceQuery -> IO AnnounceInfo
66askTracker announce req = do 63announceHTTP HTTPTracker {..} req = do
67 let r = mkGET (encodeRequest announce req) 64 let r = mkGET (encodeRequest announceURI req)
68 65
69 rawResp <- simpleHTTP r 66 rawResp <- simpleHTTP r
70 respBody <- getResponseBody rawResp 67 respBody <- getResponseBody rawResp
@@ -76,13 +73,6 @@ askTracker announce req = do
76 = ioError $ userError $ show err ++ " in tracker response" 73 = ioError $ userError $ show err ++ " in tracker response"
77 checkResult (Right resp) = return resp 74 checkResult (Right resp) = return resp
78 75
79-- | The same as the 'askTracker' but ignore response. Used in
80-- conjunction with 'Stopped'.
81leaveTracker :: URI -> AnnounceQuery -> IO ()
82leaveTracker announce req = do
83 let r = mkGET (encodeRequest announce req)
84 void $ simpleHTTP r >>= getResponseBody
85
86{----------------------------------------------------------------------- 76{-----------------------------------------------------------------------
87 Scrape 77 Scrape
88-----------------------------------------------------------------------} 78-----------------------------------------------------------------------}
@@ -113,25 +103,15 @@ scrapeURL uri ihs = do
113-- all available torrents. 103-- all available torrents.
114-- Note that the 'URI' should be /announce/ URI, not /scrape/ URI. 104-- Note that the 'URI' should be /announce/ URI, not /scrape/ URI.
115-- 105--
116scrape :: URI -- ^ Announce 'URI'. 106scrapeHTTP :: HTTPTracker -- ^ Announce 'URI'.
117 -> [InfoHash] -- ^ Torrents to be scrapped. 107 -> [InfoHash] -- ^ Torrents to be scrapped.
118 -> IO (Result Scrape) -- ^ 'ScrapeInfo' for each torrent. 108 -> IO Scrape -- ^ 'ScrapeInfo' for each torrent.
119scrape announce ihs 109scrapeHTTP HTTPTracker {..} ihs
120 | Just uri<- scrapeURL announce ihs = do 110 | Just uri <- scrapeURL announceURI ihs = do
121 rawResp <- simpleHTTP (Request uri GET [] "") 111 rawResp <- simpleHTTP (Request uri GET [] "")
122 respBody <- getResponseBody rawResp 112 respBody <- getResponseBody rawResp
123 return (decoded (BC.pack respBody)) 113 case decoded (BC.pack respBody) of
114 Left e -> throwIO $ userError $ e ++ " in scrape response"
115 Right r -> return r
124 116
125 | otherwise = return (Left "Tracker do not support scraping") 117 | otherwise = throwIO $ userError "Tracker do not support scraping"
126
127-- | More particular version of 'scrape', just for one torrent.
128--
129scrapeOne :: URI -- ^ Announce 'URI'
130 -> InfoHash -- ^ Hash of the torrent info.
131 -> IO (Result ScrapeInfo) -- ^ 'ScrapeInfo' for the torrent.
132scrapeOne uri ih = extract <$> scrape uri [ih]
133 where
134 extract (Right m)
135 | Just s <- M.lookup ih m = Right s
136 | otherwise = Left "unable to find info hash in response dict"
137 extract (Left e) = Left e
diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs
index 3f264aed..965f3480 100644
--- a/src/Network/BitTorrent/Tracker/Protocol.hs
+++ b/src/Network/BitTorrent/Tracker/Protocol.hs
@@ -39,12 +39,13 @@ module Network.BitTorrent.Tracker.Protocol
39 39
40 -- * TODO 40 -- * TODO
41 , Tracker(..) 41 , Tracker(..)
42 , scrapeOne
42 ) 43 )
43 where 44 where
44 45
45import Control.Applicative 46import Control.Applicative
47import Control.Exception
46import Control.Monad 48import Control.Monad
47
48import Data.Aeson.TH 49import Data.Aeson.TH
49import Data.Char as Char 50import Data.Char as Char
50import Data.Map as M 51import Data.Map as M
@@ -58,12 +59,11 @@ import Data.Text.Encoding
58import Data.Serialize hiding (Result) 59import Data.Serialize hiding (Result)
59import Data.URLEncoded as URL 60import Data.URLEncoded as URL
60import Data.Torrent.Metainfo 61import Data.Torrent.Metainfo
61
62import Network 62import Network
63import Network.URI
63import Network.Socket 64import Network.Socket
64 65
65import Network.BitTorrent.Peer 66import Network.BitTorrent.Peer
66import Network.BitTorrent.Sessions.Types
67 67
68{----------------------------------------------------------------------- 68{-----------------------------------------------------------------------
69 Announce messages 69 Announce messages
@@ -365,5 +365,13 @@ instance Serialize ScrapeInfo where
365 365
366-- | Set of tracker RPCs. 366-- | Set of tracker RPCs.
367class Tracker s where 367class Tracker s where
368 connect :: URI -> IO s
368 announce :: s -> AnnounceQuery -> IO AnnounceInfo 369 announce :: s -> AnnounceQuery -> IO AnnounceInfo
369 scrape_ :: s -> ScrapeQuery -> IO Scrape 370 scrape :: s -> ScrapeQuery -> IO Scrape
371
372-- | More particular version of 'scrape', just for one torrent.
373--
374scrapeOne :: Tracker t => t -> InfoHash -> IO ScrapeInfo
375scrapeOne uri ih = scrape uri [ih] >>= maybe err return . M.lookup ih
376 where
377 err = throwIO $ userError "unable to find info hash in response dict"
diff --git a/src/Network/BitTorrent/Tracker/UDP.hs b/src/Network/BitTorrent/Tracker/UDP.hs
index e5475a23..dc1b4897 100644
--- a/src/Network/BitTorrent/Tracker/UDP.hs
+++ b/src/Network/BitTorrent/Tracker/UDP.hs
@@ -15,7 +15,6 @@
15{-# LANGUAGE TypeFamilies #-} 15{-# LANGUAGE TypeFamilies #-}
16module Network.BitTorrent.Tracker.UDP 16module Network.BitTorrent.Tracker.UDP
17 ( UDPTracker 17 ( UDPTracker
18 , initialTracker
19 18
20 -- * Debug 19 -- * Debug
21 , putTracker 20 , putTracker
@@ -316,8 +315,8 @@ scrapeUDP tracker scr = do
316 freshConnection tracker 315 freshConnection tracker
317 resp <- transaction tracker (Scrape scr) 316 resp <- transaction tracker (Scrape scr)
318 case resp of 317 case resp of
319 Scraped scrape -> return $ M.fromList $ L.zip scr scrape 318 Scraped info -> return $ M.fromList $ L.zip scr info
320 _ -> fail "scrape: response type mismatch" 319 _ -> fail "scrape: response type mismatch"
321 320
322{----------------------------------------------------------------------- 321{-----------------------------------------------------------------------
323 Retransmission 322 Retransmission
@@ -342,6 +341,8 @@ retransmission action = go minTimeout
342 maybe (go (2 * curTimeout)) return r 341 maybe (go (2 * curTimeout)) return r
343 342
344{----------------------------------------------------------------------} 343{----------------------------------------------------------------------}
344
345instance Tracker UDPTracker where 345instance Tracker UDPTracker where
346 connect = initialTracker
346 announce t = retransmission . announceUDP t 347 announce t = retransmission . announceUDP t
347 scrape_ t = retransmission . scrapeUDP t 348 scrape t = retransmission . scrapeUDP t