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/Message.hs246
1 files changed, 119 insertions, 127 deletions
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 8f4c9228..469ca0ec 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -23,7 +23,7 @@
23{-# LANGUAGE TemplateHaskell #-} 23{-# LANGUAGE TemplateHaskell #-}
24{-# LANGUAGE DeriveDataTypeable #-} 24{-# LANGUAGE DeriveDataTypeable #-}
25{-# OPTIONS -fno-warn-orphans #-} 25{-# OPTIONS -fno-warn-orphans #-}
26module Network.BitTorrent.Tracker.Protocol 26module Network.BitTorrent.Tracker.Message
27 ( -- * Announce 27 ( -- * Announce
28 Event(..) 28 Event(..)
29 , AnnounceQuery(..) 29 , AnnounceQuery(..)
@@ -71,8 +71,9 @@ import Data.Torrent.Progress
71import Network.BitTorrent.Core.PeerId 71import Network.BitTorrent.Core.PeerId
72import Network.BitTorrent.Core.PeerAddr 72import Network.BitTorrent.Core.PeerAddr
73 73
74
74{----------------------------------------------------------------------- 75{-----------------------------------------------------------------------
75 Announce messages 76-- Events
76-----------------------------------------------------------------------} 77-----------------------------------------------------------------------}
77 78
78-- | Events used to specify which kind of tracker request is performed. 79-- | Events used to specify which kind of tracker request is performed.
@@ -86,6 +87,40 @@ data Event = Started
86 87
87$(deriveJSON (L.map toLower . L.dropWhile isLower) ''Event) 88$(deriveJSON (L.map toLower . L.dropWhile isLower) ''Event)
88 89
90-- | HTTP tracker protocol compatible encoding.
91instance URLShow Event where
92 urlShow e = urlShow (Char.toLower x : xs)
93 where
94 -- INVARIANT: this is always nonempty list
95 (x : xs) = show e
96
97type EventId = Word32
98
99-- | UDP tracker encoding event codes.
100eventId :: Event -> EventId
101eventId Completed = 1
102eventId Started = 2
103eventId Stopped = 3
104
105-- TODO add Regular event
106putEvent :: Putter (Maybe Event)
107putEvent Nothing = putWord32be 0
108putEvent (Just e) = putWord32be (eventId e)
109
110getEvent :: S.Get (Maybe Event)
111getEvent = do
112 eid <- getWord32be
113 case eid of
114 0 -> return Nothing
115 1 -> return $ Just Completed
116 2 -> return $ Just Started
117 3 -> return $ Just Stopped
118 _ -> fail "unknown event id"
119
120{-----------------------------------------------------------------------
121 Announce query
122-----------------------------------------------------------------------}
123
89-- | A tracker request is HTTP GET request; used to include metrics 124-- | A tracker request is HTTP GET request; used to include metrics
90-- from clients that help the tracker keep overall statistics about 125-- from clients that help the tracker keep overall statistics about
91-- the torrent. The most important, requests are used by the tracker 126-- the torrent. The most important, requests are used by the tracker
@@ -121,9 +156,74 @@ data AnnounceQuery = AnnounceQuery {
121 156
122$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery) 157$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery)
123 158
159instance URLShow PortNumber where
160 urlShow = urlShow . fromEnum
161
162instance URLShow Word32 where
163 urlShow = show
164 {-# INLINE urlShow #-}
165
166-- | HTTP tracker protocol compatible encoding.
167instance URLEncode AnnounceQuery where
168 urlEncode AnnounceQuery {..} = mconcat
169 [ s "peer_id" %= reqPeerId
170 , s "port" %= reqPort
171 , urlEncode reqProgress
172 , s "ip" %=? reqIP
173 , s "numwant" %=? reqNumWant
174 , s "event" %=? reqEvent
175 ]
176 where s :: String -> String; s = id; {-# INLINE s #-}
177
178-- | UDP tracker protocol compatible encoding.
179instance Serialize AnnounceQuery where
180 put AnnounceQuery {..} = do
181 put reqInfoHash
182 put reqPeerId
183 put reqProgress
184 putEvent reqEvent
185 putWord32be $ fromMaybe 0 reqIP
186 putWord32be $ 0 -- TODO what the fuck is "key"?
187 putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant
188
189 put reqPort
190
191 get = do
192 ih <- get
193 pid <- get
194
195 progress <- get
196
197 ev <- getEvent
198 ip <- getWord32be
199-- key <- getWord32be -- TODO
200 want <- getWord32be
201
202 port <- get
203
204 return $ AnnounceQuery {
205 reqInfoHash = ih
206 , reqPeerId = pid
207 , reqPort = port
208 , reqProgress = progress
209 , reqIP = if ip == 0 then Nothing else Just ip
210 , reqNumWant = if want == -1 then Nothing else Just (fromIntegral want)
211 , reqEvent = ev
212 }
213
214{-----------------------------------------------------------------------
215-- Announce response
216-----------------------------------------------------------------------}
217
124newtype PeerList = PeerList { getPeerList :: [PeerAddr] } 218newtype PeerList = PeerList { getPeerList :: [PeerAddr] }
125 deriving (Show, Eq, ToJSON, FromJSON, Typeable) 219 deriving (Show, Eq, ToJSON, FromJSON, Typeable)
126 220
221instance BEncode PeerList where
222 toBEncode (PeerList xs) = toBEncode xs
223 fromBEncode (BList l ) = PeerList <$> fromBEncode (BList l)
224 fromBEncode (BString s ) = PeerList <$> runGet getCompactPeerList s
225 fromBEncode _ = decodingError "Peer list"
226
127-- | The tracker response includes a peer list that helps the client 227-- | The tracker response includes a peer list that helps the client
128-- participate in the torrent. The most important is 'respPeer' list 228-- participate in the torrent. The most important is 'respPeer' list
129-- used to join the swarm. 229-- used to join the swarm.
@@ -155,31 +255,6 @@ data AnnounceInfo =
155 255
156$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceInfo) 256$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceInfo)
157 257
158-- | Ports typically reserved for bittorrent P2P listener.
159defaultPorts :: [PortNumber]
160defaultPorts = [6881..6889]
161
162-- | Above 25, new peers are highly unlikely to increase download
163-- speed. Even 30 peers is /plenty/, the official client version 3
164-- in fact only actively forms new connections if it has less than
165-- 30 peers and will refuse connections if it has 55.
166--
167-- So the default value is set to 50 because usually 30-50% of peers
168-- are not responding.
169--
170defaultNumWant :: Int
171defaultNumWant = 50
172
173{-----------------------------------------------------------------------
174 Bencode announce encoding
175-----------------------------------------------------------------------}
176
177instance BEncode PeerList where
178 toBEncode (PeerList xs) = toBEncode xs
179 fromBEncode (BList l ) = PeerList <$> fromBEncode (BList l)
180 fromBEncode (BString s ) = PeerList <$> runGet getCompactPeerList s
181 fromBEncode _ = decodingError "Peer list"
182
183-- | HTTP tracker protocol compatible encoding. 258-- | HTTP tracker protocol compatible encoding.
184instance BEncode AnnounceInfo where 259instance BEncode AnnounceInfo where
185 toBEncode (Failure t) = toDict $ 260 toBEncode (Failure t) = toDict $
@@ -207,105 +282,6 @@ instance BEncode AnnounceInfo where
207 <*>? "warning message" 282 <*>? "warning message"
208 fromBEncode _ = decodingError "Announce info" 283 fromBEncode _ = decodingError "Announce info"
209 284
210instance URLShow PortNumber where
211 urlShow = urlShow . fromEnum
212
213instance URLShow Word32 where
214 urlShow = show
215
216instance URLShow Event where
217 urlShow e = urlShow (Char.toLower x : xs)
218 where
219 -- INVARIANT: this is always nonempty list
220 (x : xs) = show e
221
222instance URLShow Word64 where
223 urlShow = show
224
225instance URLEncode Progress where
226 urlEncode Progress {..} = mconcat
227 [ s "uploaded" %= _uploaded
228 , s "left" %= _left
229 , s "downloaded" %= _downloaded
230 ]
231 where s :: String -> String; s = id; {-# INLINE s #-}
232
233-- | HTTP tracker protocol compatible encoding.
234instance URLEncode AnnounceQuery where
235 urlEncode AnnounceQuery {..} = mconcat
236 [ s "peer_id" %= reqPeerId
237 , s "port" %= reqPort
238 , urlEncode reqProgress
239
240
241 , s "ip" %=? reqIP
242 , s "numwant" %=? reqNumWant
243 , s "event" %=? reqEvent
244 ]
245 where s :: String -> String; s = id; {-# INLINE s #-}
246
247{-----------------------------------------------------------------------
248 Binary announce encoding
249-----------------------------------------------------------------------}
250
251type EventId = Word32
252
253eventId :: Event -> EventId
254eventId Completed = 1
255eventId Started = 2
256eventId Stopped = 3
257
258-- TODO add Regular event
259putEvent :: Putter (Maybe Event)
260putEvent Nothing = putWord32be 0
261putEvent (Just e) = putWord32be (eventId e)
262
263getEvent :: S.Get (Maybe Event)
264getEvent = do
265 eid <- getWord32be
266 case eid of
267 0 -> return Nothing
268 1 -> return $ Just Completed
269 2 -> return $ Just Started
270 3 -> return $ Just Stopped
271 _ -> fail "unknown event id"
272
273-- | UDP tracker protocol compatible encoding.
274instance Serialize AnnounceQuery where
275 put AnnounceQuery {..} = do
276 put reqInfoHash
277 put reqPeerId
278 put reqProgress
279 putEvent reqEvent
280 putWord32be $ fromMaybe 0 reqIP
281 putWord32be $ 0 -- TODO what the fuck is "key"?
282 putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant
283
284 put reqPort
285
286 get = do
287 ih <- get
288 pid <- get
289
290 progress <- get
291
292 ev <- getEvent
293 ip <- getWord32be
294-- key <- getWord32be -- TODO
295 want <- getWord32be
296
297 port <- get
298
299 return $ AnnounceQuery {
300 reqInfoHash = ih
301 , reqPeerId = pid
302 , reqPort = port
303 , reqProgress = progress
304 , reqIP = if ip == 0 then Nothing else Just ip
305 , reqNumWant = if want == -1 then Nothing else Just (fromIntegral want)
306 , reqEvent = ev
307 }
308
309-- | UDP tracker protocol compatible encoding. 285-- | UDP tracker protocol compatible encoding.
310instance Serialize AnnounceInfo where 286instance Serialize AnnounceInfo where
311 put (Failure msg) = put $ encodeUtf8 msg 287 put (Failure msg) = put $ encodeUtf8 msg
@@ -330,8 +306,24 @@ instance Serialize AnnounceInfo where
330 , respPeers = PeerList peers 306 , respPeers = PeerList peers
331 } 307 }
332 308
309-- TODO move this somewhere else
310-- | Ports typically reserved for bittorrent P2P listener.
311defaultPorts :: [PortNumber]
312defaultPorts = [6881..6889]
313
314-- | Above 25, new peers are highly unlikely to increase download
315-- speed. Even 30 peers is /plenty/, the official client version 3
316-- in fact only actively forms new connections if it has less than
317-- 30 peers and will refuse connections if it has 55.
318--
319-- So the default value is set to 50 because usually 30-50% of peers
320-- are not responding.
321--
322defaultNumWant :: Int
323defaultNumWant = 50
324
333{----------------------------------------------------------------------- 325{-----------------------------------------------------------------------
334 Scrape messages 326 Scrape message
335-----------------------------------------------------------------------} 327-----------------------------------------------------------------------}
336 328
337type ScrapeQuery = [InfoHash] 329type ScrapeQuery = [InfoHash]