diff options
Diffstat (limited to 'src/Network/BitTorrent/Tracker/Message.hs')
-rw-r--r-- | src/Network/BitTorrent/Tracker/Message.hs | 665 |
1 files changed, 665 insertions, 0 deletions
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs new file mode 100644 index 00000000..e8e4cf0e --- /dev/null +++ b/src/Network/BitTorrent/Tracker/Message.hs | |||
@@ -0,0 +1,665 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Every tracker should support announce query. This query is used | ||
9 | -- to discover peers within a swarm and have two-fold effect: | ||
10 | -- | ||
11 | -- * peer doing announce discover other peers using peer list from | ||
12 | -- the response to the announce query. | ||
13 | -- | ||
14 | -- * tracker store peer information and use it in the succeeding | ||
15 | -- requests made by other peers, until the peer info expires. | ||
16 | -- | ||
17 | -- By convention most trackers support another form of request — | ||
18 | -- scrape query — which queries the state of a given torrent (or | ||
19 | -- a list of torrents) that the tracker is managing. | ||
20 | -- | ||
21 | {-# LANGUAGE FlexibleInstances #-} | ||
22 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
23 | {-# LANGUAGE TemplateHaskell #-} | ||
24 | {-# LANGUAGE DeriveDataTypeable #-} | ||
25 | {-# OPTIONS -fno-warn-orphans #-} | ||
26 | module Network.BitTorrent.Tracker.Message | ||
27 | ( -- * Announce | ||
28 | -- ** Query | ||
29 | Event(..) | ||
30 | , AnnounceQuery(..) | ||
31 | , renderAnnounceQuery | ||
32 | , ParamParseFailure | ||
33 | , parseAnnounceQuery | ||
34 | |||
35 | -- ** Request | ||
36 | , AnnounceQueryExt (..) | ||
37 | , AnnounceRequest (..) | ||
38 | , parseAnnounceRequest | ||
39 | , renderAnnounceRequest | ||
40 | |||
41 | -- ** Info | ||
42 | , PeerList (..) | ||
43 | , AnnounceInfo(..) | ||
44 | , defaultNumWant | ||
45 | , defaultMaxNumWant | ||
46 | , defaultReannounceInterval | ||
47 | , parseFailureStatus | ||
48 | |||
49 | -- * Scrape | ||
50 | -- ** Query | ||
51 | , ScrapeQuery | ||
52 | , renderScrapeQuery | ||
53 | , parseScrapeQuery | ||
54 | |||
55 | -- ** Info | ||
56 | , ScrapeEntry (..) | ||
57 | , ScrapeInfo | ||
58 | |||
59 | -- * Extra | ||
60 | , queryToSimpleQuery | ||
61 | ) | ||
62 | where | ||
63 | |||
64 | import Control.Applicative | ||
65 | import Control.Monad | ||
66 | import Data.Aeson (ToJSON(..), FromJSON(..)) | ||
67 | import Data.Aeson.TH | ||
68 | import Data.BEncode as BE hiding (Result) | ||
69 | import Data.BEncode.BDict as BE | ||
70 | import Data.ByteString as BS | ||
71 | import Data.ByteString.Char8 as BC | ||
72 | import Data.Char as Char | ||
73 | import Data.Convertible | ||
74 | import Data.Default | ||
75 | import Data.List as L | ||
76 | import Data.Maybe | ||
77 | import Data.Serialize as S hiding (Result) | ||
78 | import Data.Text (Text) | ||
79 | import Data.Text.Encoding | ||
80 | import Data.Typeable | ||
81 | import Data.Word | ||
82 | import Network | ||
83 | import Network.HTTP.Types.QueryLike | ||
84 | import Network.HTTP.Types.URI hiding (urlEncode) | ||
85 | import Network.HTTP.Types.Status | ||
86 | import Network.Socket | ||
87 | import Text.Read (readMaybe) | ||
88 | |||
89 | import Data.Torrent.InfoHash | ||
90 | import Data.Torrent.Progress | ||
91 | import Network.BitTorrent.Core.PeerId | ||
92 | import Network.BitTorrent.Core.PeerAddr | ||
93 | |||
94 | |||
95 | {----------------------------------------------------------------------- | ||
96 | -- Events | ||
97 | -----------------------------------------------------------------------} | ||
98 | |||
99 | -- | Events used to specify which kind of announce query is performed. | ||
100 | data Event = Started | ||
101 | -- ^ For the first request: when a peer join the swarm. | ||
102 | | Stopped | ||
103 | -- ^ Sent when the peer is shutting down. | ||
104 | | Completed | ||
105 | -- ^ To be sent when the peer completes a download. | ||
106 | deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) | ||
107 | |||
108 | $(deriveJSON defaultOptions { fieldLabelModifier = (L.map toLower . L.dropWhile isLower) } ''Event) | ||
109 | |||
110 | -- | HTTP tracker protocol compatible encoding. | ||
111 | instance QueryValueLike Event where | ||
112 | toQueryValue e = toQueryValue (Char.toLower x : xs) | ||
113 | where | ||
114 | (x : xs) = show e -- INVARIANT: this is always nonempty list | ||
115 | |||
116 | type EventId = Word32 | ||
117 | |||
118 | -- | UDP tracker encoding event codes. | ||
119 | eventId :: Event -> EventId | ||
120 | eventId Completed = 1 | ||
121 | eventId Started = 2 | ||
122 | eventId Stopped = 3 | ||
123 | |||
124 | -- TODO add Regular event | ||
125 | putEvent :: Putter (Maybe Event) | ||
126 | putEvent Nothing = putWord32be 0 | ||
127 | putEvent (Just e) = putWord32be (eventId e) | ||
128 | |||
129 | getEvent :: S.Get (Maybe Event) | ||
130 | getEvent = do | ||
131 | eid <- getWord32be | ||
132 | case eid of | ||
133 | 0 -> return Nothing | ||
134 | 1 -> return $ Just Completed | ||
135 | 2 -> return $ Just Started | ||
136 | 3 -> return $ Just Stopped | ||
137 | _ -> fail "unknown event id" | ||
138 | |||
139 | {----------------------------------------------------------------------- | ||
140 | Announce query | ||
141 | -----------------------------------------------------------------------} | ||
142 | |||
143 | -- | A tracker request is HTTP GET request; used to include metrics | ||
144 | -- from clients that help the tracker keep overall statistics about | ||
145 | -- the torrent. The most important, requests are used by the tracker | ||
146 | -- to keep track lists of active peer for a particular torrent. | ||
147 | -- | ||
148 | data AnnounceQuery = AnnounceQuery | ||
149 | { | ||
150 | -- | Hash of info part of the torrent usually obtained from | ||
151 | -- 'Torrent' or 'Magnet'. | ||
152 | reqInfoHash :: !InfoHash | ||
153 | |||
154 | -- | ID of the peer doing request. | ||
155 | , reqPeerId :: !PeerId | ||
156 | |||
157 | -- | Port to listen to for connections from other | ||
158 | -- peers. Tracker should respond with this port when | ||
159 | -- some /other/ peer request the tracker with the same info hash. | ||
160 | -- Normally, this port is choosed from 'defaultPorts'. | ||
161 | , reqPort :: !PortNumber | ||
162 | |||
163 | -- | Current progress of peer doing request. | ||
164 | , reqProgress :: !Progress | ||
165 | |||
166 | -- | The peer IP. Needed only when client communicated with | ||
167 | -- tracker throught a proxy. | ||
168 | , reqIP :: Maybe HostAddress | ||
169 | |||
170 | -- | Number of peers that the peers wants to receive from. See | ||
171 | -- note for 'defaultNumWant'. | ||
172 | , reqNumWant :: Maybe Int | ||
173 | |||
174 | -- | If not specified, the request is regular periodic request. | ||
175 | , reqEvent :: Maybe Event | ||
176 | } deriving (Show, Eq, Typeable) | ||
177 | |||
178 | $(deriveJSON defaultOptions { fieldLabelModifier = (L.map toLower . L.dropWhile isLower) } ''AnnounceQuery) | ||
179 | |||
180 | -- | UDP tracker protocol compatible encoding. | ||
181 | instance Serialize AnnounceQuery where | ||
182 | put AnnounceQuery {..} = do | ||
183 | put reqInfoHash | ||
184 | put reqPeerId | ||
185 | put reqProgress | ||
186 | putEvent reqEvent | ||
187 | putWord32be $ fromMaybe 0 reqIP | ||
188 | putWord32be $ 0 -- TODO what the fuck is "key"? | ||
189 | putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant | ||
190 | |||
191 | put reqPort | ||
192 | |||
193 | get = do | ||
194 | ih <- get | ||
195 | pid <- get | ||
196 | |||
197 | progress <- get | ||
198 | |||
199 | ev <- getEvent | ||
200 | ip <- getWord32be | ||
201 | -- key <- getWord32be -- TODO | ||
202 | want <- getWord32be | ||
203 | |||
204 | port <- get | ||
205 | |||
206 | return $ AnnounceQuery { | ||
207 | reqInfoHash = ih | ||
208 | , reqPeerId = pid | ||
209 | , reqPort = port | ||
210 | , reqProgress = progress | ||
211 | , reqIP = if ip == 0 then Nothing else Just ip | ||
212 | , reqNumWant = if want == -1 then Nothing | ||
213 | else Just (fromIntegral want) | ||
214 | , reqEvent = ev | ||
215 | } | ||
216 | |||
217 | instance QueryValueLike PortNumber where | ||
218 | toQueryValue = toQueryValue . show . fromEnum | ||
219 | |||
220 | instance QueryValueLike Word32 where | ||
221 | toQueryValue = toQueryValue . show | ||
222 | |||
223 | instance QueryValueLike Int where | ||
224 | toQueryValue = toQueryValue . show | ||
225 | |||
226 | -- | HTTP tracker protocol compatible encoding. | ||
227 | instance QueryLike AnnounceQuery where | ||
228 | toQuery AnnounceQuery {..} = | ||
229 | toQuery reqProgress ++ | ||
230 | [ ("info_hash", toQueryValue reqInfoHash) -- TODO use 'paramName' | ||
231 | , ("peer_id" , toQueryValue reqPeerId) | ||
232 | , ("port" , toQueryValue reqPort) | ||
233 | , ("ip" , toQueryValue reqIP) | ||
234 | , ("numwant" , toQueryValue reqNumWant) | ||
235 | , ("event" , toQueryValue reqEvent) | ||
236 | ] | ||
237 | |||
238 | -- | Filter @param=value@ pairs with the unset value. | ||
239 | queryToSimpleQuery :: Query -> SimpleQuery | ||
240 | queryToSimpleQuery = catMaybes . L.map f | ||
241 | where | ||
242 | f (_, Nothing) = Nothing | ||
243 | f (a, Just b ) = Just (a, b) | ||
244 | |||
245 | -- | Encode announce query to query string. | ||
246 | renderAnnounceQuery :: AnnounceQuery -> SimpleQuery | ||
247 | renderAnnounceQuery = queryToSimpleQuery . toQuery | ||
248 | |||
249 | data QueryParam | ||
250 | -- announce query | ||
251 | = ParamInfoHash | ||
252 | | ParamPeerId | ||
253 | | ParamPort | ||
254 | | ParamUploaded | ||
255 | | ParamLeft | ||
256 | | ParamDownloaded | ||
257 | | ParamIP | ||
258 | | ParamNumWant | ||
259 | | ParamEvent | ||
260 | -- announce query ext | ||
261 | | ParamCompact | ||
262 | | ParamNoPeerId | ||
263 | deriving (Show, Eq, Ord, Enum) | ||
264 | |||
265 | paramName :: QueryParam -> BS.ByteString | ||
266 | paramName ParamInfoHash = "info_hash" | ||
267 | paramName ParamPeerId = "peer_id" | ||
268 | paramName ParamPort = "port" | ||
269 | paramName ParamUploaded = "uploaded" | ||
270 | paramName ParamLeft = "left" | ||
271 | paramName ParamDownloaded = "downloaded" | ||
272 | paramName ParamIP = "ip" | ||
273 | paramName ParamNumWant = "numwant" | ||
274 | paramName ParamEvent = "event" | ||
275 | paramName ParamCompact = "compact" | ||
276 | paramName ParamNoPeerId = "no_peer_id" | ||
277 | {-# INLINE paramName #-} | ||
278 | |||
279 | class FromParam a where | ||
280 | fromParam :: BS.ByteString -> Maybe a | ||
281 | |||
282 | instance FromParam InfoHash where | ||
283 | fromParam = either (const Nothing) pure . safeConvert | ||
284 | |||
285 | instance FromParam PeerId where | ||
286 | fromParam = either (const Nothing) pure . safeConvert | ||
287 | |||
288 | instance FromParam Word32 where | ||
289 | fromParam = readMaybe . BC.unpack | ||
290 | |||
291 | instance FromParam Word64 where | ||
292 | fromParam = readMaybe . BC.unpack | ||
293 | |||
294 | instance FromParam Int where | ||
295 | fromParam = readMaybe . BC.unpack | ||
296 | |||
297 | instance FromParam PortNumber where | ||
298 | fromParam bs = fromIntegral <$> (fromParam bs :: Maybe Word32) | ||
299 | |||
300 | instance FromParam Event where | ||
301 | fromParam bs = do | ||
302 | (x, xs) <- BC.uncons bs | ||
303 | readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs | ||
304 | |||
305 | -- | 'ParamParseFailure' represent errors can occur while parsing HTTP | ||
306 | -- tracker requests. In case of failure, this can be used to provide | ||
307 | -- more informative 'statusCode' and 'statusMessage' in tracker | ||
308 | -- responses. | ||
309 | -- | ||
310 | data ParamParseFailure | ||
311 | = Missing QueryParam -- ^ param not found in query string; | ||
312 | | Invalid QueryParam BS.ByteString -- ^ param present but not valid. | ||
313 | deriving (Show, Eq) | ||
314 | |||
315 | type ParseResult = Either ParamParseFailure | ||
316 | |||
317 | withError :: ParamParseFailure -> Maybe a -> ParseResult a | ||
318 | withError e = maybe (Left e) Right | ||
319 | |||
320 | reqParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult a | ||
321 | reqParam param xs = do | ||
322 | val <- withError (Missing param) $ L.lookup (paramName param) xs | ||
323 | withError (Invalid param val) (fromParam val) | ||
324 | |||
325 | optParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult (Maybe a) | ||
326 | optParam param ps | ||
327 | | Just x <- L.lookup (paramName param) ps | ||
328 | = pure <$> withError (Invalid param x) (fromParam x) | ||
329 | | otherwise = pure Nothing | ||
330 | |||
331 | parseProgress :: SimpleQuery -> ParseResult Progress | ||
332 | parseProgress params = Progress | ||
333 | <$> reqParam ParamDownloaded params | ||
334 | <*> reqParam ParamLeft params | ||
335 | <*> reqParam ParamUploaded params | ||
336 | |||
337 | -- | Parse announce request from a query string. | ||
338 | parseAnnounceQuery :: SimpleQuery -> ParseResult AnnounceQuery | ||
339 | parseAnnounceQuery params = AnnounceQuery | ||
340 | <$> reqParam ParamInfoHash params | ||
341 | <*> reqParam ParamPeerId params | ||
342 | <*> reqParam ParamPort params | ||
343 | <*> parseProgress params | ||
344 | <*> optParam ParamIP params | ||
345 | <*> optParam ParamNumWant params | ||
346 | <*> optParam ParamEvent params | ||
347 | |||
348 | -- | Extensions for HTTP tracker protocol. | ||
349 | data AnnounceQueryExt = AnnounceQueryExt | ||
350 | { -- | If specified, "compact" parameter is used to advise the | ||
351 | -- tracker to send peer id list as: | ||
352 | -- | ||
353 | -- * bencoded list (extCompact = Just False); | ||
354 | -- * or more compact binary string (extCompact = Just True). | ||
355 | -- | ||
356 | -- The later is prefered since compact peer list will reduce the | ||
357 | -- size of tracker responses. Hovewer, if tracker do not support | ||
358 | -- this extension then it can return peer list in either form. | ||
359 | -- | ||
360 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
361 | -- | ||
362 | extCompact :: !(Maybe Bool) | ||
363 | |||
364 | -- | If specified, "no_peer_id" parameter is used advise tracker | ||
365 | -- to either send or not to send peer id in tracker response. | ||
366 | -- Tracker may not support this extension as well. | ||
367 | -- | ||
368 | -- For more info see: | ||
369 | -- <http://permalink.gmane.org/gmane.network.bit-torrent.general/4030> | ||
370 | -- | ||
371 | , extNoPeerId :: !(Maybe Bool) | ||
372 | } deriving (Show, Eq, Typeable) | ||
373 | |||
374 | instance Default AnnounceQueryExt where | ||
375 | def = AnnounceQueryExt Nothing Nothing | ||
376 | |||
377 | instance QueryLike AnnounceQueryExt where | ||
378 | toQuery AnnounceQueryExt {..} = | ||
379 | [ ("compact", toQueryFlag <$> extCompact) -- TODO use 'paramName' | ||
380 | , ("no_peer_id", toQueryFlag <$> extNoPeerId) | ||
381 | ] | ||
382 | where | ||
383 | toQueryFlag False = "0" | ||
384 | toQueryFlag True = "1" | ||
385 | |||
386 | instance FromParam Bool where | ||
387 | fromParam "0" = Just False | ||
388 | fromParam "1" = Just True | ||
389 | fromParam _ = Nothing | ||
390 | |||
391 | -- | Parse announce query extended part from query string. | ||
392 | parseAnnounceQueryExt :: SimpleQuery -> AnnounceQueryExt | ||
393 | parseAnnounceQueryExt params = either (const def) id $ | ||
394 | AnnounceQueryExt | ||
395 | <$> optParam ParamCompact params | ||
396 | <*> optParam ParamNoPeerId params | ||
397 | |||
398 | -- | Render announce query extended part to query string. | ||
399 | renderAnnounceQueryExt :: AnnounceQueryExt -> SimpleQuery | ||
400 | renderAnnounceQueryExt = queryToSimpleQuery . toQuery | ||
401 | |||
402 | -- | HTTP tracker request with extensions. | ||
403 | data AnnounceRequest = AnnounceRequest | ||
404 | { announceQuery :: AnnounceQuery -- ^ Request query params. | ||
405 | , announceAdvises :: AnnounceQueryExt -- ^ Optional advises to the tracker. | ||
406 | } deriving (Show, Eq, Typeable) | ||
407 | |||
408 | instance QueryLike AnnounceRequest where | ||
409 | toQuery AnnounceRequest{..} = toQuery announceAdvises ++ toQuery announceQuery | ||
410 | |||
411 | -- | Parse announce request from query string. | ||
412 | parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest | ||
413 | parseAnnounceRequest params = AnnounceRequest | ||
414 | <$> parseAnnounceQuery params | ||
415 | <*> pure (parseAnnounceQueryExt params) | ||
416 | |||
417 | -- | Render announce request to query string. | ||
418 | renderAnnounceRequest :: AnnounceRequest -> SimpleQuery | ||
419 | renderAnnounceRequest = queryToSimpleQuery . toQuery | ||
420 | |||
421 | {----------------------------------------------------------------------- | ||
422 | -- Announce response | ||
423 | -----------------------------------------------------------------------} | ||
424 | |||
425 | -- | Tracker can return peer list in either compact(BEP23) or not | ||
426 | -- compact form. | ||
427 | -- | ||
428 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
429 | -- | ||
430 | data PeerList | ||
431 | = PeerList { getPeerList :: [PeerAddr] } | ||
432 | | CompactPeerList { getPeerList :: [PeerAddr] } | ||
433 | deriving (Show, Eq, Typeable) | ||
434 | |||
435 | instance ToJSON PeerList where | ||
436 | toJSON = toJSON . getPeerList | ||
437 | |||
438 | instance FromJSON PeerList where | ||
439 | parseJSON v = PeerList <$> parseJSON v | ||
440 | |||
441 | putCompactPeerList :: S.Putter [PeerAddr] | ||
442 | putCompactPeerList = mapM_ put | ||
443 | |||
444 | getCompactPeerList :: S.Get [PeerAddr] | ||
445 | getCompactPeerList = many get | ||
446 | |||
447 | instance BEncode PeerList where | ||
448 | toBEncode (PeerList xs) = toBEncode xs | ||
449 | toBEncode (CompactPeerList xs) = toBEncode $ runPut (putCompactPeerList xs) | ||
450 | |||
451 | fromBEncode (BList l ) = PeerList <$> fromBEncode (BList l) | ||
452 | fromBEncode (BString s ) = CompactPeerList <$> runGet getCompactPeerList s | ||
453 | fromBEncode _ = decodingError "Peer list" | ||
454 | |||
455 | -- | The tracker response includes a peer list that helps the client | ||
456 | -- participate in the torrent. The most important is 'respPeer' list | ||
457 | -- used to join the swarm. | ||
458 | -- | ||
459 | data AnnounceInfo = | ||
460 | Failure !Text -- ^ Failure reason in human readable form. | ||
461 | | AnnounceInfo { | ||
462 | -- | Number of peers completed the torrent. (seeders) | ||
463 | respComplete :: !(Maybe Int) | ||
464 | |||
465 | -- | Number of peers downloading the torrent. (leechers) | ||
466 | , respIncomplete :: !(Maybe Int) | ||
467 | |||
468 | -- | Recommended interval to wait between requests, in seconds. | ||
469 | , respInterval :: !Int | ||
470 | |||
471 | -- | Minimal amount of time between requests, in seconds. A | ||
472 | -- peer /should/ make timeout with at least 'respMinInterval' | ||
473 | -- value, otherwise tracker might not respond. If not specified | ||
474 | -- the same applies to 'respInterval'. | ||
475 | , respMinInterval :: !(Maybe Int) | ||
476 | |||
477 | -- | Peers that must be contacted. | ||
478 | , respPeers :: !PeerList | ||
479 | |||
480 | -- | Human readable warning. | ||
481 | , respWarning :: !(Maybe Text) | ||
482 | } deriving (Show, Typeable) | ||
483 | |||
484 | $(deriveJSON defaultOptions { fieldLabelModifier = (L.map toLower . L.dropWhile isLower) } ''AnnounceInfo) | ||
485 | |||
486 | -- | HTTP tracker protocol compatible encoding. | ||
487 | instance BEncode AnnounceInfo where | ||
488 | toBEncode (Failure t) = toDict $ | ||
489 | "failure reason" .=! t | ||
490 | .: endDict | ||
491 | |||
492 | toBEncode AnnounceInfo {..} = toDict $ | ||
493 | "complete" .=? respComplete | ||
494 | .: "incomplete" .=? respIncomplete | ||
495 | .: "interval" .=! respInterval | ||
496 | .: "min interval" .=? respMinInterval | ||
497 | .: "peers" .=! respPeers | ||
498 | .: "warning message" .=? respWarning | ||
499 | .: endDict | ||
500 | |||
501 | fromBEncode (BDict d) | ||
502 | | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t | ||
503 | | otherwise = (`fromDict` (BDict d)) $ do | ||
504 | AnnounceInfo | ||
505 | <$>? "complete" | ||
506 | <*>? "incomplete" | ||
507 | <*>! "interval" | ||
508 | <*>? "min interval" | ||
509 | <*>! "peers" | ||
510 | <*>? "warning message" | ||
511 | fromBEncode _ = decodingError "Announce info" | ||
512 | |||
513 | -- | UDP tracker protocol compatible encoding. | ||
514 | instance Serialize AnnounceInfo where | ||
515 | put (Failure msg) = put $ encodeUtf8 msg | ||
516 | put AnnounceInfo {..} = do | ||
517 | putWord32be $ fromIntegral respInterval | ||
518 | putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete | ||
519 | putWord32be $ fromIntegral $ fromMaybe 0 respComplete | ||
520 | forM_ (getPeerList respPeers) put | ||
521 | |||
522 | get = do | ||
523 | interval <- getWord32be | ||
524 | leechers <- getWord32be | ||
525 | seeders <- getWord32be | ||
526 | peers <- many get | ||
527 | |||
528 | return $ AnnounceInfo { | ||
529 | respWarning = Nothing | ||
530 | , respInterval = fromIntegral interval | ||
531 | , respMinInterval = Nothing | ||
532 | , respIncomplete = Just $ fromIntegral leechers | ||
533 | , respComplete = Just $ fromIntegral seeders | ||
534 | , respPeers = PeerList peers | ||
535 | } | ||
536 | |||
537 | -- | Above 25, new peers are highly unlikely to increase download | ||
538 | -- speed. Even 30 peers is /plenty/, the official client version 3 | ||
539 | -- in fact only actively forms new connections if it has less than | ||
540 | -- 30 peers and will refuse connections if it has 55. | ||
541 | -- | ||
542 | -- <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Basic_Tracker_Announce_Request> | ||
543 | -- | ||
544 | defaultNumWant :: Int | ||
545 | defaultNumWant = 50 | ||
546 | |||
547 | -- | Reasonable upper bound of numwant parameter. | ||
548 | defaultMaxNumWant :: Int | ||
549 | defaultMaxNumWant = 200 | ||
550 | |||
551 | -- | Widely used reannounce interval. Note: tracker clients should not | ||
552 | -- use this value! | ||
553 | defaultReannounceInterval :: Int | ||
554 | defaultReannounceInterval = 30 * 60 | ||
555 | |||
556 | missingOffset :: Int | ||
557 | missingOffset = 101 | ||
558 | |||
559 | invalidOffset :: Int | ||
560 | invalidOffset = 150 | ||
561 | |||
562 | parseFailureCode :: ParamParseFailure -> Int | ||
563 | parseFailureCode (Missing param ) = missingOffset + fromEnum param | ||
564 | parseFailureCode (Invalid param _) = invalidOffset + fromEnum param | ||
565 | |||
566 | parseFailureMessage :: ParamParseFailure -> BS.ByteString | ||
567 | parseFailureMessage e = BS.concat $ case e of | ||
568 | Missing p -> ["Missing parameter: ", paramName p] | ||
569 | Invalid p v -> ["Invalid parameter: ", paramName p, " = ", v] | ||
570 | |||
571 | -- | Get HTTP response status from a announce params parse failure. | ||
572 | -- | ||
573 | -- For more info see: | ||
574 | -- <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Response_Codes> | ||
575 | -- | ||
576 | parseFailureStatus :: ParamParseFailure -> Status | ||
577 | parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage | ||
578 | |||
579 | {----------------------------------------------------------------------- | ||
580 | Scrape message | ||
581 | -----------------------------------------------------------------------} | ||
582 | |||
583 | -- | Scrape query used to specify a set of torrent to scrape. | ||
584 | -- If list is empty then tracker should return scrape info about each | ||
585 | -- torrent. | ||
586 | type ScrapeQuery = [InfoHash] | ||
587 | |||
588 | -- TODO | ||
589 | -- data ScrapeQuery | ||
590 | -- = ScrapeAll | ||
591 | -- | ScrapeSingle InfoHash | ||
592 | -- | ScrapeMulti (HashSet InfoHash) | ||
593 | -- deriving (Show) | ||
594 | -- | ||
595 | -- data ScrapeInfo | ||
596 | -- = ScrapeAll (HashMap InfoHash ScrapeEntry) | ||
597 | -- | ScrapeSingle InfoHash ScrapeEntry | ||
598 | -- | ScrapeMulti (HashMap InfoHash ScrapeEntry) | ||
599 | -- | ||
600 | |||
601 | scrapeParam :: BS.ByteString | ||
602 | scrapeParam = "info_hash" | ||
603 | |||
604 | isScrapeParam :: BS.ByteString -> Bool | ||
605 | isScrapeParam = (==) scrapeParam | ||
606 | |||
607 | -- | Parse scrape query to query string. | ||
608 | parseScrapeQuery :: SimpleQuery -> ScrapeQuery | ||
609 | parseScrapeQuery | ||
610 | = catMaybes . L.map (fromParam . snd) . L.filter (isScrapeParam . fst) | ||
611 | |||
612 | -- | Render scrape query to query string. | ||
613 | renderScrapeQuery :: ScrapeQuery -> SimpleQuery | ||
614 | renderScrapeQuery = queryToSimpleQuery . L.map mkPair | ||
615 | where | ||
616 | mkPair ih = (scrapeParam, toQueryValue ih) | ||
617 | |||
618 | -- | Overall information about particular torrent. | ||
619 | data ScrapeEntry = ScrapeEntry { | ||
620 | -- | Number of seeders - peers with the entire file. | ||
621 | siComplete :: {-# UNPACK #-} !Int | ||
622 | |||
623 | -- | Total number of times the tracker has registered a completion. | ||
624 | , siDownloaded :: {-# UNPACK #-} !Int | ||
625 | |||
626 | -- | Number of leechers. | ||
627 | , siIncomplete :: {-# UNPACK #-} !Int | ||
628 | |||
629 | -- | Name of the torrent file, as specified by the "name" | ||
630 | -- file in the info section of the .torrent file. | ||
631 | , siName :: !(Maybe Text) | ||
632 | } deriving (Show, Eq, Typeable) | ||
633 | |||
634 | $(deriveJSON defaultOptions { fieldLabelModifier = (L.map toLower . L.dropWhile isLower) } ''ScrapeEntry) | ||
635 | |||
636 | -- | HTTP tracker protocol compatible encoding. | ||
637 | instance BEncode ScrapeEntry where | ||
638 | toBEncode ScrapeEntry {..} = toDict $ | ||
639 | "complete" .=! siComplete | ||
640 | .: "downloaded" .=! siDownloaded | ||
641 | .: "incomplete" .=! siIncomplete | ||
642 | .: "name" .=? siName | ||
643 | .: endDict | ||
644 | |||
645 | fromBEncode = fromDict $ ScrapeEntry | ||
646 | <$>! "complete" | ||
647 | <*>! "downloaded" | ||
648 | <*>! "incomplete" | ||
649 | <*>? "name" | ||
650 | |||
651 | -- | UDP tracker protocol compatible encoding. | ||
652 | instance Serialize ScrapeEntry where | ||
653 | put ScrapeEntry {..} = do | ||
654 | putWord32be $ fromIntegral siComplete | ||
655 | putWord32be $ fromIntegral siDownloaded | ||
656 | putWord32be $ fromIntegral siIncomplete | ||
657 | |||
658 | get = ScrapeEntry | ||
659 | <$> (fromIntegral <$> getWord32be) | ||
660 | <*> (fromIntegral <$> getWord32be) | ||
661 | <*> (fromIntegral <$> getWord32be) | ||
662 | <*> pure Nothing | ||
663 | |||
664 | -- | Scrape info about a set of torrents. | ||
665 | type ScrapeInfo = [(InfoHash, ScrapeEntry)] | ||