summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Tracker.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Tracker.hs')
-rw-r--r--src/Network/BitTorrent/Tracker.hs227
1 files changed, 25 insertions, 202 deletions
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
index 9c7590c4..6af76a16 100644
--- a/src/Network/BitTorrent/Tracker.hs
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -11,207 +11,30 @@
11-- 11--
12{-# LANGUAGE TemplateHaskell #-} 12{-# LANGUAGE TemplateHaskell #-}
13module Network.BitTorrent.Tracker 13module Network.BitTorrent.Tracker
14 ( -- * Connection 14 ( PeerInfo (..)
15 TConnection(..) 15
16 , tconnection 16 -- * RPC Manager
17 17 , Options
18 -- * Session 18 , Manager
19 , TSession 19 , newManager
20 , tracker 20 , closeManager
21 21 , withManager
22 -- * Re-export 22
23 , defaultPorts 23 -- * Multitracker session
24 , ScrapeInfo 24 , trackerList
25 , Session
26 , newSession
27 , closeSession
28
29 -- * Events
30 , Event (..)
31 , notify
32 , askPeers
33
34 -- * Query
35-- , getSessionState
25 ) where 36 ) where
26 37
27import Control.Applicative 38import Network.BitTorrent.Tracker.List
28import Control.Concurrent 39import Network.BitTorrent.Tracker.RPC
29import Control.Concurrent.BoundedChan as BC 40import Network.BitTorrent.Tracker.Session
30import Control.Concurrent.STM
31import Control.Exception
32import Control.Monad
33import Data.List as L
34import Data.IORef
35import Data.Text as T
36import Network
37import Network.URI
38
39import Data.Torrent
40import Network.BitTorrent.Peer
41import Network.BitTorrent.Tracker.Protocol as Tracker
42import Network.BitTorrent.Tracker.HTTP
43import Network.BitTorrent.Tracker.UDP
44
45{-----------------------------------------------------------------------
46 Tracker connection
47-----------------------------------------------------------------------}
48
49-- | 'TConnection' (shorthand for Tracker session) combines tracker
50-- request fields neccessary for tracker, torrent and client
51-- identification.
52--
53-- This data is considered as static within one session.
54--
55data TConnection = TConnection {
56 tconnAnnounce :: URI
57 -- ^ Announce URL.
58 , tconnInfoHash :: InfoHash
59 -- ^ Hash of info part of current .torrent file.
60 , tconnPeerId :: PeerId
61 -- ^ Client peer ID.
62 , tconnPort :: PortNumber
63 -- ^ The port number the client is listenning on.
64 } deriving Show
65
66-- TODO tconnection :: SwarmSession -> TConnection
67tconnection :: Torrent -> PeerId -> PortNumber -> TConnection
68tconnection t = TConnection (tAnnounce t) (tInfoHash t)
69
70-- | used to avoid boilerplate; do NOT export me
71genericReq :: TConnection -> Progress -> AnnounceQuery
72genericReq ses pr = AnnounceQuery {
73 reqInfoHash = tconnInfoHash ses
74 , reqPeerId = tconnPeerId ses
75 , reqPort = tconnPort ses
76
77 , reqProgress = pr
78
79 , reqIP = Nothing
80 , reqNumWant = Nothing
81 , reqEvent = Nothing
82 }
83
84-- | The first request to the tracker that should be created is
85-- 'startedReq'. It includes necessary 'Started' event field.
86--
87startedReq :: TConnection -> Progress -> AnnounceQuery
88startedReq ses pr = (genericReq ses pr)
89 { reqNumWant = Just defaultNumWant
90 , reqEvent = Just Started
91 }
92
93-- | Regular request must be sent to keep track new peers and
94-- notify tracker about current state of the client
95-- so new peers could connect to the client.
96--
97regularReq :: Int -> TConnection -> Progress -> AnnounceQuery
98regularReq numWant ses pr = (genericReq ses pr)
99 { reqNumWant = Just numWant
100 , reqEvent = Nothing
101 }
102
103-- | Must be sent to the tracker if the client is shutting down
104-- gracefully.
105--
106stoppedReq :: TConnection -> Progress -> AnnounceQuery
107stoppedReq ses pr = (genericReq ses pr)
108 { reqNumWant = Nothing
109 , reqEvent = Just Stopped
110 }
111
112-- | Must be sent to the tracker when the download completes.
113-- However, must not be sent if the download was already 100%
114-- complete.
115--
116completedReq :: TConnection -> Progress -> AnnounceQuery
117completedReq ses pr = (genericReq ses pr)
118 { reqNumWant = Nothing
119 , reqEvent = Just Completed
120 }
121
122{-----------------------------------------------------------------------
123 Tracker session
124-----------------------------------------------------------------------}
125
126{- Why use BoundedChan?
127
128Because most times we need just a list of peer at the start and all
129the rest time we will take little by little. On the other hand tracker
130will give us some constant count of peers and channel will grow with
131time. To avoid space leaks and long lists of peers (which we don't
132need) we use bounded chaan.
133
134 Chan size.
135
136Should be at least (count_of_workers * 2) to accumulate long enough
137peer list.
138
139 Order of peers in chan.
140
141Old peers in head, new ones in tail. Old peers should be used in the
142first place because by statistics they are most likely will present in
143network a long time than a new.
144
145-}
146
147type TimeInterval = Int
148
149waitInterval :: TSession -> IO ()
150waitInterval TSession {..} = do
151 delay <- readIORef seInterval
152 threadDelay (delay * sec)
153 where
154 sec = 1000 * 1000 :: Int
155
156data TSession = TSession
157 { seConnection :: !TConnection
158 , seTracker :: !BitTracker
159 , seProgress :: !(TVar Progress)
160 , sePeers :: !(BoundedChan PeerAddr)
161 , seInterval :: {-# UNPACK #-} !(IORef TimeInterval)
162 }
163
164openSession :: BoundedChan PeerAddr
165 -> TVar Progress
166 -> TConnection -> IO TSession
167openSession chan progress conn @ TConnection {..} = do
168 trac <- Tracker.connect tconnAnnounce
169 pr <- readTVarIO progress
170 resp <- Tracker.announce trac $ startedReq conn pr
171 print resp
172 case resp of
173 Failure e -> throwIO $ userError $ T.unpack e
174 AnnounceInfo {..} -> do
175 -- TODO make use of rest AnnounceInfo fields
176 BC.writeList2Chan chan respPeers
177 TSession conn trac progress chan
178 <$> newIORef respInterval
179
180closeSession :: TSession -> IO ()
181closeSession TSession {..} = do
182 pr <- readTVarIO seProgress
183 _ <- Tracker.announce seTracker (stoppedReq seConnection pr)
184 return ()
185
186withSession :: BoundedChan PeerAddr
187 -> TVar Progress
188 -> TConnection -> (TSession -> IO a) -> IO a
189withSession chan prog conn
190 = bracket (openSession chan prog conn) closeSession
191
192askPeers :: TSession -> IO ()
193askPeers se @ TSession {..} = forever $ do
194 waitInterval se
195 pr <- readTVarIO seProgress
196 resp <- tryJust isIOException $ do
197 let req = regularReq defaultNumWant seConnection pr
198 Tracker.announce seTracker req
199 print resp
200 case resp of
201 Left _ -> return ()
202 Right (Failure e) -> throwIO $ userError $ T.unpack e
203 Right (AnnounceInfo {..}) -> do
204 writeIORef seInterval respInterval
205
206 -- we rely on the fact that union on lists is not
207 -- commutative: this implements the heuristic "old peers
208 -- in head"
209 old <- BC.getChanContents sePeers
210 let combined = L.union old respPeers
211 BC.writeList2Chan sePeers combined
212 where
213 isIOException :: IOException -> Maybe IOException
214 isIOException = return
215
216tracker :: BoundedChan PeerAddr -> TVar Progress -> TConnection -> IO ()
217tracker chan prog conn = withSession chan prog conn askPeers \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:27:21 +0000