summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Network/BitTorrent/Client/Handle.hs14
-rw-r--r--src/Network/BitTorrent/Client/Types.hs15
2 files changed, 21 insertions, 8 deletions
diff --git a/src/Network/BitTorrent/Client/Handle.hs b/src/Network/BitTorrent/Client/Handle.hs
index 6e2dd0dc..2da3b357 100644
--- a/src/Network/BitTorrent/Client/Handle.hs
+++ b/src/Network/BitTorrent/Client/Handle.hs
@@ -19,7 +19,7 @@ module Network.BitTorrent.Client.Handle
19 ) where 19 ) where
20 20
21import Control.Applicative 21import Control.Applicative
22import Control.Concurrent 22import Control.Concurrent.Lifted as L
23import Control.Monad 23import Control.Monad
24import Control.Monad.Trans 24import Control.Monad.Trans
25import Data.Default 25import Data.Default
@@ -40,28 +40,28 @@ import Network.BitTorrent.Tracker as Tracker
40 40
41allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle 41allocHandle :: InfoHash -> BitTorrent Handle -> BitTorrent Handle
42allocHandle ih m = do 42allocHandle ih m = do
43 c @ Client {..} <- getClient 43 Client {..} <- getClient
44 liftIO $ modifyMVar clientTorrents $ \ handles -> do 44 modifyMVar clientTorrents $ \ handles -> do
45 case HM.lookup ih handles of 45 case HM.lookup ih handles of
46 Just h -> return (handles, h) 46 Just h -> return (handles, h)
47 Nothing -> do 47 Nothing -> do
48 h <- runBitTorrent c m 48 h <- m
49 return (HM.insert ih h handles, h) 49 return (HM.insert ih h handles, h)
50 50
51freeHandle :: InfoHash -> BitTorrent () -> BitTorrent () 51freeHandle :: InfoHash -> BitTorrent () -> BitTorrent ()
52freeHandle ih finalizer = do 52freeHandle ih finalizer = do
53 c @ Client {..} <- getClient 53 c @ Client {..} <- getClient
54 liftIO $ modifyMVar_ clientTorrents $ \ handles -> do 54 modifyMVar_ clientTorrents $ \ handles -> do
55 case HM.lookup ih handles of 55 case HM.lookup ih handles of
56 Nothing -> return handles 56 Nothing -> return handles
57 Just _ -> do 57 Just _ -> do
58 runBitTorrent c finalizer 58 finalizer
59 return (HM.delete ih handles) 59 return (HM.delete ih handles)
60 60
61lookupHandle :: InfoHash -> BitTorrent (Maybe Handle) 61lookupHandle :: InfoHash -> BitTorrent (Maybe Handle)
62lookupHandle ih = do 62lookupHandle ih = do
63 Client {..} <- getClient 63 Client {..} <- getClient
64 handles <- liftIO $ readMVar clientTorrents 64 handles <- readMVar clientTorrents
65 return (HM.lookup ih handles) 65 return (HM.lookup ih handles)
66 66
67{----------------------------------------------------------------------- 67{-----------------------------------------------------------------------
diff --git a/src/Network/BitTorrent/Client/Types.hs b/src/Network/BitTorrent/Client/Types.hs
index d6b08efe..c0d50175 100644
--- a/src/Network/BitTorrent/Client/Types.hs
+++ b/src/Network/BitTorrent/Client/Types.hs
@@ -1,4 +1,6 @@
1{-# LANGUAGE FlexibleInstances #-} 1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-} 4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3module Network.BitTorrent.Client.Types 5module Network.BitTorrent.Client.Types
4 ( -- * Core types 6 ( -- * Core types
@@ -20,8 +22,10 @@ module Network.BitTorrent.Client.Types
20import Control.Applicative 22import Control.Applicative
21import Control.Concurrent 23import Control.Concurrent
22import Control.Concurrent.Chan.Split 24import Control.Concurrent.Chan.Split
25import Control.Monad.Base
23import Control.Monad.Logger 26import Control.Monad.Logger
24import Control.Monad.Reader 27import Control.Monad.Reader
28import Control.Monad.Trans.Control
25import Control.Monad.Trans.Resource 29import Control.Monad.Trans.Resource
26import Data.Function 30import Data.Function
27import Data.HashMap.Strict as HM 31import Data.HashMap.Strict as HM
@@ -82,12 +86,21 @@ data ClientEvent
82newtype BitTorrent a = BitTorrent 86newtype BitTorrent a = BitTorrent
83 { unBitTorrent :: ReaderT Client IO a 87 { unBitTorrent :: ReaderT Client IO a
84 } deriving ( Functor, Applicative, Monad 88 } deriving ( Functor, Applicative, Monad
85 , MonadIO, MonadThrow, MonadUnsafeIO 89 , MonadIO, MonadThrow, MonadUnsafeIO, MonadBase IO
86 ) 90 )
87 91
88class MonadBitTorrent m where 92class MonadBitTorrent m where
89 liftBT :: BitTorrent a -> m a 93 liftBT :: BitTorrent a -> m a
90 94
95instance MonadBaseControl IO BitTorrent where
96 newtype StM BitTorrent a = StM { unSt :: StM (ReaderT Client IO) a }
97 liftBaseWith cc = BitTorrent $ liftBaseWith $ \ cc' ->
98 cc $ \ (BitTorrent m) -> StM <$> cc' m
99 {-# INLINE liftBaseWith #-}
100
101 restoreM = BitTorrent . restoreM . unSt
102 {-# INLINE restoreM #-}
103
91-- | NOP. 104-- | NOP.
92instance MonadBitTorrent BitTorrent where 105instance MonadBitTorrent BitTorrent where
93 liftBT = id 106 liftBT = id