Redesign core of client

3 files changed, 222 insertions, 52 deletions

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