diff options
Diffstat (limited to 'dht/src/Network/BitTorrent/Tracker/Message.hs')
-rw-r--r-- | dht/src/Network/BitTorrent/Tracker/Message.hs | 929 |
1 files changed, 929 insertions, 0 deletions
diff --git a/dht/src/Network/BitTorrent/Tracker/Message.hs b/dht/src/Network/BitTorrent/Tracker/Message.hs new file mode 100644 index 00000000..e9d12006 --- /dev/null +++ b/dht/src/Network/BitTorrent/Tracker/Message.hs | |||
@@ -0,0 +1,929 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- (c) Daniel Gröber 2013 | ||
4 | -- License : BSD3 | ||
5 | -- Maintainer : pxqr.sta@gmail.com | ||
6 | -- Stability : experimental | ||
7 | -- Portability : portable | ||
8 | -- | ||
9 | -- Every tracker should support announce query. This query is used | ||
10 | -- to discover peers within a swarm and have two-fold effect: | ||
11 | -- | ||
12 | -- * peer doing announce discover other peers using peer list from | ||
13 | -- the response to the announce query. | ||
14 | -- | ||
15 | -- * tracker store peer information and use it in the succeeding | ||
16 | -- requests made by other peers, until the peer info expires. | ||
17 | -- | ||
18 | -- By convention most trackers support another form of request — | ||
19 | -- scrape query — which queries the state of a given torrent (or | ||
20 | -- a list of torrents) that the tracker is managing. | ||
21 | -- | ||
22 | {-# LANGUAGE FlexibleContexts #-} | ||
23 | {-# LANGUAGE FlexibleInstances #-} | ||
24 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
25 | {-# LANGUAGE TemplateHaskell #-} | ||
26 | {-# LANGUAGE DeriveDataTypeable #-} | ||
27 | {-# LANGUAGE DeriveFunctor #-} | ||
28 | {-# LANGUAGE ScopedTypeVariables #-} | ||
29 | {-# LANGUAGE TypeFamilies #-} | ||
30 | {-# LANGUAGE CPP #-} | ||
31 | {-# LANGUAGE PatternSynonyms #-} | ||
32 | {-# OPTIONS -fno-warn-orphans #-} | ||
33 | module Network.BitTorrent.Tracker.Message | ||
34 | ( -- * Announce | ||
35 | -- ** Query | ||
36 | AnnounceEvent (..) | ||
37 | , AnnounceQuery (..) | ||
38 | , renderAnnounceQuery | ||
39 | , ParamParseFailure | ||
40 | , parseAnnounceQuery | ||
41 | |||
42 | -- ** Info | ||
43 | , PeerList (..) | ||
44 | , getPeerList | ||
45 | , AnnounceInfo(..) | ||
46 | , defaultNumWant | ||
47 | , defaultMaxNumWant | ||
48 | , defaultReannounceInterval | ||
49 | |||
50 | -- * Scrape | ||
51 | -- ** Query | ||
52 | , ScrapeQuery | ||
53 | , renderScrapeQuery | ||
54 | , parseScrapeQuery | ||
55 | |||
56 | -- ** Info | ||
57 | , ScrapeEntry (..) | ||
58 | , ScrapeInfo | ||
59 | |||
60 | -- * HTTP specific | ||
61 | -- ** Routes | ||
62 | , PathPiece | ||
63 | , defaultAnnouncePath | ||
64 | , defaultScrapePath | ||
65 | |||
66 | -- ** Preferences | ||
67 | , AnnouncePrefs (..) | ||
68 | , renderAnnouncePrefs | ||
69 | , parseAnnouncePrefs | ||
70 | |||
71 | -- ** Request | ||
72 | , AnnounceRequest (..) | ||
73 | , parseAnnounceRequest | ||
74 | , renderAnnounceRequest | ||
75 | |||
76 | -- ** Response | ||
77 | , announceType | ||
78 | , scrapeType | ||
79 | , parseFailureStatus | ||
80 | |||
81 | -- ** Extra | ||
82 | , queryToSimpleQuery | ||
83 | |||
84 | -- * UDP specific | ||
85 | -- ** Connection | ||
86 | , ConnectionId | ||
87 | , initialConnectionId | ||
88 | |||
89 | -- ** Messages | ||
90 | , Request (..) | ||
91 | , Response (..) | ||
92 | , responseName | ||
93 | |||
94 | -- ** Transaction | ||
95 | , genTransactionId | ||
96 | , TransactionId | ||
97 | , Transaction (..) | ||
98 | |||
99 | , MessageId(ConnectId,AnnounceId,ScrapeId,ErrorId) | ||
100 | ) | ||
101 | where | ||
102 | |||
103 | import Control.Applicative | ||
104 | import Control.Monad | ||
105 | import Data.BEncode as BE hiding (Result) | ||
106 | import Data.BEncode.BDict as BE | ||
107 | import Data.ByteString as BS | ||
108 | import Data.ByteString.Char8 as BC | ||
109 | import Data.Char as Char | ||
110 | import Data.Convertible | ||
111 | import Data.Default | ||
112 | import Data.Either | ||
113 | import Data.List as L | ||
114 | import Data.Maybe | ||
115 | import Data.Monoid | ||
116 | import Data.Serialize as S hiding (Result) | ||
117 | import Data.String | ||
118 | import Data.Text (Text) | ||
119 | import Data.Text.Encoding | ||
120 | import Data.Typeable | ||
121 | import Data.Word | ||
122 | #if MIN_VERSION_iproute(1,7,4) | ||
123 | import Data.IP hiding (fromSockAddr) | ||
124 | #else | ||
125 | import Data.IP | ||
126 | #endif | ||
127 | import Network | ||
128 | import Network.HTTP.Types.QueryLike | ||
129 | import Network.HTTP.Types.URI hiding (urlEncode) | ||
130 | import Network.HTTP.Types.Status | ||
131 | import Network.Socket hiding (Connected) | ||
132 | import Numeric | ||
133 | import System.Entropy | ||
134 | import Text.Read (readMaybe) | ||
135 | |||
136 | import Data.Torrent | ||
137 | import Network.Address | ||
138 | import Network.BitTorrent.Internal.Progress | ||
139 | |||
140 | {----------------------------------------------------------------------- | ||
141 | -- Events | ||
142 | -----------------------------------------------------------------------} | ||
143 | |||
144 | -- | Events are used to specify which kind of announce query is performed. | ||
145 | data AnnounceEvent | ||
146 | -- | For the first request: when download first begins. | ||
147 | = Started | ||
148 | |||
149 | -- | This peer stopped downloading /and/ uploading the torrent or | ||
150 | -- just shutting down. | ||
151 | | Stopped | ||
152 | |||
153 | -- | This peer completed downloading the torrent. This only happen | ||
154 | -- right after last piece have been verified. No 'Completed' is | ||
155 | -- sent if the file was completed when 'Started'. | ||
156 | | Completed | ||
157 | deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) | ||
158 | |||
159 | -- | HTTP tracker protocol compatible encoding. | ||
160 | instance QueryValueLike AnnounceEvent where | ||
161 | toQueryValue e = toQueryValue (Char.toLower x : xs) | ||
162 | where | ||
163 | (x : xs) = show e -- INVARIANT: this is always nonempty list | ||
164 | |||
165 | type EventId = Word32 | ||
166 | |||
167 | -- | UDP tracker encoding event codes. | ||
168 | eventId :: AnnounceEvent -> EventId | ||
169 | eventId Completed = 1 | ||
170 | eventId Started = 2 | ||
171 | eventId Stopped = 3 | ||
172 | |||
173 | -- TODO add Regular event | ||
174 | putEvent :: Putter (Maybe AnnounceEvent) | ||
175 | putEvent Nothing = putWord32be 0 | ||
176 | putEvent (Just e) = putWord32be (eventId e) | ||
177 | |||
178 | getEvent :: S.Get (Maybe AnnounceEvent) | ||
179 | getEvent = do | ||
180 | eid <- getWord32be | ||
181 | case eid of | ||
182 | 0 -> return Nothing | ||
183 | 1 -> return $ Just Completed | ||
184 | 2 -> return $ Just Started | ||
185 | 3 -> return $ Just Stopped | ||
186 | _ -> fail "unknown event id" | ||
187 | |||
188 | {----------------------------------------------------------------------- | ||
189 | Announce query | ||
190 | -----------------------------------------------------------------------} | ||
191 | -- TODO add &ipv6= and &ipv4= params to AnnounceQuery | ||
192 | -- http://www.bittorrent.org/beps/bep_0007.html#announce-parameter | ||
193 | |||
194 | -- | A tracker request is HTTP GET request; used to include metrics | ||
195 | -- from clients that help the tracker keep overall statistics about | ||
196 | -- the torrent. The most important, requests are used by the tracker | ||
197 | -- to keep track lists of active peer for a particular torrent. | ||
198 | -- | ||
199 | data AnnounceQuery = AnnounceQuery | ||
200 | { | ||
201 | -- | Hash of info part of the torrent usually obtained from | ||
202 | -- 'Torrent' or 'Magnet'. | ||
203 | reqInfoHash :: !InfoHash | ||
204 | |||
205 | -- | ID of the peer doing request. | ||
206 | , reqPeerId :: !PeerId | ||
207 | |||
208 | -- | Port to listen to for connections from other | ||
209 | -- peers. Tracker should respond with this port when | ||
210 | -- some /other/ peer request the tracker with the same info hash. | ||
211 | -- Normally, this port is choosed from 'defaultPorts'. | ||
212 | , reqPort :: !PortNumber | ||
213 | |||
214 | -- | Current progress of peer doing request. | ||
215 | , reqProgress :: !Progress | ||
216 | |||
217 | -- | The peer IP. Needed only when client communicated with | ||
218 | -- tracker throught a proxy. | ||
219 | , reqIP :: Maybe HostAddress | ||
220 | |||
221 | -- | Number of peers that the peers wants to receive from. It is | ||
222 | -- optional for trackers to honor this limit. See note for | ||
223 | -- 'defaultNumWant'. | ||
224 | , reqNumWant :: Maybe Int | ||
225 | |||
226 | -- | If not specified, the request is regular periodic | ||
227 | -- request. Regular request should be sent | ||
228 | , reqEvent :: Maybe AnnounceEvent | ||
229 | } deriving (Show, Eq, Typeable) | ||
230 | |||
231 | -- | UDP tracker protocol compatible encoding. | ||
232 | instance Serialize AnnounceQuery where | ||
233 | put AnnounceQuery {..} = do | ||
234 | put reqInfoHash | ||
235 | put reqPeerId | ||
236 | put reqProgress | ||
237 | putEvent reqEvent | ||
238 | putWord32host $ fromMaybe 0 reqIP | ||
239 | putWord32be $ 0 -- TODO what the fuck is "key"? | ||
240 | putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant | ||
241 | |||
242 | put reqPort | ||
243 | |||
244 | get = do | ||
245 | ih <- get | ||
246 | pid <- get | ||
247 | |||
248 | progress <- get | ||
249 | |||
250 | ev <- getEvent | ||
251 | ip <- getWord32be | ||
252 | -- key <- getWord32be -- TODO | ||
253 | want <- getWord32be | ||
254 | |||
255 | port <- get | ||
256 | |||
257 | return $ AnnounceQuery { | ||
258 | reqInfoHash = ih | ||
259 | , reqPeerId = pid | ||
260 | , reqPort = port | ||
261 | , reqProgress = progress | ||
262 | , reqIP = if ip == 0 then Nothing else Just ip | ||
263 | , reqNumWant = if want == maxBound then Nothing | ||
264 | else Just (fromIntegral want) | ||
265 | , reqEvent = ev | ||
266 | } | ||
267 | |||
268 | instance QueryValueLike PortNumber where | ||
269 | toQueryValue = toQueryValue . show . fromEnum | ||
270 | |||
271 | instance QueryValueLike Word32 where | ||
272 | toQueryValue = toQueryValue . show | ||
273 | |||
274 | instance QueryValueLike Int where | ||
275 | toQueryValue = toQueryValue . show | ||
276 | |||
277 | -- | HTTP tracker protocol compatible encoding. | ||
278 | instance QueryLike AnnounceQuery where | ||
279 | toQuery AnnounceQuery {..} = | ||
280 | toQuery reqProgress ++ | ||
281 | [ ("info_hash", toQueryValue reqInfoHash) -- TODO use 'paramName' | ||
282 | , ("peer_id" , toQueryValue reqPeerId) | ||
283 | , ("port" , toQueryValue reqPort) | ||
284 | , ("ip" , toQueryValue reqIP) | ||
285 | , ("numwant" , toQueryValue reqNumWant) | ||
286 | , ("event" , toQueryValue reqEvent) | ||
287 | ] | ||
288 | |||
289 | -- | Filter @param=value@ pairs with the unset value. | ||
290 | queryToSimpleQuery :: Query -> SimpleQuery | ||
291 | queryToSimpleQuery = catMaybes . L.map f | ||
292 | where | ||
293 | f (_, Nothing) = Nothing | ||
294 | f (a, Just b ) = Just (a, b) | ||
295 | |||
296 | -- | Encode announce query to query string. | ||
297 | renderAnnounceQuery :: AnnounceQuery -> SimpleQuery | ||
298 | renderAnnounceQuery = queryToSimpleQuery . toQuery | ||
299 | |||
300 | data QueryParam | ||
301 | -- announce query | ||
302 | = ParamInfoHash | ||
303 | | ParamPeerId | ||
304 | | ParamPort | ||
305 | | ParamUploaded | ||
306 | | ParamLeft | ||
307 | | ParamDownloaded | ||
308 | | ParamIP | ||
309 | | ParamNumWant | ||
310 | | ParamEvent | ||
311 | -- announce query ext | ||
312 | | ParamCompact | ||
313 | | ParamNoPeerId | ||
314 | deriving (Show, Eq, Ord, Enum) | ||
315 | |||
316 | paramName :: QueryParam -> BS.ByteString | ||
317 | paramName ParamInfoHash = "info_hash" | ||
318 | paramName ParamPeerId = "peer_id" | ||
319 | paramName ParamPort = "port" | ||
320 | paramName ParamUploaded = "uploaded" | ||
321 | paramName ParamLeft = "left" | ||
322 | paramName ParamDownloaded = "downloaded" | ||
323 | paramName ParamIP = "ip" | ||
324 | paramName ParamNumWant = "numwant" | ||
325 | paramName ParamEvent = "event" | ||
326 | paramName ParamCompact = "compact" | ||
327 | paramName ParamNoPeerId = "no_peer_id" | ||
328 | {-# INLINE paramName #-} | ||
329 | |||
330 | class FromParam a where | ||
331 | fromParam :: BS.ByteString -> Maybe a | ||
332 | |||
333 | instance FromParam Bool where | ||
334 | fromParam "0" = Just False | ||
335 | fromParam "1" = Just True | ||
336 | fromParam _ = Nothing | ||
337 | |||
338 | instance FromParam InfoHash where | ||
339 | fromParam = either (const Nothing) pure . safeConvert | ||
340 | |||
341 | instance FromParam PeerId where | ||
342 | fromParam = either (const Nothing) pure . safeConvert | ||
343 | |||
344 | instance FromParam Word32 where | ||
345 | fromParam = readMaybe . BC.unpack | ||
346 | |||
347 | instance FromParam Word64 where | ||
348 | fromParam = readMaybe . BC.unpack | ||
349 | |||
350 | instance FromParam Int where | ||
351 | fromParam = readMaybe . BC.unpack | ||
352 | |||
353 | instance FromParam PortNumber where | ||
354 | fromParam bs = fromIntegral <$> (fromParam bs :: Maybe Word32) | ||
355 | |||
356 | instance FromParam AnnounceEvent where | ||
357 | fromParam bs = do | ||
358 | (x, xs) <- BC.uncons bs | ||
359 | readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs | ||
360 | |||
361 | -- | 'ParamParseFailure' represent errors can occur while parsing HTTP | ||
362 | -- tracker requests. In case of failure, this can be used to provide | ||
363 | -- more informative 'statusCode' and 'statusMessage' in tracker | ||
364 | -- responses. | ||
365 | -- | ||
366 | data ParamParseFailure | ||
367 | = Missing QueryParam -- ^ param not found in query string; | ||
368 | | Invalid QueryParam BS.ByteString -- ^ param present but not valid. | ||
369 | deriving (Show, Eq) | ||
370 | |||
371 | type ParseResult = Either ParamParseFailure | ||
372 | |||
373 | withError :: ParamParseFailure -> Maybe a -> ParseResult a | ||
374 | withError e = maybe (Left e) Right | ||
375 | |||
376 | reqParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult a | ||
377 | reqParam param xs = do | ||
378 | val <- withError (Missing param) $ L.lookup (paramName param) xs | ||
379 | withError (Invalid param val) (fromParam val) | ||
380 | |||
381 | optParam :: FromParam a => QueryParam -> SimpleQuery -> ParseResult (Maybe a) | ||
382 | optParam param ps | ||
383 | | Just x <- L.lookup (paramName param) ps | ||
384 | = pure <$> withError (Invalid param x) (fromParam x) | ||
385 | | otherwise = pure Nothing | ||
386 | |||
387 | parseProgress :: SimpleQuery -> ParseResult Progress | ||
388 | parseProgress params = Progress | ||
389 | <$> reqParam ParamDownloaded params | ||
390 | <*> reqParam ParamLeft params | ||
391 | <*> reqParam ParamUploaded params | ||
392 | |||
393 | -- | Parse announce request from a query string. | ||
394 | parseAnnounceQuery :: SimpleQuery -> ParseResult AnnounceQuery | ||
395 | parseAnnounceQuery params = AnnounceQuery | ||
396 | <$> reqParam ParamInfoHash params | ||
397 | <*> reqParam ParamPeerId params | ||
398 | <*> reqParam ParamPort params | ||
399 | <*> parseProgress params | ||
400 | <*> optParam ParamIP params | ||
401 | <*> optParam ParamNumWant params | ||
402 | <*> optParam ParamEvent params | ||
403 | |||
404 | {----------------------------------------------------------------------- | ||
405 | -- Announce Info | ||
406 | -----------------------------------------------------------------------} | ||
407 | -- TODO check if announceinterval/complete/incomplete is positive ints | ||
408 | |||
409 | -- | Tracker can return peer list in either compact(BEP23) or not | ||
410 | -- compact form. | ||
411 | -- | ||
412 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
413 | -- | ||
414 | data PeerList ip | ||
415 | = PeerList [PeerAddr] | ||
416 | | CompactPeerList [PeerAddr] | ||
417 | deriving (Show, Eq, Typeable, Functor) | ||
418 | |||
419 | -- | The empty non-compact peer list. | ||
420 | instance Default (PeerList IP) where | ||
421 | def = PeerList [] | ||
422 | {-# INLINE def #-} | ||
423 | |||
424 | getPeerList :: PeerList IP -> [PeerAddr] | ||
425 | getPeerList (PeerList xs) = xs | ||
426 | getPeerList (CompactPeerList xs) = xs | ||
427 | |||
428 | instance BEncode (PeerList a) where | ||
429 | toBEncode (PeerList xs) = toBEncode xs | ||
430 | toBEncode (CompactPeerList xs) = toBEncode $ runPut (mapM_ put xs) | ||
431 | |||
432 | fromBEncode (BList l ) = PeerList <$> fromBEncode (BList l) | ||
433 | fromBEncode (BString s ) = CompactPeerList <$> runGet (many get) s | ||
434 | fromBEncode _ = decodingError "PeerList: should be a BString or BList" | ||
435 | |||
436 | -- | The tracker response includes a peer list that helps the client | ||
437 | -- participate in the torrent. The most important is 'respPeer' list | ||
438 | -- used to join the swarm. | ||
439 | -- | ||
440 | data AnnounceInfo = | ||
441 | Failure !Text -- ^ Failure reason in human readable form. | ||
442 | | AnnounceInfo { | ||
443 | -- | Number of peers completed the torrent. (seeders) | ||
444 | respComplete :: !(Maybe Int) | ||
445 | |||
446 | -- | Number of peers downloading the torrent. (leechers) | ||
447 | , respIncomplete :: !(Maybe Int) | ||
448 | |||
449 | -- | Recommended interval to wait between requests, in seconds. | ||
450 | , respInterval :: !Int | ||
451 | |||
452 | -- | Minimal amount of time between requests, in seconds. A | ||
453 | -- peer /should/ make timeout with at least 'respMinInterval' | ||
454 | -- value, otherwise tracker might not respond. If not specified | ||
455 | -- the same applies to 'respInterval'. | ||
456 | , respMinInterval :: !(Maybe Int) | ||
457 | |||
458 | -- | Peers that must be contacted. | ||
459 | , respPeers :: !(PeerList IP) | ||
460 | |||
461 | -- | Human readable warning. | ||
462 | , respWarning :: !(Maybe Text) | ||
463 | } deriving (Show, Eq, Typeable) | ||
464 | |||
465 | -- | Empty peer list with default reannounce interval. | ||
466 | instance Default AnnounceInfo where | ||
467 | def = AnnounceInfo | ||
468 | { respComplete = Nothing | ||
469 | , respIncomplete = Nothing | ||
470 | , respInterval = defaultReannounceInterval | ||
471 | , respMinInterval = Nothing | ||
472 | , respPeers = def | ||
473 | , respWarning = Nothing | ||
474 | } | ||
475 | |||
476 | -- | HTTP tracker protocol compatible encoding. | ||
477 | instance BEncode AnnounceInfo where | ||
478 | toBEncode (Failure t) = toDict $ | ||
479 | "failure reason" .=! t | ||
480 | .: endDict | ||
481 | |||
482 | toBEncode AnnounceInfo {..} = toDict $ | ||
483 | "complete" .=? respComplete | ||
484 | .: "incomplete" .=? respIncomplete | ||
485 | .: "interval" .=! respInterval | ||
486 | .: "min interval" .=? respMinInterval | ||
487 | .: "peers" .=! peers | ||
488 | .: "peers6" .=? peers6 | ||
489 | .: "warning message" .=? respWarning | ||
490 | .: endDict | ||
491 | where | ||
492 | (peers, peers6) = prttn respPeers | ||
493 | |||
494 | prttn :: PeerList IP -> (PeerList IPv4, Maybe (PeerList IPv6)) | ||
495 | prttn (PeerList xs) = (PeerList xs, Nothing) | ||
496 | prttn (CompactPeerList xs) = mk $ partitionEithers $ toEither <$> xs | ||
497 | where | ||
498 | mk (v4s, v6s) | ||
499 | | L.null v6s = (CompactPeerList v4s, Nothing) | ||
500 | | otherwise = (CompactPeerList v4s, Just (CompactPeerList v6s)) | ||
501 | |||
502 | toEither :: PeerAddr -> Either PeerAddr PeerAddr | ||
503 | toEither PeerAddr {..} = case peerHost of | ||
504 | ipv4@IPv4{} -> Left $ PeerAddr peerId ipv4 peerPort | ||
505 | ipv6@IPv6{} -> Right $ PeerAddr peerId ipv6 peerPort | ||
506 | |||
507 | fromBEncode (BDict d) | ||
508 | | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t | ||
509 | | otherwise = (`fromDict` (BDict d)) $ | ||
510 | AnnounceInfo | ||
511 | <$>? "complete" | ||
512 | <*>? "incomplete" | ||
513 | <*>! "interval" | ||
514 | <*>? "min interval" | ||
515 | <*> (uncurry merge =<< (,) <$>! "peers" <*>? "peers6") | ||
516 | <*>? "warning message" | ||
517 | where | ||
518 | merge :: PeerList IPv4 -> Maybe (PeerList IPv6) -> BE.Get (PeerList IP) | ||
519 | merge (PeerList ips) Nothing = pure (PeerList ips) | ||
520 | merge (PeerList _ ) (Just _) | ||
521 | = fail "PeerList: non-compact peer list provided, but the `peers6' field present" | ||
522 | |||
523 | merge (CompactPeerList ipv4s) Nothing | ||
524 | = pure $ CompactPeerList ipv4s | ||
525 | |||
526 | merge (CompactPeerList _ ) (Just (PeerList _)) | ||
527 | = fail "PeerList: the `peers6' field value should contain *compact* peer list" | ||
528 | |||
529 | merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s)) | ||
530 | = pure $ CompactPeerList $ | ||
531 | ipv4s <> ipv6s | ||
532 | |||
533 | fromBEncode _ = decodingError "Announce info" | ||
534 | |||
535 | -- | UDP tracker protocol compatible encoding. | ||
536 | instance Serialize AnnounceInfo where | ||
537 | put (Failure msg) = put $ encodeUtf8 msg | ||
538 | put AnnounceInfo {..} = do | ||
539 | putWord32be $ fromIntegral respInterval | ||
540 | putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete | ||
541 | putWord32be $ fromIntegral $ fromMaybe 0 respComplete | ||
542 | forM_ (getPeerList respPeers) put | ||
543 | |||
544 | get = do | ||
545 | interval <- getWord32be | ||
546 | leechers <- getWord32be | ||
547 | seeders <- getWord32be | ||
548 | peers <- many $ isolate 6 get -- isolated to specify IPv4. | ||
549 | |||
550 | return $ AnnounceInfo { | ||
551 | respWarning = Nothing | ||
552 | , respInterval = fromIntegral interval | ||
553 | , respMinInterval = Nothing | ||
554 | , respIncomplete = Just $ fromIntegral leechers | ||
555 | , respComplete = Just $ fromIntegral seeders | ||
556 | , respPeers = PeerList peers | ||
557 | } | ||
558 | |||
559 | -- | Decodes announce response from bencoded string, for debugging only. | ||
560 | instance IsString AnnounceInfo where | ||
561 | fromString str = either (error . format) id $ BE.decode (fromString str) | ||
562 | where | ||
563 | format msg = "fromString: unable to decode AnnounceInfo: " ++ msg | ||
564 | |||
565 | -- | Above 25, new peers are highly unlikely to increase download | ||
566 | -- speed. Even 30 peers is /plenty/, the official client version 3 | ||
567 | -- in fact only actively forms new connections if it has less than | ||
568 | -- 30 peers and will refuse connections if it has 55. | ||
569 | -- | ||
570 | -- <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Basic_Tracker_Announce_Request> | ||
571 | -- | ||
572 | defaultNumWant :: Int | ||
573 | defaultNumWant = 50 | ||
574 | |||
575 | -- | Reasonable upper bound of numwant parameter. | ||
576 | defaultMaxNumWant :: Int | ||
577 | defaultMaxNumWant = 200 | ||
578 | |||
579 | -- | Widely used reannounce interval. Note: tracker clients should not | ||
580 | -- use this value! | ||
581 | defaultReannounceInterval :: Int | ||
582 | defaultReannounceInterval = 30 * 60 | ||
583 | |||
584 | {----------------------------------------------------------------------- | ||
585 | Scrape message | ||
586 | -----------------------------------------------------------------------} | ||
587 | |||
588 | -- | Scrape query used to specify a set of torrent to scrape. | ||
589 | -- If list is empty then tracker should return scrape info about each | ||
590 | -- torrent. | ||
591 | type ScrapeQuery = [InfoHash] | ||
592 | |||
593 | -- TODO | ||
594 | -- data ScrapeQuery | ||
595 | -- = ScrapeAll | ||
596 | -- | ScrapeSingle InfoHash | ||
597 | -- | ScrapeMulti (HashSet InfoHash) | ||
598 | -- deriving (Show) | ||
599 | -- | ||
600 | -- data ScrapeInfo | ||
601 | -- = ScrapeAll (HashMap InfoHash ScrapeEntry) | ||
602 | -- | ScrapeSingle InfoHash ScrapeEntry | ||
603 | -- | ScrapeMulti (HashMap InfoHash ScrapeEntry) | ||
604 | -- | ||
605 | |||
606 | scrapeParam :: BS.ByteString | ||
607 | scrapeParam = "info_hash" | ||
608 | |||
609 | isScrapeParam :: BS.ByteString -> Bool | ||
610 | isScrapeParam = (==) scrapeParam | ||
611 | |||
612 | -- | Parse scrape query to query string. | ||
613 | parseScrapeQuery :: SimpleQuery -> ScrapeQuery | ||
614 | parseScrapeQuery | ||
615 | = catMaybes . L.map (fromParam . snd) . L.filter (isScrapeParam . fst) | ||
616 | |||
617 | -- | Render scrape query to query string. | ||
618 | renderScrapeQuery :: ScrapeQuery -> SimpleQuery | ||
619 | renderScrapeQuery = queryToSimpleQuery . L.map mkPair | ||
620 | where | ||
621 | mkPair ih = (scrapeParam, toQueryValue ih) | ||
622 | |||
623 | -- | Overall information about particular torrent. | ||
624 | data ScrapeEntry = ScrapeEntry { | ||
625 | -- | Number of seeders - peers with the entire file. | ||
626 | siComplete :: {-# UNPACK #-} !Int | ||
627 | |||
628 | -- | Total number of times the tracker has registered a completion. | ||
629 | , siDownloaded :: {-# UNPACK #-} !Int | ||
630 | |||
631 | -- | Number of leechers. | ||
632 | , siIncomplete :: {-# UNPACK #-} !Int | ||
633 | |||
634 | -- | Name of the torrent file, as specified by the "name" | ||
635 | -- file in the info section of the .torrent file. | ||
636 | , siName :: !(Maybe Text) | ||
637 | } deriving (Show, Eq, Typeable) | ||
638 | |||
639 | -- | HTTP tracker protocol compatible encoding. | ||
640 | instance BEncode ScrapeEntry where | ||
641 | toBEncode ScrapeEntry {..} = toDict $ | ||
642 | "complete" .=! siComplete | ||
643 | .: "downloaded" .=! siDownloaded | ||
644 | .: "incomplete" .=! siIncomplete | ||
645 | .: "name" .=? siName | ||
646 | .: endDict | ||
647 | |||
648 | fromBEncode = fromDict $ ScrapeEntry | ||
649 | <$>! "complete" | ||
650 | <*>! "downloaded" | ||
651 | <*>! "incomplete" | ||
652 | <*>? "name" | ||
653 | |||
654 | -- | UDP tracker protocol compatible encoding. | ||
655 | instance Serialize ScrapeEntry where | ||
656 | put ScrapeEntry {..} = do | ||
657 | putWord32be $ fromIntegral siComplete | ||
658 | putWord32be $ fromIntegral siDownloaded | ||
659 | putWord32be $ fromIntegral siIncomplete | ||
660 | |||
661 | get = ScrapeEntry | ||
662 | <$> (fromIntegral <$> getWord32be) | ||
663 | <*> (fromIntegral <$> getWord32be) | ||
664 | <*> (fromIntegral <$> getWord32be) | ||
665 | <*> pure Nothing | ||
666 | |||
667 | -- | Scrape info about a set of torrents. | ||
668 | type ScrapeInfo = [(InfoHash, ScrapeEntry)] | ||
669 | |||
670 | {----------------------------------------------------------------------- | ||
671 | -- HTTP specific | ||
672 | -----------------------------------------------------------------------} | ||
673 | |||
674 | -- | Some HTTP trackers allow to choose prefered representation of the | ||
675 | -- 'AnnounceInfo'. It's optional for trackers to honor any of this | ||
676 | -- options. | ||
677 | data AnnouncePrefs = AnnouncePrefs | ||
678 | { -- | If specified, "compact" parameter is used to advise the | ||
679 | -- tracker to send peer id list as: | ||
680 | -- | ||
681 | -- * bencoded list (extCompact = Just False); | ||
682 | -- * or more compact binary string (extCompact = Just True). | ||
683 | -- | ||
684 | -- The later is prefered since compact peer list will reduce the | ||
685 | -- size of tracker responses. Hovewer, if tracker do not support | ||
686 | -- this extension then it can return peer list in either form. | ||
687 | -- | ||
688 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | ||
689 | -- | ||
690 | extCompact :: !(Maybe Bool) | ||
691 | |||
692 | -- | If specified, "no_peer_id" parameter is used advise tracker | ||
693 | -- to either send or not to send peer id in tracker response. | ||
694 | -- Tracker may not support this extension as well. | ||
695 | -- | ||
696 | -- For more info see: | ||
697 | -- <http://permalink.gmane.org/gmane.network.bit-torrent.general/4030> | ||
698 | -- | ||
699 | , extNoPeerId :: !(Maybe Bool) | ||
700 | } deriving (Show, Eq, Typeable) | ||
701 | |||
702 | instance Default AnnouncePrefs where | ||
703 | def = AnnouncePrefs Nothing Nothing | ||
704 | |||
705 | instance QueryLike AnnouncePrefs where | ||
706 | toQuery AnnouncePrefs {..} = | ||
707 | [ ("compact", toQueryFlag <$> extCompact) -- TODO use 'paramName' | ||
708 | , ("no_peer_id", toQueryFlag <$> extNoPeerId) | ||
709 | ] | ||
710 | where | ||
711 | toQueryFlag False = "0" | ||
712 | toQueryFlag True = "1" | ||
713 | |||
714 | -- | Parse announce query extended part from query string. | ||
715 | parseAnnouncePrefs :: SimpleQuery -> AnnouncePrefs | ||
716 | parseAnnouncePrefs params = either (const def) id $ | ||
717 | AnnouncePrefs | ||
718 | <$> optParam ParamCompact params | ||
719 | <*> optParam ParamNoPeerId params | ||
720 | |||
721 | -- | Render announce preferences to query string. | ||
722 | renderAnnouncePrefs :: AnnouncePrefs -> SimpleQuery | ||
723 | renderAnnouncePrefs = queryToSimpleQuery . toQuery | ||
724 | |||
725 | -- | HTTP tracker request with preferences. | ||
726 | data AnnounceRequest = AnnounceRequest | ||
727 | { announceQuery :: AnnounceQuery -- ^ Request query params. | ||
728 | , announcePrefs :: AnnouncePrefs -- ^ Optional advises to the tracker. | ||
729 | } deriving (Show, Eq, Typeable) | ||
730 | |||
731 | instance QueryLike AnnounceRequest where | ||
732 | toQuery AnnounceRequest{..} = | ||
733 | toQuery announcePrefs <> | ||
734 | toQuery announceQuery | ||
735 | |||
736 | -- | Parse announce request from query string. | ||
737 | parseAnnounceRequest :: SimpleQuery -> ParseResult AnnounceRequest | ||
738 | parseAnnounceRequest params = AnnounceRequest | ||
739 | <$> parseAnnounceQuery params | ||
740 | <*> pure (parseAnnouncePrefs params) | ||
741 | |||
742 | -- | Render announce request to query string. | ||
743 | renderAnnounceRequest :: AnnounceRequest -> SimpleQuery | ||
744 | renderAnnounceRequest = queryToSimpleQuery . toQuery | ||
745 | |||
746 | type PathPiece = BS.ByteString | ||
747 | |||
748 | defaultAnnouncePath :: PathPiece | ||
749 | defaultAnnouncePath = "announce" | ||
750 | |||
751 | defaultScrapePath :: PathPiece | ||
752 | defaultScrapePath = "scrape" | ||
753 | |||
754 | missingOffset :: Int | ||
755 | missingOffset = 101 | ||
756 | |||
757 | invalidOffset :: Int | ||
758 | invalidOffset = 150 | ||
759 | |||
760 | parseFailureCode :: ParamParseFailure -> Int | ||
761 | parseFailureCode (Missing param ) = missingOffset + fromEnum param | ||
762 | parseFailureCode (Invalid param _) = invalidOffset + fromEnum param | ||
763 | |||
764 | parseFailureMessage :: ParamParseFailure -> BS.ByteString | ||
765 | parseFailureMessage e = BS.concat $ case e of | ||
766 | Missing p -> ["Missing parameter: ", paramName p] | ||
767 | Invalid p v -> ["Invalid parameter: ", paramName p, " = ", v] | ||
768 | |||
769 | -- | HTTP response /content type/ for announce info. | ||
770 | announceType :: ByteString | ||
771 | announceType = "text/plain" | ||
772 | |||
773 | -- | HTTP response /content type/ for scrape info. | ||
774 | scrapeType :: ByteString | ||
775 | scrapeType = "text/plain" | ||
776 | |||
777 | -- | Get HTTP response status from a announce params parse failure. | ||
778 | -- | ||
779 | -- For more info see: | ||
780 | -- <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Response_Codes> | ||
781 | -- | ||
782 | parseFailureStatus :: ParamParseFailure -> Status | ||
783 | parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage | ||
784 | |||
785 | {----------------------------------------------------------------------- | ||
786 | -- UDP specific message types | ||
787 | -----------------------------------------------------------------------} | ||
788 | |||
789 | genToken :: IO Word64 | ||
790 | genToken = do | ||
791 | bs <- getEntropy 8 | ||
792 | either err return $ runGet getWord64be bs | ||
793 | where | ||
794 | err = error "genToken: impossible happen" | ||
795 | |||
796 | -- | Connection Id is used for entire tracker session. | ||
797 | newtype ConnectionId = ConnectionId Word64 | ||
798 | deriving (Eq, Serialize) | ||
799 | |||
800 | instance Show ConnectionId where | ||
801 | showsPrec _ (ConnectionId cid) = showString "0x" <> showHex cid | ||
802 | |||
803 | initialConnectionId :: ConnectionId | ||
804 | initialConnectionId = ConnectionId 0x41727101980 | ||
805 | |||
806 | -- | Transaction Id is used within a UDP RPC. | ||
807 | newtype TransactionId = TransactionId Word32 | ||
808 | deriving (Eq, Ord, Enum, Bounded, Serialize) | ||
809 | |||
810 | instance Show TransactionId where | ||
811 | showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid | ||
812 | |||
813 | genTransactionId :: IO TransactionId | ||
814 | genTransactionId = (TransactionId . fromIntegral) <$> genToken | ||
815 | |||
816 | data Request | ||
817 | = Connect | ||
818 | | Announce AnnounceQuery | ||
819 | | Scrape ScrapeQuery | ||
820 | deriving Show | ||
821 | |||
822 | data Response | ||
823 | = Connected ConnectionId | ||
824 | | Announced AnnounceInfo | ||
825 | | Scraped [ScrapeEntry] | ||
826 | | Failed Text | ||
827 | deriving Show | ||
828 | |||
829 | responseName :: Response -> String | ||
830 | responseName (Connected _) = "connected" | ||
831 | responseName (Announced _) = "announced" | ||
832 | responseName (Scraped _) = "scraped" | ||
833 | responseName (Failed _) = "failed" | ||
834 | |||
835 | data family Transaction a | ||
836 | data instance Transaction Request = TransactionQ | ||
837 | { connIdQ :: {-# UNPACK #-} !ConnectionId | ||
838 | , transIdQ :: {-# UNPACK #-} !TransactionId | ||
839 | , request :: !Request | ||
840 | } deriving Show | ||
841 | data instance Transaction Response = TransactionR | ||
842 | { transIdR :: {-# UNPACK #-} !TransactionId | ||
843 | , response :: !Response | ||
844 | } deriving Show | ||
845 | |||
846 | -- TODO newtype | ||
847 | newtype MessageId = MessageId Word32 | ||
848 | deriving (Show, Eq, Num, Serialize) | ||
849 | |||
850 | pattern ConnectId :: MessageId | ||
851 | pattern ConnectId = MessageId 0 | ||
852 | pattern AnnounceId :: MessageId | ||
853 | pattern AnnounceId = MessageId 1 | ||
854 | pattern ScrapeId :: MessageId | ||
855 | pattern ScrapeId = MessageId 2 | ||
856 | pattern ErrorId :: MessageId | ||
857 | pattern ErrorId = MessageId 3 | ||
858 | |||
859 | instance Serialize (Transaction Request) where | ||
860 | put TransactionQ {..} = do | ||
861 | case request of | ||
862 | Connect -> do | ||
863 | put initialConnectionId | ||
864 | put ConnectId | ||
865 | put transIdQ | ||
866 | |||
867 | Announce ann -> do | ||
868 | put connIdQ | ||
869 | put AnnounceId | ||
870 | put transIdQ | ||
871 | put ann | ||
872 | |||
873 | Scrape hashes -> do | ||
874 | put connIdQ | ||
875 | put ScrapeId | ||
876 | put transIdQ | ||
877 | forM_ hashes put | ||
878 | |||
879 | get = do | ||
880 | cid <- get | ||
881 | mid <- get | ||
882 | TransactionQ cid <$> S.get <*> getBody mid | ||
883 | where | ||
884 | getBody :: MessageId -> S.Get Request | ||
885 | getBody msgId | ||
886 | | msgId == ConnectId = pure Connect | ||
887 | | msgId == AnnounceId = Announce <$> get | ||
888 | | msgId == ScrapeId = Scrape <$> many get | ||
889 | | otherwise = fail errMsg | ||
890 | where | ||
891 | errMsg = "unknown request: " ++ show msgId | ||
892 | |||
893 | instance Serialize (Transaction Response) where | ||
894 | put TransactionR {..} = do | ||
895 | case response of | ||
896 | Connected conn -> do | ||
897 | put ConnectId | ||
898 | put transIdR | ||
899 | put conn | ||
900 | |||
901 | Announced info -> do | ||
902 | put AnnounceId | ||
903 | put transIdR | ||
904 | put info | ||
905 | |||
906 | Scraped infos -> do | ||
907 | put ScrapeId | ||
908 | put transIdR | ||
909 | forM_ infos put | ||
910 | |||
911 | Failed info -> do | ||
912 | put ErrorId | ||
913 | put transIdR | ||
914 | put (encodeUtf8 info) | ||
915 | |||
916 | |||
917 | get = do | ||
918 | mid <- get | ||
919 | TransactionR <$> get <*> getBody mid | ||
920 | where | ||
921 | getBody :: MessageId -> S.Get Response | ||
922 | getBody msgId | ||
923 | | msgId == ConnectId = Connected <$> get | ||
924 | | msgId == AnnounceId = Announced <$> get | ||
925 | | msgId == ScrapeId = Scraped <$> many get | ||
926 | | msgId == ErrorId = (Failed . decodeUtf8) <$> get | ||
927 | | otherwise = fail msg | ||
928 | where | ||
929 | msg = "unknown response: " ++ show msgId | ||