From 240f025f6e631a7b3b14173472028ae5f225fc7b Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 8 Feb 2014 07:31:23 +0400 Subject: Redesign core of client --- src/Network/BitTorrent/Client.hs | 137 +++++++++++++-------------------------- 1 file changed, 44 insertions(+), 93 deletions(-) (limited to 'src/Network/BitTorrent/Client.hs') diff --git a/src/Network/BitTorrent/Client.hs b/src/Network/BitTorrent/Client.hs index fd830239..d8c3ee91 100644 --- a/src/Network/BitTorrent/Client.hs +++ b/src/Network/BitTorrent/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Network.BitTorrent.Client ( -- * Options Options (..) @@ -15,142 +16,92 @@ module Network.BitTorrent.Client , newClient , closeClient , withClient + , simpleClient -- * BitTorrent monad + , MonadBitTorrent (..) , BitTorrent , runBitTorrent - , MonadBitTorrent (..) , getClient - -- * Operations - , addTorrent + -- * Handle + , openTorrent + , openMagnet + , closeHandle ) where import Control.Exception -import Control.Concurrent.STM -import Control.Monad.Logger -import Control.Monad.Reader +import Control.Concurrent import Control.Monad.Trans.Resource + import Data.Default -import Data.Function import Data.HashMap.Strict as HM import Data.Maybe -import Data.Ord import Data.Text import Network -import System.Log.FastLogger -import Data.Torrent -import Data.Torrent.InfoHash -import Network.BitTorrent.Client.Swarm +import Network.BitTorrent.Client.Types +import Network.BitTorrent.Client.Handle import Network.BitTorrent.Core import Network.BitTorrent.DHT +import Network.BitTorrent.Tracker as Tracker hiding (Options) import Network.BitTorrent.Exchange.Message data Options = Options - { fingerprint :: Fingerprint - , name :: Text - , port :: PortNumber - , extensions :: [Extension] - , nodeAddr :: NodeAddr IPv4 - , bootNode :: Maybe (NodeAddr IPv4) + { optFingerprint :: Fingerprint + , optName :: Text + , optPort :: PortNumber + , optExtensions :: [Extension] + , optNodeAddr :: NodeAddr IPv4 + , optBootNode :: Maybe (NodeAddr IPv4) } instance Default Options where def = Options - { fingerprint = def - , name = "hs-bittorrent" - , port = 6882 - , extensions = [] - , nodeAddr = "0.0.0.0:6882" - , bootNode = Nothing + { optFingerprint = def + , optName = "hs-bittorrent" + , optPort = 6882 + , optExtensions = [] + , optNodeAddr = "0.0.0.0:6882" + , optBootNode = Nothing } -data Client = Client - { clientPeerId :: !PeerId - , clientListenerPort :: !PortNumber - , allowedExtensions :: !Caps - , clientNode :: !(Node IPv4) - , clientTorrents :: !(TVar (HashMap InfoHash Swarm)) - , clientLogger :: !LogFun --- , trackerClient :: !(Manager) - } - -instance Eq Client where - (==) = (==) `on` clientPeerId - -instance Ord Client where - compare = comparing clientPeerId - newClient :: Options -> LogFun -> IO Client newClient Options {..} logger = do pid <- genPeerId - ts <- newTVarIO HM.empty + ts <- newMVar HM.empty + let peerInfo = PeerInfo pid Nothing optPort + mgr <- Tracker.newManager def peerInfo node <- runResourceT $ do - node <- startNode handlers def nodeAddr logger - runDHT node $ bootstrap (maybeToList bootNode) + node <- startNode handlers def optNodeAddr logger + runDHT node $ bootstrap (maybeToList optBootNode) return node return Client { clientPeerId = pid - , clientListenerPort = port - , allowedExtensions = toCaps extensions - , clientTorrents = ts + , clientListenerPort = optPort + , allowedExtensions = toCaps optExtensions + , trackerManager = mgr , clientNode = node + , clientTorrents = ts , clientLogger = logger } closeClient :: Client -> IO () closeClient Client {..} = do + Tracker.closeManager trackerManager return () -- closeNode clientNode withClient :: Options -> LogFun -> (Client -> IO a) -> IO a -withClient opts log action = bracket (newClient opts log) closeClient action - -{----------------------------------------------------------------------- --- BitTorrent monad ------------------------------------------------------------------------} - -class MonadBitTorrent m where - liftBT :: BitTorrent a -> m a - -newtype BitTorrent a = BitTorrent - { unBitTorrent :: ReaderT Client (ResourceT IO) a - } deriving (Monad, MonadIO) - -instance MonadBitTorrent BitTorrent where - liftBT = id - -instance MonadDHT BitTorrent where - liftDHT action = BitTorrent $ do - node <- asks clientNode - liftIO $ runResourceT $ runDHT node action - -instance MonadLogger BitTorrent where - monadLoggerLog loc src lvl msg = BitTorrent $ do - logger <- asks clientLogger - liftIO $ logger loc src lvl (toLogStr msg) - -runBitTorrent :: Client -> BitTorrent a -> IO a -runBitTorrent client action = runResourceT $ - runReaderT (unBitTorrent action) client -{-# INLINE runBitTorrent #-} - -getClient :: BitTorrent Client -getClient = BitTorrent ask - -{----------------------------------------------------------------------- --- Operations ------------------------------------------------------------------------} --- All operations should be non blocking! - -addTorrent :: Torrent -> BitTorrent () -addTorrent t = do - Client {..} <- getClient - liftIO $ do - leecher <- newLeecher clientPeerId clientListenerPort t - let ih = idInfoHash (tInfoDict t) - atomically $ modifyTVar' clientTorrents (HM.insert ih leecher) - askPeers leecher >>= print \ No newline at end of file +withClient opts lf action = bracket (newClient opts lf) closeClient action + +-- | Run bittorrent client with default options and log to @stderr@. +-- +-- For testing purposes only. +-- +simpleClient :: BitTorrent () -> IO () +simpleClient m = withClient def logger (`runBitTorrent` m) + where + logger _ _ _ _ = return () \ No newline at end of file -- cgit v1.2.3