From 442a7c0941b4f2659988193404263348593551a2 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 15 Mar 2014 20:37:11 +0400 Subject: Expose UDP tracker specific message types Those can be used to implement UDP tracker server by third party libraries or projects. --- src/Network/BitTorrent/Tracker/Message.hs | 163 ++++++++++++++++++++++++++++- src/Network/BitTorrent/Tracker/RPC/HTTP.hs | 2 +- src/Network/BitTorrent/Tracker/RPC/UDP.hs | 147 -------------------------- src/Network/BitTorrent/Tracker/Session.hs | 12 +-- 4 files changed, 169 insertions(+), 155 deletions(-) (limited to 'src') diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs index edafdaba..8131ecf0 100644 --- a/src/Network/BitTorrent/Tracker/Message.hs +++ b/src/Network/BitTorrent/Tracker/Message.hs @@ -25,6 +25,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -fno-warn-orphans #-} module Network.BitTorrent.Tracker.Message ( -- * Announce @@ -76,6 +77,21 @@ module Network.BitTorrent.Tracker.Message -- ** Extra , queryToSimpleQuery + + -- * UDP specific + -- ** Connection + , ConnectionId + , initialConnectionId + + -- ** Messages + , Request (..) + , Response (..) + , responseName + + -- ** Transaction + , genTransactionId + , TransactionId + , Transaction (..) ) where @@ -104,7 +120,9 @@ import Network import Network.HTTP.Types.QueryLike import Network.HTTP.Types.URI hiding (urlEncode) import Network.HTTP.Types.Status -import Network.Socket +import Network.Socket hiding (Connected) +import Numeric +import System.Entropy import Text.Read (readMaybe) import Data.Torrent.InfoHash @@ -765,3 +783,146 @@ scrapeType = "text/plain" -- parseFailureStatus :: ParamParseFailure -> Status parseFailureStatus = mkStatus <$> parseFailureCode <*> parseFailureMessage + +{----------------------------------------------------------------------- +-- UDP specific message types +-----------------------------------------------------------------------} + +genToken :: IO Word64 +genToken = do + bs <- getEntropy 8 + either err return $ runGet getWord64be bs + where + err = error "genToken: impossible happen" + +-- | Connection Id is used for entire tracker session. +newtype ConnectionId = ConnectionId Word64 + deriving (Eq, Serialize) + +instance Show ConnectionId where + showsPrec _ (ConnectionId cid) = showString "0x" <> showHex cid + +initialConnectionId :: ConnectionId +initialConnectionId = ConnectionId 0x41727101980 + +-- | Transaction Id is used within a UDP RPC. +newtype TransactionId = TransactionId Word32 + deriving (Eq, Ord, Enum, Bounded, Serialize) + +instance Show TransactionId where + showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid + +genTransactionId :: IO TransactionId +genTransactionId = (TransactionId . fromIntegral) <$> genToken + +data Request + = Connect + | Announce AnnounceQuery + | Scrape ScrapeQuery + deriving Show + +data Response + = Connected ConnectionId + | Announced AnnounceInfo + | Scraped [ScrapeEntry] + | Failed Text + deriving Show + +responseName :: Response -> String +responseName (Connected _) = "connected" +responseName (Announced _) = "announced" +responseName (Scraped _) = "scraped" +responseName (Failed _) = "failed" + +data family Transaction a +data instance Transaction Request = TransactionQ + { connIdQ :: {-# UNPACK #-} !ConnectionId + , transIdQ :: {-# UNPACK #-} !TransactionId + , request :: !Request + } deriving Show +data instance Transaction Response = TransactionR + { transIdR :: {-# UNPACK #-} !TransactionId + , response :: !Response + } deriving Show + +-- TODO newtype +newtype MessageId = MessageId Word32 + deriving (Show, Eq, Num, Serialize) + +connectId, announceId, scrapeId, errorId :: MessageId +connectId = 0 +announceId = 1 +scrapeId = 2 +errorId = 3 + +instance Serialize (Transaction Request) where + put TransactionQ {..} = do + case request of + Connect -> do + put initialConnectionId + put connectId + put transIdQ + + Announce ann -> do + put connIdQ + put announceId + put transIdQ + put ann + + Scrape hashes -> do + put connIdQ + put scrapeId + put transIdQ + forM_ hashes put + + get = do + cid <- get + mid <- get + TransactionQ cid <$> S.get <*> getBody mid + where + getBody :: MessageId -> S.Get Request + getBody msgId + | msgId == connectId = pure Connect + | msgId == announceId = Announce <$> get + | msgId == scrapeId = Scrape <$> many get + | otherwise = fail errMsg + where + errMsg = "unknown request: " ++ show msgId + +instance Serialize (Transaction Response) where + put TransactionR {..} = do + case response of + Connected conn -> do + put connectId + put transIdR + put conn + + Announced info -> do + put announceId + put transIdR + put info + + Scraped infos -> do + put scrapeId + put transIdR + forM_ infos put + + Failed info -> do + put errorId + put transIdR + put (encodeUtf8 info) + + + get = do + mid <- get + TransactionR <$> get <*> getBody mid + where + getBody :: MessageId -> S.Get Response + getBody msgId + | msgId == connectId = Connected <$> get + | msgId == announceId = Announced <$> get + | msgId == scrapeId = Scraped <$> many get + | msgId == errorId = (Failed . decodeUtf8) <$> get + | otherwise = fail msg + where + msg = "unknown response: " ++ show msgId diff --git a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs index cc5bd318..4a8e5f79 100644 --- a/src/Network/BitTorrent/Tracker/RPC/HTTP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs @@ -49,7 +49,7 @@ import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) import Data.Torrent.InfoHash (InfoHash) import Network.BitTorrent.Core.Fingerprint (libUserAgent) -import Network.BitTorrent.Tracker.Message +import Network.BitTorrent.Tracker.Message hiding (Request, Response) {----------------------------------------------------------------------- -- Exceptions diff --git a/src/Network/BitTorrent/Tracker/RPC/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs index 0c9c3367..35e8b7b6 100644 --- a/src/Network/BitTorrent/Tracker/RPC/UDP.hs +++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs @@ -15,7 +15,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} module Network.BitTorrent.Tracker.RPC.UDP ( -- * Manager Options (..) @@ -52,7 +51,6 @@ import Text.Read (readMaybe) import Network.Socket hiding (Connected, connect, listen) import Network.Socket.ByteString as BS import Network.URI -import System.Entropy import System.Timeout import Numeric @@ -258,151 +256,6 @@ getTrackerAddr _ uri | uriScheme uri == "udp:" = resolveURI uri | otherwise = throwIO (UnrecognizedScheme (uriScheme uri)) -{----------------------------------------------------------------------- - Tokens ------------------------------------------------------------------------} - -genToken :: IO Word64 -genToken = do - bs <- getEntropy 8 - either err return $ runGet getWord64be bs - where - err = error "genToken: impossible happen" - --- | Connection Id is used for entire tracker session. -newtype ConnectionId = ConnectionId Word64 - deriving (Eq, Serialize) - -instance Show ConnectionId where - showsPrec _ (ConnectionId cid) = showString "0x" <> showHex cid - -initialConnectionId :: ConnectionId -initialConnectionId = ConnectionId 0x41727101980 - --- | Transaction Id is used within a UDP RPC. -newtype TransactionId = TransactionId Word32 - deriving (Eq, Ord, Enum, Bounded, Serialize) - -instance Show TransactionId where - showsPrec _ (TransactionId tid) = showString "0x" <> showHex tid - -genTransactionId :: IO TransactionId -genTransactionId = (TransactionId . fromIntegral) <$> genToken - -{----------------------------------------------------------------------- - Transactions ------------------------------------------------------------------------} - -data Request = Connect - | Announce AnnounceQuery - | Scrape ScrapeQuery - deriving Show - -data Response = Connected ConnectionId - | Announced AnnounceInfo - | Scraped [ScrapeEntry] - | Failed Text - deriving Show - -responseName :: Response -> String -responseName (Connected _) = "connected" -responseName (Announced _) = "announced" -responseName (Scraped _) = "scraped" -responseName (Failed _) = "failed" - -data family Transaction a -data instance Transaction Request = TransactionQ - { connIdQ :: {-# UNPACK #-} !ConnectionId - , transIdQ :: {-# UNPACK #-} !TransactionId - , request :: !Request - } deriving Show -data instance Transaction Response = TransactionR - { transIdR :: {-# UNPACK #-} !TransactionId - , response :: !Response - } deriving Show - --- TODO newtype -newtype MessageId = MessageId Word32 - deriving (Show, Eq, Num, Serialize) - -connectId, announceId, scrapeId, errorId :: MessageId -connectId = 0 -announceId = 1 -scrapeId = 2 -errorId = 3 - -instance Serialize (Transaction Request) where - put TransactionQ {..} = do - case request of - Connect -> do - put initialConnectionId - put connectId - put transIdQ - - Announce ann -> do - put connIdQ - put announceId - put transIdQ - put ann - - Scrape hashes -> do - put connIdQ - put scrapeId - put transIdQ - forM_ hashes put - - get = do - cid <- get - mid <- get - TransactionQ cid <$> get <*> getBody mid - where - getBody :: MessageId -> Get Request - getBody msgId - | msgId == connectId = pure Connect - | msgId == announceId = Announce <$> get - | msgId == scrapeId = Scrape <$> many get - | otherwise = fail errMsg - where - errMsg = "unknown request: " ++ show msgId - -instance Serialize (Transaction Response) where - put TransactionR {..} = do - case response of - Connected conn -> do - put connectId - put transIdR - put conn - - Announced info -> do - put announceId - put transIdR - put info - - Scraped infos -> do - put scrapeId - put transIdR - forM_ infos put - - Failed info -> do - put errorId - put transIdR - put (encodeUtf8 info) - - - get = do - mid <- get - TransactionR <$> get <*> getBody mid - where - getBody :: MessageId -> Get Response - getBody msgId - | msgId == connectId = Connected <$> get - | msgId == announceId = Announced <$> get - | msgId == scrapeId = Scraped <$> many get - | msgId == errorId = (Failed . decodeUtf8) <$> get - | otherwise = fail msg - where - msg = "unknown response: " ++ show msgId - {----------------------------------------------------------------------- Connection -----------------------------------------------------------------------} diff --git a/src/Network/BitTorrent/Tracker/Session.hs b/src/Network/BitTorrent/Tracker/Session.hs index 7be16fd6..9fe02b52 100644 --- a/src/Network/BitTorrent/Tracker/Session.hs +++ b/src/Network/BitTorrent/Tracker/Session.hs @@ -50,13 +50,13 @@ import Network.BitTorrent.Tracker.RPC as RPC -- Tracker entry -----------------------------------------------------------------------} -data Scrape = Scrape +data LastScrape = LastScrape { leechersCount :: Maybe Int , seedersCount :: Maybe Int } deriving (Show, Eq) -instance Default Scrape where - def = Scrape Nothing Nothing +instance Default LastScrape where + def = LastScrape Nothing Nothing data Status @@ -102,7 +102,7 @@ data TrackerEntry = TrackerEntry , peersCache :: Cached [PeerAddr IP] -- | May be used to show brief swarm stats in client GUI. - , scrapeCache :: Cached Scrape + , scrapeCache :: Cached LastScrape } nullEntry :: URI -> TrackerEntry @@ -140,11 +140,11 @@ cachePeers AnnounceInfo {..} = (seconds (fromMaybe respInterval respMinInterval)) (getPeerList respPeers) -cacheScrape :: AnnounceInfo -> IO (Cached Scrape) +cacheScrape :: AnnounceInfo -> IO (Cached LastScrape) cacheScrape AnnounceInfo {..} = newCached (seconds respInterval) (seconds (fromMaybe respInterval respMinInterval)) - Scrape + LastScrape { seedersCount = respComplete , leechersCount = respIncomplete } -- cgit v1.2.3