summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/Tracker/Message.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/Tracker/Message.hs')
-rw-r--r--src/Network/BitTorrent/Tracker/Message.hs41
1 files changed, 19 insertions, 22 deletions
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index fe7686cb..95b9c7ca 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -22,6 +22,8 @@
22{-# LANGUAGE GeneralizedNewtypeDeriving #-} 22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23{-# LANGUAGE TemplateHaskell #-} 23{-# LANGUAGE TemplateHaskell #-}
24{-# LANGUAGE DeriveDataTypeable #-} 24{-# LANGUAGE DeriveDataTypeable #-}
25{-# LANGUAGE DeriveFunctor #-}
26{-# LANGUAGE ScopedTypeVariables #-}
25{-# OPTIONS -fno-warn-orphans #-} 27{-# OPTIONS -fno-warn-orphans #-}
26module Network.BitTorrent.Tracker.Message 28module Network.BitTorrent.Tracker.Message
27 ( -- * Announce 29 ( -- * Announce
@@ -83,6 +85,7 @@ import Data.Text (Text)
83import Data.Text.Encoding 85import Data.Text.Encoding
84import Data.Typeable 86import Data.Typeable
85import Data.Word 87import Data.Word
88import Data.IP
86import Network 89import Network
87import Network.HTTP.Types.QueryLike 90import Network.HTTP.Types.QueryLike
88import Network.HTTP.Types.URI hiding (urlEncode) 91import Network.HTTP.Types.URI hiding (urlEncode)
@@ -431,24 +434,18 @@ renderAnnounceRequest = queryToSimpleQuery . toQuery
431-- 434--
432-- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> 435-- For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
433-- 436--
434data PeerList 437data PeerList a
435 = PeerList { getPeerList :: [PeerAddr] } 438 = PeerList { getPeerList :: [PeerAddr a] }
436 | CompactPeerList { getPeerList :: [PeerAddr] } 439 | CompactPeerList { getPeerList :: [PeerAddr a] }
437 deriving (Show, Eq, Typeable) 440 deriving (Show, Eq, Typeable, Functor)
438 441
439instance ToJSON PeerList where 442putCompactPeerList :: (Serialize a) => S.Putter [PeerAddr a]
440 toJSON = toJSON . getPeerList
441
442instance FromJSON PeerList where
443 parseJSON v = PeerList <$> parseJSON v
444
445putCompactPeerList :: S.Putter [PeerAddr]
446putCompactPeerList = mapM_ put 443putCompactPeerList = mapM_ put
447 444
448getCompactPeerList :: S.Get [PeerAddr] 445getCompactPeerList :: (Serialize a) => S.Get [PeerAddr a]
449getCompactPeerList = many get 446getCompactPeerList = many get
450 447
451instance BEncode PeerList where 448instance (Typeable a, BEncode a, Serialize a) => BEncode (PeerList a) where
452 toBEncode (PeerList xs) = toBEncode xs 449 toBEncode (PeerList xs) = toBEncode xs
453 toBEncode (CompactPeerList xs) = toBEncode $ runPut (putCompactPeerList xs) 450 toBEncode (CompactPeerList xs) = toBEncode $ runPut (putCompactPeerList xs)
454 451
@@ -479,14 +476,12 @@ data AnnounceInfo =
479 , respMinInterval :: !(Maybe Int) 476 , respMinInterval :: !(Maybe Int)
480 477
481 -- | Peers that must be contacted. 478 -- | Peers that must be contacted.
482 , respPeers :: !PeerList 479 , respPeers :: !(PeerList IP)
483 480
484 -- | Human readable warning. 481 -- | Human readable warning.
485 , respWarning :: !(Maybe Text) 482 , respWarning :: !(Maybe Text)
486 } deriving (Show, Typeable) 483 } deriving (Show, Typeable)
487 484
488$(deriveJSON omitRecordPrefix ''AnnounceInfo)
489
490-- | HTTP tracker protocol compatible encoding. 485-- | HTTP tracker protocol compatible encoding.
491instance BEncode AnnounceInfo where 486instance BEncode AnnounceInfo where
492 toBEncode (Failure t) = toDict $ 487 toBEncode (Failure t) = toDict $
@@ -498,19 +493,21 @@ instance BEncode AnnounceInfo where
498 .: "incomplete" .=? respIncomplete 493 .: "incomplete" .=? respIncomplete
499 .: "interval" .=! respInterval 494 .: "interval" .=! respInterval
500 .: "min interval" .=? respMinInterval 495 .: "min interval" .=? respMinInterval
501 .: "peers" .=! respPeers 496 .: "peers" .=! peers
497 .: "peers6" .=! peers6
502 .: "warning message" .=? respWarning 498 .: "warning message" .=? respWarning
503 .: endDict 499 .: endDict
500 where (peers,peers6) = splitIPList $ getPeerList respPeers
504 501
505 fromBEncode (BDict d) 502 fromBEncode (BDict d)
506 | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t 503 | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t
507 | otherwise = (`fromDict` (BDict d)) $ do 504 | otherwise = (`fromDict` (BDict d)) $
508 AnnounceInfo 505 AnnounceInfo
509 <$>? "complete" 506 <$>? "complete"
510 <*>? "incomplete" 507 <*>? "incomplete"
511 <*>! "interval" 508 <*>! "interval"
512 <*>? "min interval" 509 <*>? "min interval"
513 <*>! "peers" 510 <*> (PeerList <$> (mergeIPLists <$>! "peers" <*>? "peers6"))
514 <*>? "warning message" 511 <*>? "warning message"
515 fromBEncode _ = decodingError "Announce info" 512 fromBEncode _ = decodingError "Announce info"
516 513
@@ -521,13 +518,13 @@ instance Serialize AnnounceInfo where
521 putWord32be $ fromIntegral respInterval 518 putWord32be $ fromIntegral respInterval
522 putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete 519 putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete
523 putWord32be $ fromIntegral $ fromMaybe 0 respComplete 520 putWord32be $ fromIntegral $ fromMaybe 0 respComplete
524 forM_ (getPeerList respPeers) put 521 forM_ (fmap ipv4 <$> getPeerList respPeers) put
525 522
526 get = do 523 get = do
527 interval <- getWord32be 524 interval <- getWord32be
528 leechers <- getWord32be 525 leechers <- getWord32be
529 seeders <- getWord32be 526 seeders <- getWord32be
530 peers <- many get 527 peers <- many $ fmap IPv4 <$> get
531 528
532 return $ AnnounceInfo { 529 return $ AnnounceInfo {
533 respWarning = Nothing 530 respWarning = Nothing