summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/KRPC/Manager.hs18
1 files changed, 15 insertions, 3 deletions
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 9d8688d3..a8c90b33 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -55,6 +55,7 @@ type Handler h = (MethodName, HandlerBody h)
55data Manager h = Manager 55data Manager h = Manager
56 { sock :: !Socket 56 { sock :: !Socket
57 , queryTimeout :: !Int -- ^ in seconds 57 , queryTimeout :: !Int -- ^ in seconds
58 , listenerThread :: !(MVar ThreadId)
58 , transactionCounter :: {-# UNPACK #-} !TransactionCounter 59 , transactionCounter :: {-# UNPACK #-} !TransactionCounter
59 , pendingCalls :: {-# UNPACK #-} !PendingCalls 60 , pendingCalls :: {-# UNPACK #-} !PendingCalls
60 , handlers :: [Handler h] 61 , handlers :: [Handler h]
@@ -68,6 +69,9 @@ class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where
68 69
69 liftHandler :: h a -> m a 70 liftHandler :: h a -> m a
70 71
72 default liftHandler :: m a -> m a
73 liftHandler = id
74
71instance (MonadBaseControl IO h, MonadIO h) 75instance (MonadBaseControl IO h, MonadIO h)
72 => MonadKRPC h (ReaderT (Manager h) h) where 76 => MonadKRPC h (ReaderT (Manager h) h) where
73 liftHandler = lift 77 liftHandler = lift
@@ -86,9 +90,10 @@ defaultQueryTimeout = 120
86newManager :: SockAddr -> [Handler h] -> IO (Manager h) 90newManager :: SockAddr -> [Handler h] -> IO (Manager h)
87newManager servAddr handlers = do 91newManager servAddr handlers = do
88 sock <- bindServ 92 sock <- bindServ
93 tref <- newEmptyMVar
89 tran <- newIORef seedTransaction 94 tran <- newIORef seedTransaction
90 calls <- newIORef M.empty 95 calls <- newIORef M.empty
91 return $ Manager sock defaultQueryTimeout tran calls handlers 96 return $ Manager sock defaultQueryTimeout tref tran calls handlers
92 where 97 where
93 bindServ = do 98 bindServ = do
94 let family = sockAddrFamily servAddr 99 let family = sockAddrFamily servAddr
@@ -101,9 +106,11 @@ newManager servAddr handlers = do
101-- | Unblock all pending calls and close socket. 106-- | Unblock all pending calls and close socket.
102closeManager :: Manager m -> IO () 107closeManager :: Manager m -> IO ()
103closeManager Manager {..} = do 108closeManager Manager {..} = do
109 maybe (return ()) killThread =<< tryTakeMVar listenerThread
104 -- TODO unblock calls 110 -- TODO unblock calls
105 close sock 111 close sock
106 112
113-- | Normally you should use Control.Monad.Trans.allocate function.
107withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a 114withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a
108withManager addr hs = bracket (newManager addr hs) closeManager 115withManager addr hs = bracket (newManager addr hs) closeManager
109 116
@@ -236,5 +243,10 @@ listener = do
236 Left e -> liftIO $ sendMessage sock addr $ unknownMessage e 243 Left e -> liftIO $ sendMessage sock addr $ unknownMessage e
237 Right m -> handleMessage m addr 244 Right m -> handleMessage m addr
238 245
239listen :: MonadKRPC h m => m ThreadId 246-- | Should be run before any 'query', otherwise they will never
240listen = fork $ listener 247-- succeed.
248listen :: MonadKRPC h m => m ()
249listen = do
250 Manager {..} <- getManager
251 tid <- fork $ listener
252 liftIO $ putMVar listenerThread tid