From 08d1d4674ef38542e5db24fc398efefbc7bb35af Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 21 Nov 2013 21:41:06 +0400 Subject: Rename protocol module --- src/Network/BitTorrent/Tracker/Message.hs | 406 ++++++++++++++++++++++++++++++ 1 file changed, 406 insertions(+) create mode 100644 src/Network/BitTorrent/Tracker/Message.hs (limited to 'src/Network/BitTorrent/Tracker/Message.hs') diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs new file mode 100644 index 00000000..8f4c9228 --- /dev/null +++ b/src/Network/BitTorrent/Tracker/Message.hs @@ -0,0 +1,406 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Every tracker should support announce query. This query is used +-- to discover peers within swarm and have two-fold effect: +-- +-- * peer doing announce discover other peers using peer list from +-- the response to the announce query. +-- +-- * tracker store peer information and use it in the succeeding +-- requests made by other peers, until the peer info expires. +-- +-- By convention most trackers support another form of request -- +-- scrape query -- which queries the state of a given torrent (or +-- a list of torrents) that the tracker is managing. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS -fno-warn-orphans #-} +module Network.BitTorrent.Tracker.Protocol + ( -- * Announce + Event(..) + , AnnounceQuery(..) + , AnnounceInfo(..) + + -- ** Defaults + , defaultNumWant + , defaultPorts + + -- * Scrape + , ScrapeQuery + , ScrapeInfo(..) + , Scrape + + -- * TODO + , Tracker(..) + , scrapeOne + ) + where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson.TH +import Data.BEncode as BE +import Data.BEncode.BDict as BE +import Data.Char as Char +import Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Serialize as S hiding (Result) +import Data.Text (Text) +import Data.Text.Encoding +import Data.Typeable +import Data.URLEncoded as URL +import Data.Word +import Network +import Network.URI +import Network.Socket + +import Data.Torrent.InfoHash +import Data.Torrent.Progress +import Network.BitTorrent.Core.PeerId +import Network.BitTorrent.Core.PeerAddr + +{----------------------------------------------------------------------- + Announce messages +-----------------------------------------------------------------------} + +-- | Events used to specify which kind of tracker request is performed. +data Event = Started + -- ^ For the first request: when a peer join the swarm. + | Stopped + -- ^ Sent when the peer is shutting down. + | Completed + -- ^ To be sent when the peer completes a download. + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''Event) + +-- | A tracker request is HTTP GET request; used to include metrics +-- from clients that help the tracker keep overall statistics about +-- the torrent. The most important, requests are used by the tracker +-- to keep track lists of active peer for a particular torrent. +-- +data AnnounceQuery = AnnounceQuery { + reqInfoHash :: !InfoHash + -- ^ Hash of info part of the torrent usually obtained from + -- 'Torrent'. + + , reqPeerId :: !PeerId + -- ^ ID of the peer doing request. + + , reqPort :: !PortNumber + -- ^ Port to listen to for connections from other + -- peers. Normally, tracker should respond with this port when + -- some peer request the tracker with the same info hash. + + , reqProgress :: !Progress + -- ^ Current progress of peer doing request. + + , reqIP :: Maybe HostAddress + -- ^ The peer IP. Needed only when client communicated with + -- tracker throught a proxy. + + , reqNumWant :: Maybe Int + -- ^ Number of peers that the peers wants to receive from. See + -- note for 'defaultNumWant'. + + , reqEvent :: Maybe Event + -- ^ If not specified, the request is regular periodic request. + } deriving (Show, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery) + +newtype PeerList = PeerList { getPeerList :: [PeerAddr] } + deriving (Show, Eq, ToJSON, FromJSON, Typeable) + +-- | The tracker response includes a peer list that helps the client +-- participate in the torrent. The most important is 'respPeer' list +-- used to join the swarm. +-- +data AnnounceInfo = + Failure !Text -- ^ Failure reason in human readable form. + | AnnounceInfo { + -- | Number of peers completed the torrent. (seeders) + respComplete :: !(Maybe Int) + + -- | Number of peers downloading the torrent. (leechers) + , respIncomplete :: !(Maybe Int) + + -- | Recommended interval to wait between requests. + , respInterval :: !Int + + -- | Minimal amount of time between requests. A peer /should/ + -- make timeout with at least 'respMinInterval' value, + -- otherwise tracker might not respond. If not specified the + -- same applies to 'respInterval'. + , respMinInterval :: !(Maybe Int) + + -- | Peers that must be contacted. + , respPeers :: !PeerList + + -- | Human readable warning. + , respWarning :: !(Maybe Text) + } deriving (Show, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceInfo) + +-- | Ports typically reserved for bittorrent P2P listener. +defaultPorts :: [PortNumber] +defaultPorts = [6881..6889] + +-- | Above 25, new peers are highly unlikely to increase download +-- speed. Even 30 peers is /plenty/, the official client version 3 +-- in fact only actively forms new connections if it has less than +-- 30 peers and will refuse connections if it has 55. +-- +-- So the default value is set to 50 because usually 30-50% of peers +-- are not responding. +-- +defaultNumWant :: Int +defaultNumWant = 50 + +{----------------------------------------------------------------------- + Bencode announce encoding +-----------------------------------------------------------------------} + +instance BEncode PeerList where + toBEncode (PeerList xs) = toBEncode xs + fromBEncode (BList l ) = PeerList <$> fromBEncode (BList l) + fromBEncode (BString s ) = PeerList <$> runGet getCompactPeerList s + fromBEncode _ = decodingError "Peer list" + +-- | HTTP tracker protocol compatible encoding. +instance BEncode AnnounceInfo where + toBEncode (Failure t) = toDict $ + "failure reason" .=! t + .: endDict + + toBEncode AnnounceInfo {..} = toDict $ + "complete" .=? respComplete + .: "incomplete" .=? respIncomplete + .: "interval" .=! respInterval + .: "min interval" .=? respMinInterval + .: "peers" .=! respPeers + .: "warning message" .=? respWarning + .: endDict + + fromBEncode (BDict d) + | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t + | otherwise = (`fromDict` (BDict d)) $ do + AnnounceInfo + <$>? "complete" + <*>? "incomplete" + <*>! "interval" + <*>? "min interval" + <*>! "peers" + <*>? "warning message" + fromBEncode _ = decodingError "Announce info" + +instance URLShow PortNumber where + urlShow = urlShow . fromEnum + +instance URLShow Word32 where + urlShow = show + +instance URLShow Event where + urlShow e = urlShow (Char.toLower x : xs) + where + -- INVARIANT: this is always nonempty list + (x : xs) = show e + +instance URLShow Word64 where + urlShow = show + +instance URLEncode Progress where + urlEncode Progress {..} = mconcat + [ s "uploaded" %= _uploaded + , s "left" %= _left + , s "downloaded" %= _downloaded + ] + where s :: String -> String; s = id; {-# INLINE s #-} + +-- | HTTP tracker protocol compatible encoding. +instance URLEncode AnnounceQuery where + urlEncode AnnounceQuery {..} = mconcat + [ s "peer_id" %= reqPeerId + , s "port" %= reqPort + , urlEncode reqProgress + + + , s "ip" %=? reqIP + , s "numwant" %=? reqNumWant + , s "event" %=? reqEvent + ] + where s :: String -> String; s = id; {-# INLINE s #-} + +{----------------------------------------------------------------------- + Binary announce encoding +-----------------------------------------------------------------------} + +type EventId = Word32 + +eventId :: Event -> EventId +eventId Completed = 1 +eventId Started = 2 +eventId Stopped = 3 + +-- TODO add Regular event +putEvent :: Putter (Maybe Event) +putEvent Nothing = putWord32be 0 +putEvent (Just e) = putWord32be (eventId e) + +getEvent :: S.Get (Maybe Event) +getEvent = do + eid <- getWord32be + case eid of + 0 -> return Nothing + 1 -> return $ Just Completed + 2 -> return $ Just Started + 3 -> return $ Just Stopped + _ -> fail "unknown event id" + +-- | UDP tracker protocol compatible encoding. +instance Serialize AnnounceQuery where + put AnnounceQuery {..} = do + put reqInfoHash + put reqPeerId + put reqProgress + putEvent reqEvent + putWord32be $ fromMaybe 0 reqIP + putWord32be $ 0 -- TODO what the fuck is "key"? + putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant + + put reqPort + + get = do + ih <- get + pid <- get + + progress <- get + + ev <- getEvent + ip <- getWord32be +-- key <- getWord32be -- TODO + want <- getWord32be + + port <- get + + return $ AnnounceQuery { + reqInfoHash = ih + , reqPeerId = pid + , reqPort = port + , reqProgress = progress + , reqIP = if ip == 0 then Nothing else Just ip + , reqNumWant = if want == -1 then Nothing else Just (fromIntegral want) + , reqEvent = ev + } + +-- | UDP tracker protocol compatible encoding. +instance Serialize AnnounceInfo where + put (Failure msg) = put $ encodeUtf8 msg + put AnnounceInfo {..} = do + putWord32be $ fromIntegral respInterval + putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete + putWord32be $ fromIntegral $ fromMaybe 0 respComplete + forM_ (getPeerList respPeers) put + + get = do + interval <- getWord32be + leechers <- getWord32be + seeders <- getWord32be + peers <- many get + + return $ AnnounceInfo { + respWarning = Nothing + , respInterval = fromIntegral interval + , respMinInterval = Nothing + , respIncomplete = Just $ fromIntegral leechers + , respComplete = Just $ fromIntegral seeders + , respPeers = PeerList peers + } + +{----------------------------------------------------------------------- + Scrape messages +-----------------------------------------------------------------------} + +type ScrapeQuery = [InfoHash] + +-- | Overall information about particular torrent. +data ScrapeInfo = ScrapeInfo { + -- | Number of seeders - peers with the entire file. + siComplete :: {-# UNPACK #-} !Int + + -- | Total number of times the tracker has registered a completion. + , siDownloaded :: {-# UNPACK #-} !Int + + -- | Number of leechers. + , siIncomplete :: {-# UNPACK #-} !Int + + -- | Name of the torrent file, as specified by the "name" + -- file in the info section of the .torrent file. + , siName :: !(Maybe Text) + } deriving (Show, Eq, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''ScrapeInfo) + +-- TODO hash map +-- | Scrape info about a set of torrents. +type Scrape = Map InfoHash ScrapeInfo + +-- | HTTP tracker protocol compatible encoding. +instance BEncode ScrapeInfo where + toBEncode ScrapeInfo {..} = toDict $ + "complete" .=! siComplete + .: "downloaded" .=! siDownloaded + .: "incomplete" .=! siIncomplete + .: "name" .=? siName + .: endDict + + fromBEncode = fromDict $ do + ScrapeInfo <$>! "complete" + <*>! "downloaded" + <*>! "incomplete" + <*>? "name" + +-- | UDP tracker protocol complatble encoding. +instance Serialize ScrapeInfo where + put ScrapeInfo {..} = do + putWord32be $ fromIntegral siComplete + putWord32be $ fromIntegral siDownloaded + putWord32be $ fromIntegral siIncomplete + + get = do + seeders <- getWord32be + downTimes <- getWord32be + leechers <- getWord32be + + return $ ScrapeInfo { + siComplete = fromIntegral seeders + , siDownloaded = fromIntegral downTimes + , siIncomplete = fromIntegral leechers + , siName = Nothing + } + +-- | Set of tracker RPCs. +class Tracker s where + connect :: URI -> IO s + announce :: s -> AnnounceQuery -> IO AnnounceInfo + scrape :: s -> ScrapeQuery -> IO Scrape + +-- | More particular version of 'scrape', just for one torrent. +-- +scrapeOne :: Tracker t => t -> InfoHash -> IO ScrapeInfo +scrapeOne uri ih = scrape uri [ih] >>= maybe err return . M.lookup ih + where + err = throwIO $ userError "unable to find info hash in response dict" -- cgit v1.2.3