1 files changed, 188 insertions, 0 deletions

diff --git a/bittorrent/src/Network/BitTorrent/Client/Handle.hs b/bittorrent/src/Network/BitTorrent/Client/Handle.hs
new file mode 100644
index 00000000..66baac48
--- /dev/null
+++ b/bittorrent/src/Network/BitTorrent/Client/Handle.hs
@@ -0,0 +1,188 @@
+module Network.BitTorrent.Client.Handle
+       ( -- * Handle
+         Handle
+
+         -- * Initialization
+       , openTorrent
+       , openMagnet
+       , closeHandle
+
+         -- * Control
+       , start
+       , pause
+       , stop
+
+         -- * Query
+       , getHandle
+       , getStatus
+       ) where
+
+import Control.Concurrent.Chan.Split
+import Control.Concurrent.Lifted as L
+import Control.Monad
+import Control.Monad.Trans
+import Data.Default
+import Data.List as L
+import Data.HashMap.Strict as HM
+
+import Data.Torrent
+import Network.BitTorrent.Client.Types as Types
+import Network.BitTorrent.DHT      as DHT
+import Network.BitTorrent.Exchange as Exchange
+import Network.BitTorrent.Tracker  as Tracker
+
+{-----------------------------------------------------------------------
+--  Safe handle set manupulation
+-----------------------------------------------------------------------}
+
+allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle
+allocHandle ih m = do
+  Client {..} <- getClient
+
+  (h, added) <- modifyMVar clientTorrents $ \ handles -> do
+    case HM.lookup ih handles of
+      Just h  -> return (handles, (h, False))
+      Nothing -> do
+        h <- m
+        return (HM.insert ih h handles, (h, True))
+
+  when added $ do
+    liftIO $ send clientEvents (TorrentAdded ih)
+
+  return h
+
+freeHandle :: InfoHash -> BitTorrent () -> BitTorrent ()
+freeHandle ih finalizer = do
+  Client {..} <- getClient
+
+  modifyMVar_ clientTorrents $ \ handles -> do
+    case HM.lookup ih handles of
+      Nothing -> return handles
+      Just _  -> do
+        finalizer
+        return (HM.delete ih handles)
+
+lookupHandle :: InfoHash -> BitTorrent (Maybe Handle)
+lookupHandle ih = do
+  Client {..} <- getClient
+  handles     <- readMVar clientTorrents
+  return (HM.lookup ih handles)
+
+{-----------------------------------------------------------------------
+--  Initialization
+-----------------------------------------------------------------------}
+
+newExchangeSession :: FilePath -> Either InfoHash InfoDict -> BitTorrent Exchange.Session
+newExchangeSession rootPath source = do
+  c @ Client {..} <- getClient
+  liftIO $ Exchange.newSession clientLogger (externalAddr c) rootPath source
+
+-- | Open a torrent in 'stop'ed state. Use 'nullTorrent' to open
+-- handle from 'InfoDict'. This operation do not block.
+openTorrent :: FilePath -> Torrent -> BitTorrent Handle
+openTorrent rootPath t @ Torrent {..} = do
+  let ih = idInfoHash tInfoDict
+  allocHandle ih $ do
+    statusVar <- newMVar Types.Stopped
+    tses <- liftIO $ Tracker.newSession ih (trackerList t)
+    eses <- newExchangeSession rootPath (Right tInfoDict)
+    eventStream <- liftIO newSendPort
+    return $ Handle
+      { handleTopic    = ih
+      , handlePrivate  = idPrivate tInfoDict
+      , handleStatus   = statusVar
+      , handleTrackers = tses
+      , handleExchange = eses
+      , handleEvents   = eventStream
+      }
+
+-- | Use 'nullMagnet' to open handle from 'InfoHash'.
+openMagnet :: FilePath -> Magnet -> BitTorrent Handle
+openMagnet rootPath Magnet {..} = do
+  allocHandle exactTopic $ do
+    statusVar <- newMVar Types.Stopped
+    tses <- liftIO $ Tracker.newSession exactTopic def
+    eses <- newExchangeSession rootPath (Left exactTopic)
+    eventStream <- liftIO newSendPort
+    return $ Handle
+      { handleTopic    = exactTopic
+      , handlePrivate  = False
+      , handleStatus   = statusVar
+      , handleTrackers = tses
+      , handleExchange = eses
+      , handleEvents   = eventStream
+      }
+
+-- | 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 handleTopic $ do
+    Client {..} <- getClient
+    stop h
+    liftIO $ Exchange.closeSession handleExchange
+    liftIO $ Tracker.closeSession trackerManager handleTrackers
+
+{-----------------------------------------------------------------------
+--  Control
+-----------------------------------------------------------------------}
+
+modifyStatus :: HandleStatus -> Handle -> (HandleStatus -> BitTorrent ()) -> BitTorrent ()
+modifyStatus targetStatus Handle {..} targetAction = do
+  modifyMVar_ handleStatus $ \ actualStatus -> do
+    unless (actualStatus == targetStatus) $ do
+      targetAction actualStatus
+    return targetStatus
+  liftIO $ send handleEvents (StatusChanged targetStatus)
+
+-- | Start downloading, uploading and announcing this torrent.
+--
+-- This operation is blocking, use
+-- 'Control.Concurrent.Async.Lifted.async' if needed.
+start :: Handle -> BitTorrent ()
+start h @ Handle {..} = do
+  modifyStatus Types.Running h $ \ status -> do
+    case status of
+      Types.Running -> return ()
+      Types.Stopped -> do
+        Client {..} <- getClient
+        liftIO $ Tracker.notify trackerManager handleTrackers Tracker.Started
+        unless handlePrivate $ do
+          liftDHT $ DHT.insert handleTopic (error "start")
+        liftIO $ do
+          peers <- askPeers trackerManager handleTrackers
+          print $ "got: " ++ show (L.length peers) ++ " peers"
+          forM_ peers $ \ peer -> do
+            Exchange.connect peer handleExchange
+
+-- | Stop downloading this torrent.
+pause :: Handle -> BitTorrent ()
+pause _ = return ()
+
+-- | Stop downloading, uploading and announcing this torrent.
+stop :: Handle -> BitTorrent ()
+stop h @ Handle {..} = do
+  modifyStatus Types.Stopped h $ \ status -> do
+    case status of
+      Types.Stopped -> return ()
+      Types.Running -> do
+        Client {..} <- getClient
+        unless handlePrivate $ do
+          liftDHT $ DHT.delete handleTopic (error "stop")
+        liftIO  $ Tracker.notify trackerManager handleTrackers Tracker.Stopped
+
+{-----------------------------------------------------------------------
+--  Query
+-----------------------------------------------------------------------}
+
+getHandle :: InfoHash -> BitTorrent Handle
+getHandle ih = do
+  mhandle <- lookupHandle ih
+  case mhandle of
+    Nothing -> error "should we throw some exception?"
+    Just h  -> return h
+
+getStatus :: Handle -> IO HandleStatus
+getStatus Handle {..} = readMVar handleStatus