From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- .../src/Network/BitTorrent/Tracker/RPC/HTTP.hs | 191 --------------------- 1 file changed, 191 deletions(-) delete mode 100644 bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs (limited to 'bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs') diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs deleted file mode 100644 index 6f7a53bf..00000000 --- a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs +++ /dev/null @@ -1,191 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- This module implement HTTP tracker protocol. --- --- For more information see: --- --- -{-# LANGUAGE DeriveDataTypeable #-} -module Network.BitTorrent.Tracker.RPC.HTTP - ( -- * Manager - Options (..) - , Manager - , newManager - , closeManager - , withManager - - -- * RPC - , RpcException (..) - , announce - , scrape - , scrapeOne - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad -import Control.Monad.Trans.Resource -import Data.BEncode as BE -import Data.ByteString as BS -import Data.ByteString.Char8 as BC -import Data.ByteString.Lazy as BL -import Data.Default -import Data.List as L -import Data.Monoid -import Data.Typeable hiding (Proxy) -import Network.URI -import Network.HTTP.Conduit hiding - (Manager, newManager, closeManager, withManager) -import Network.HTTP.Client (defaultManagerSettings) -import Network.HTTP.Client.Internal (setUri) -import qualified Network.HTTP.Conduit as HTTP -import Network.HTTP.Types.Header (hUserAgent) -import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery) - -import Data.Torrent (InfoHash) -import Network.Address (libUserAgent) -import Network.BitTorrent.Tracker.Message hiding (Request, Response) - -{----------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------} - -data RpcException - = RequestFailed HttpException -- ^ failed HTTP request. - | ParserFailure String -- ^ unable to decode tracker response; - | ScrapelessTracker -- ^ tracker do not support scraping; - | BadScrape -- ^ unable to find info hash in response dict; - deriving (Show, Typeable) - -instance Exception RpcException - -packHttpException :: IO a -> IO a -packHttpException m = try m >>= either (throwIO . RequestFailed) return - -{----------------------------------------------------------------------- --- Manager ------------------------------------------------------------------------} - --- | HTTP tracker specific RPC options. -data Options = Options - { -- | Global HTTP announce query preferences. - optAnnouncePrefs :: !AnnouncePrefs - - -- | Whether to use HTTP proxy for HTTP tracker requests. - , optHttpProxy :: !(Maybe Proxy) - - -- | Value to put in HTTP user agent header. - , optUserAgent :: !BS.ByteString - - -- | HTTP manager options. - , optHttpOptions :: !ManagerSettings - } - -instance Default Options where - def = Options - { optAnnouncePrefs = def - , optHttpProxy = Nothing - , optUserAgent = BC.pack libUserAgent - , optHttpOptions = defaultManagerSettings - } - --- | HTTP tracker manager. -data Manager = Manager - { options :: !Options - , httpMgr :: !HTTP.Manager - } - --- | -newManager :: Options -> IO Manager -newManager opts = Manager opts <$> HTTP.newManager (optHttpOptions opts) - --- | -closeManager :: Manager -> IO () -closeManager Manager {..} = HTTP.closeManager httpMgr - --- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'. -withManager :: Options -> (Manager -> IO a) -> IO a -withManager opts = bracket (newManager opts) closeManager - -{----------------------------------------------------------------------- --- Queries ------------------------------------------------------------------------} - -fillRequest :: Options -> SimpleQuery -> Request -> Request -fillRequest Options {..} q r = r - { queryString = joinQuery (queryString r) (renderSimpleQuery False q) - , requestHeaders = (hUserAgent, optUserAgent) : requestHeaders r - , proxy = optHttpProxy - } - where - joinQuery a b - | BS.null a = b - | otherwise = a <> "&" <> b - -httpTracker :: BEncode a => Manager -> URI -> SimpleQuery -> IO a -httpTracker Manager {..} uri q = packHttpException $ do - request <- fillRequest options q <$> setUri defaultRequest uri - response <- runResourceT $ httpLbs request httpMgr - case BE.decode $ BL.toStrict $ responseBody response of - Left msg -> throwIO (ParserFailure msg) - Right info -> return info - -{----------------------------------------------------------------------- --- RPC ------------------------------------------------------------------------} - --- | Send request and receive response from the tracker specified in --- announce list. --- --- This function can throw 'RpcException'. --- -announce :: Manager -> URI -> AnnounceQuery -> IO AnnounceInfo -announce mgr uri q = httpTracker mgr uri (renderAnnounceRequest uriQ) - where - uriQ = AnnounceRequest - { announceQuery = q - , announcePrefs = optAnnouncePrefs (options mgr) - } - --- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL' --- gives 'Nothing' then tracker do not support scraping. --- -scrapeURL :: URI -> Maybe URI -scrapeURL uri = do - newPath <- replace (BC.pack (uriPath uri)) - return uri { uriPath = BC.unpack newPath } - where - replace p = do - let ps = BC.splitWith (== '/') p - guard (not (L.null ps)) - guard ("announce" `BS.isPrefixOf` L.last ps) - let newSuff = "scrape" <> BS.drop (BS.length "announce") (L.last ps) - return (BS.intercalate "/" (L.init ps ++ [newSuff])) - --- | For each 'InfoHash' of torrents request scrape info from the tracker. --- However if the info hash list is 'null', the tracker should list --- all available torrents. --- --- This function can throw 'RpcException'. --- -scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo -scrape m u q = do - case scrapeURL u of - Nothing -> throwIO ScrapelessTracker - Just uri -> httpTracker m uri (renderScrapeQuery q) - --- | More particular version of 'scrape', just for one torrent. --- --- This function can throw 'RpcException'. --- -scrapeOne :: Manager -> URI -> InfoHash -> IO ScrapeEntry -scrapeOne m uri ih = do - xs <- scrape m uri [ih] - case L.lookup ih xs of - Nothing -> throwIO BadScrape - Just a -> return a -- cgit v1.2.3