From 10fcabb96e9f5b2d25cdfae22973cbcb99282139 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Mon, 2 Dec 2013 00:17:05 +0400 Subject: Add http tracker server-side skeleton --- bittorrent.cabal | 8 +- src/Network/BitTorrent/Tracker/RPC/Message.hs | 49 +++++++++++-- src/Network/BitTorrent/Tracker/Wai.hs | 102 ++++++++++++++++++++++++++ 3 files changed, 149 insertions(+), 10 deletions(-) create mode 100644 src/Network/BitTorrent/Tracker/Wai.hs diff --git a/bittorrent.cabal b/bittorrent.cabal index acb28fa7..5b8473dc 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal @@ -59,21 +59,21 @@ library -- , Network.BitTorrent.DHT.Protocol -- , Network.BitTorrent.DHT.Session -- , Network.BitTorrent.Exchange - , Network.BitTorrent.Exchange.Assembler - , Network.BitTorrent.Exchange.Message +-- , Network.BitTorrent.Exchange.Assembler +-- , Network.BitTorrent.Exchange.Message -- , Network.BitTorrent.Exchange.Session -- , Network.BitTorrent.Exchange.Status -- , Network.BitTorrent.Exchange.Wire -- , Network.BitTorrent.Extension -- , Network.BitTorrent.Tracker -- , Network.BitTorrent.Tracker.RPC + , Network.BitTorrent.Tracker.Wai , Network.BitTorrent.Tracker.RPC.Message , Network.BitTorrent.Tracker.RPC.HTTP , Network.BitTorrent.Tracker.RPC.UDP -- , Network.BitTorrent.Tracker.Session -- , Network.BitTorrent.Session -- , Network.BitTorrent.Session.Types --- , System.IO.MMap.Fixed -- , System.Torrent.Storage other-modules: Paths_bittorrent @@ -86,7 +86,6 @@ library -- Control , deepseq , lens --- , mtl , resourcet -- , transformers @@ -131,6 +130,7 @@ library , network >= 2.4 , http-types >= 0.7 , http-conduit + , wai -- , krpc -- System diff --git a/src/Network/BitTorrent/Tracker/RPC/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs index cec68169..cefe96d5 100644 --- a/src/Network/BitTorrent/Tracker/RPC/Message.hs +++ b/src/Network/BitTorrent/Tracker/RPC/Message.hs @@ -32,10 +32,18 @@ module Network.BitTorrent.Tracker.RPC.Message , ParamParseFailure , parseAnnounceQuery + -- ** Request + , AnnounceQueryExt (..) + , AnnounceRequest (..) + , parseAnnounceRequest + , renderAnnounceRequest + -- ** Info , PeerList (..) , AnnounceInfo(..) , defaultNumWant + , defaultMaxNumWant + , defaultReannounceInterval , parseFailureStatus -- * Scrape @@ -47,6 +55,9 @@ module Network.BitTorrent.Tracker.RPC.Message -- ** Info , ScrapeEntry (..) , ScrapeInfo + + -- ** Extra + , queryToSimpleQuery ) where @@ -223,15 +234,15 @@ instance QueryLike AnnounceQuery where , ("event" , toQueryValue reqEvent) ] -filterMaybes :: [(a, Maybe b)] -> [(a, b)] -filterMaybes = catMaybes . L.map f +queryToSimpleQuery :: Query -> SimpleQuery +queryToSimpleQuery = catMaybes . L.map f where f (_, Nothing) = Nothing f (a, Just b ) = Just (a, b) -- | Encode announce query and add it to the base tracker URL. renderAnnounceQuery :: AnnounceQuery -> SimpleQuery -renderAnnounceQuery = filterMaybes . toQuery +renderAnnounceQuery = queryToSimpleQuery . toQuery data QueryParam = ParamInfoHash @@ -320,8 +331,27 @@ parseAnnounceQuery params = AnnounceQuery <*> optParam ParamNumWant params <*> optParam ParamEvent params --- TODO add extension datatype ---type AnnounceRequest = () +data AnnounceQueryExt = AnnounceQueryExt + { extCompact :: Maybe Bool -- | "compact" param + , extNoPeerId :: Maybe Bool -- | "no_peer_id" param + } deriving (Show, Eq, Typeable) + +parseAnnounceQueryExt :: SimpleQuery -> AnnounceQueryExt +parseAnnounceQueryExt = undefined + +renderAnnounceQueryExt :: AnnounceQueryExt -> SimpleQuery +renderAnnounceQueryExt = undefined + +data AnnounceRequest = AnnounceRequest + { announceQuery :: AnnounceQuery + , announceAdvises :: AnnounceQueryExt + } deriving (Show, Eq, Typeable) + +parseAnnounceRequest :: SimpleQuery -> Either ParamParseFailure AnnounceRequest +parseAnnounceRequest = undefined + +renderAnnounceRequest :: AnnounceRequest -> SimpleQuery +renderAnnounceRequest = undefined {----------------------------------------------------------------------- -- Announce response @@ -449,6 +479,13 @@ instance Serialize AnnounceInfo where defaultNumWant :: Int defaultNumWant = 50 +defaultMaxNumWant :: Int +defaultMaxNumWant = 200 + +defaultReannounceInterval :: Int +defaultReannounceInterval = 30 * 60 + + missingOffset :: Int missingOffset = 101 @@ -500,7 +537,7 @@ isScrapeParam :: BS.ByteString -> Bool isScrapeParam = (==) scrapeParam renderScrapeQuery :: ScrapeQuery -> SimpleQuery -renderScrapeQuery = filterMaybes . L.map mkPair +renderScrapeQuery = queryToSimpleQuery . L.map mkPair where mkPair ih = (scrapeParam, toQueryValue ih) diff --git a/src/Network/BitTorrent/Tracker/Wai.hs b/src/Network/BitTorrent/Tracker/Wai.hs new file mode 100644 index 00000000..f290c380 --- /dev/null +++ b/src/Network/BitTorrent/Tracker/Wai.hs @@ -0,0 +1,102 @@ +-- supported extensions: +-- +-- no_peer_id - do not send peer id if no_peer_id=1 specified +-- http://www.bittorrent.org/beps/bep_0023.html +-- +-- compact - compact=1 or compact=0 +-- http://permalink.gmane.org/gmane.network.bit-torrent.general/4030 +-- +-- +{-# LANGUAGE RecordWildCards #-} +module Network.BitTorrent.Tracker.Wai + ( tracker + ) where + +import Control.Monad.Trans.Resource +import Data.BEncode as BE +import Data.ByteString +import Data.Default +import Data.List as L +import Network.HTTP.Types +import Network.Wai + +import Data.Torrent.Progress +import Network.BitTorrent.Core.PeerId +import Network.BitTorrent.Core.PeerAddr +import Network.BitTorrent.Tracker.RPC.Message + + +data TrackerSettings = TrackerSettings + { -- | If peer did not specified the "numwant" then this value is + -- used. + defNumWant :: {-# UNPACK #-} !Int + + -- | If peer specified to big numwant value. + , maxNumWant :: {-# UNPACK #-} !Int + + -- | Recommended time interval to wait between regular announce + -- requests. + , reannounceInterval :: {-# UNPACK #-} !Int + + -- | Minimum time interval to wait between regular announce + -- requests. + , reannounceMinInterval :: !(Maybe Int) + + -- | Whether to send count of seeders. + , completePeers :: !Bool + + -- | Whether to send count of leechers. + , incompletePeers :: !Bool + + -- | Do not send peer id in response. Peer can override this value + -- by setting "no_peer_id" to 0 or 1. + , noPeerId :: !Bool + + -- | Whether to send compact peer list. Peer can override this + -- value by setting "compact" to 0 or 1. + , compactPeerList :: !Bool + } + +instance Default TrackerSettings where + def = TrackerSettings + { defNumWant = defaultNumWant + , maxNumWant = defaultMaxNumWant + , reannounceInterval = defaultReannounceInterval + , reannounceMinInterval = Nothing + , compactPeerList = False + , completePeers = False + , incompletePeers = False + , noPeerId = False + } + +getAnnounceR :: AnnounceRequest -> ResourceT IO AnnounceInfo +getAnnounceR = undefined + +getScrapeR :: ScrapeQuery -> ResourceT IO ScrapeInfo +getScrapeR = undefined + +-- content-type: "text/plain" ? +tracker :: Application +tracker Request {..} + | requestMethod /= methodGet + = return $ responseLBS methodNotAllowed405 [] "" + + | otherwise = do + case pathInfo of + ["announce"] -> + case parseAnnounceRequest $ queryToSimpleQuery queryString of + Right query -> do + info <- getAnnounceR query + return $ responseLBS ok200 [] $ BE.encode info + Left msg -> + return $ responseLBS (parseFailureStatus msg) [] "" + + ["scrape"] -> + case Right $ parseScrapeQuery $ queryToSimpleQuery queryString of -- TODO + Right query -> do + info <- getScrapeR query + return $ responseLBS ok200 [] $ BE.encode info + Left _ -> + return $ responseLBS badRequest400 [] "" + + _ -> undefined --badPath -- cgit v1.2.3