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 ++++++++++--------------------- src/Network/BitTorrent/Client/Handle.hs | 138 ++++++++++++++++++++++++++++++++ src/Network/BitTorrent/Client/Swarm.hs | 52 ------------ src/Network/BitTorrent/Client/Types.hs | 84 +++++++++++++++++++ 4 files changed, 266 insertions(+), 145 deletions(-) create mode 100644 src/Network/BitTorrent/Client/Handle.hs delete mode 100644 src/Network/BitTorrent/Client/Swarm.hs create mode 100644 src/Network/BitTorrent/Client/Types.hs (limited to 'src/Network/BitTorrent') 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 diff --git a/src/Network/BitTorrent/Client/Handle.hs b/src/Network/BitTorrent/Client/Handle.hs new file mode 100644 index 00000000..467d5745 --- /dev/null +++ b/src/Network/BitTorrent/Client/Handle.hs @@ -0,0 +1,138 @@ +module Network.BitTorrent.Client.Handle + ( -- * Handle + Handle + + -- * Initialization + , openTorrent + , openMagnet + , closeHandle + + -- * Control + , start + , pause + , stop + + -- * Query + , getHandle + , HandleState + , getState + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans +import Data.HashMap.Strict as HM + +import Data.Torrent +import Data.Torrent.InfoHash +import Data.Torrent.Magnet +import Network.BitTorrent.Client.Types +import Network.BitTorrent.DHT as DHT +import Network.BitTorrent.Tracker as Tracker + +{----------------------------------------------------------------------- +-- Safe handle set manupulation +-----------------------------------------------------------------------} + +-- | Guarantees that we newer allocate the same handle twice. +allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle +allocHandle ih m = do + c @ Client {..} <- getClient + liftIO $ modifyMVar clientTorrents $ \ handles -> do + case HM.lookup ih handles of + Just h -> return (handles, h) + Nothing -> do + h <- runBitTorrent c m + return (HM.insert ih h handles, h) + +-- | +freeHandle :: InfoHash -> BitTorrent () -> BitTorrent () +freeHandle ih finalizer = do + c @ Client {..} <- getClient + liftIO $ modifyMVar_ clientTorrents $ \ handles -> do + case HM.lookup ih handles of + Nothing -> return handles + Just _ -> do + runBitTorrent c finalizer + return (HM.delete ih handles) + +-- | +lookupHandle :: InfoHash -> BitTorrent (Maybe Handle) +lookupHandle ih = do + Client {..} <- getClient + handles <- liftIO $ readMVar clientTorrents + return (HM.lookup ih handles) + +{----------------------------------------------------------------------- +-- Initialization +-----------------------------------------------------------------------} + +-- | Open a torrent in 'stop'ed state. Use 'nullTorrent' to open +-- handle from 'InfoDict'. This operation do not block. +openTorrent :: Torrent -> BitTorrent Handle +openTorrent t @ Torrent {..} = do + let ih = idInfoHash tInfoDict + allocHandle ih $ do + ses <- liftIO (Tracker.newSession ih (trackerList t)) + return $ Handle ih (idPrivate tInfoDict) ses + +-- | Use 'nullMagnet' to open handle from 'InfoHash'. +openMagnet :: Magnet -> BitTorrent Handle +openMagnet = undefined + +-- | Stop torrent and destroy all sessions. You don't need to close +-- handles at application exit, all handles will be automatically +-- closed at 'Network.BitTorrent.Client.closeClient'. This operation +-- may block. +closeHandle :: Handle -> BitTorrent () +closeHandle h @ Handle {..} = do + freeHandle topic $ do + stop h + liftIO $ Tracker.closeSession trackers + +{----------------------------------------------------------------------- +-- Control +-----------------------------------------------------------------------} + +-- | Start downloading, uploading and announcing this torrent. +-- +-- This operation is blocking, use +-- 'Control.Concurrent.Async.Lifted.async' if needed. +start :: Handle -> BitTorrent () +start Handle {..} = do + Client {..} <- getClient + liftIO $ Tracker.notify trackerManager trackers Tracker.Started + unless private $ do + liftDHT $ DHT.insert topic undefined + +-- | Stop downloading this torrent. +pause :: Handle -> BitTorrent () +pause _ = return () + +-- | Stop downloading, uploading and announcing this torrent. +stop :: Handle -> BitTorrent () +stop Handle {..} = do + Client {..} <- getClient + unless private $ do + liftDHT $ DHT.delete topic undefined + liftIO $ Tracker.notify trackerManager trackers Tracker.Stopped + +{----------------------------------------------------------------------- +-- Query +-----------------------------------------------------------------------} + +data HandleState + = Running + | Paused + | Stopped + +getHandle :: InfoHash -> BitTorrent Handle +getHandle ih = do + mhandle <- lookupHandle ih + case mhandle of + Nothing -> error "should we throw some exception?" + Just h -> return h + +getState :: Handle -> IO HandleState +getState = undefined \ No newline at end of file diff --git a/src/Network/BitTorrent/Client/Swarm.hs b/src/Network/BitTorrent/Client/Swarm.hs deleted file mode 100644 index bd48f8a4..00000000 --- a/src/Network/BitTorrent/Client/Swarm.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Network.BitTorrent.Client.Swarm - ( Swarm - , newLeecher - , askPeers - ) where - -import Data.Default -import Data.Maybe -import Network - -import Data.Torrent -import Data.Torrent.InfoHash -import Network.BitTorrent.Core -import Network.BitTorrent.Tracker.Message -import Network.BitTorrent.Tracker.RPC as RPC - - -data Swarm = Swarm - { swarmTopic :: InfoHash - , thisPeerId :: PeerId - , listenerPort :: PortNumber - } - -newLeecher :: PeerId -> PortNumber -> Torrent -> IO Swarm -newLeecher pid port Torrent {..} = do - return Swarm - { swarmTopic = idInfoHash tInfoDict - , thisPeerId = pid - , listenerPort = port - } - -getAnnounceQuery :: Swarm -> AnnounceQuery -getAnnounceQuery Swarm {..} = AnnounceQuery - { reqInfoHash = swarmTopic - , reqPeerId = thisPeerId - , reqPort = listenerPort - , reqProgress = def - , reqIP = Nothing - , reqNumWant = Nothing - , reqEvent = Nothing - } - -askPeers :: Swarm -> IO [PeerAddr IP] -askPeers s @ Swarm {..} = do --- AnnounceInfo {..} <- RPC.announce (getAnnounceQuery s) trackerConn - return [] -- (getPeerList respPeers) - ---reannounce :: HTracker -> IO () ---reannounce = undefined - ---forceReannounce :: HTracker -> IO () ---forceReannounce = undefined diff --git a/src/Network/BitTorrent/Client/Types.hs b/src/Network/BitTorrent/Client/Types.hs new file mode 100644 index 00000000..0da24dc2 --- /dev/null +++ b/src/Network/BitTorrent/Client/Types.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Network.BitTorrent.Client.Types + ( -- * Core types + Handle (..) + , Client (..) + + -- * Monad BitTorrent + , BitTorrent (..) + , runBitTorrent + , getClient + + , MonadBitTorrent (..) + ) where + +import Control.Concurrent +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Function +import Data.HashMap.Strict as HM +import Data.Ord +import Network +import System.Log.FastLogger + +import Data.Torrent.InfoHash +import Network.BitTorrent.Core +import Network.BitTorrent.DHT as DHT +import Network.BitTorrent.Tracker as Tracker +import Network.BitTorrent.Exchange.Message + + +data Handle = Handle + { topic :: !InfoHash + , private :: !Bool + , trackers :: !Tracker.Session + } + +data Client = Client + { clientPeerId :: !PeerId + , clientListenerPort :: !PortNumber + , allowedExtensions :: !Caps + , trackerManager :: !Tracker.Manager + , clientNode :: !(Node IPv4) + , clientTorrents :: !(MVar (HashMap InfoHash Handle)) + , clientLogger :: !LogFun + } + +instance Eq Client where + (==) = (==) `on` clientPeerId + +instance Ord Client where + compare = comparing clientPeerId + +{----------------------------------------------------------------------- +-- BitTorrent monad +-----------------------------------------------------------------------} + +newtype BitTorrent a = BitTorrent + { unBitTorrent :: ReaderT Client (ResourceT IO) a + } deriving (Functor, Monad, MonadIO) + +class MonadBitTorrent m where + liftBT :: BitTorrent a -> m a + +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 -- cgit v1.2.3