Redesign core of client

4 files changed, 266 insertions, 145 deletions

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