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/Handle.hs | 138 ++++++++++++++++++++++++++++++++ src/Network/BitTorrent/Client/Swarm.hs | 52 ------------ src/Network/BitTorrent/Client/Types.hs | 84 +++++++++++++++++++ 3 files changed, 222 insertions(+), 52 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/Client') 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