summaryrefslogtreecommitdiff
path: root/src/Network/KRPC
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/KRPC')
-rw-r--r--src/Network/KRPC/Manager.hs55
-rw-r--r--src/Network/KRPC/Method.hs6
2 files changed, 41 insertions, 20 deletions
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 6bc448c6..cc2e383e 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -7,12 +7,14 @@
7-- 7--
8-- Normally, you don't need to import this module. 8-- Normally, you don't need to import this module.
9-- 9--
10{-# LANGUAGE FlexibleContexts #-} 10{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE DefaultSignatures #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
14{-# LANGUAGE FunctionalDependencies #-}
15{-# LANGUAGE FlexibleInstances #-} 11{-# LANGUAGE FlexibleInstances #-}
12{-# LANGUAGE FlexibleContexts #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE DefaultSignatures #-}
15{-# LANGUAGE MultiParamTypeClasses #-}
16{-# LANGUAGE FunctionalDependencies #-}
17{-# LANGUAGE TemplateHaskell #-}
16module Network.KRPC.Manager 18module Network.KRPC.Manager
17 ( -- * Manager 19 ( -- * Manager
18 MonadKRPC (..) 20 MonadKRPC (..)
@@ -35,6 +37,7 @@ import Control.Concurrent.Lifted (fork)
35import Control.Exception hiding (Handler) 37import Control.Exception hiding (Handler)
36import Control.Exception.Lifted as Lifted (catch) 38import Control.Exception.Lifted as Lifted (catch)
37import Control.Monad 39import Control.Monad
40import Control.Monad.Logger
38import Control.Monad.Reader 41import Control.Monad.Reader
39import Control.Monad.Trans.Control 42import Control.Monad.Trans.Control
40import Data.BEncode as BE 43import Data.BEncode as BE
@@ -43,6 +46,9 @@ import Data.ByteString.Lazy as BL
43import Data.IORef 46import Data.IORef
44import Data.List as L 47import Data.List as L
45import Data.Map as M 48import Data.Map as M
49import Data.Monoid
50import Data.Text as T
51import Data.Text.Encoding as T
46import Data.Tuple 52import Data.Tuple
47import Network.KRPC.Message 53import Network.KRPC.Message
48import Network.KRPC.Method 54import Network.KRPC.Method
@@ -76,7 +82,9 @@ data Manager h = Manager
76 } 82 }
77 83
78-- | A monad which can perform or handle queries. 84-- | A monad which can perform or handle queries.
79class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where 85class (MonadBaseControl IO m, MonadLogger m, MonadIO m)
86 => MonadKRPC h m | m -> h where
87
80 -- | Ask for manager. 88 -- | Ask for manager.
81 getManager :: m (Manager h) 89 getManager :: m (Manager h)
82 90
@@ -89,8 +97,9 @@ class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where
89 default liftHandler :: m a -> m a 97 default liftHandler :: m a -> m a
90 liftHandler = id 98 liftHandler = id
91 99
92instance (MonadBaseControl IO h, MonadIO h) 100instance (MonadBaseControl IO h, MonadLogger h, MonadIO h)
93 => MonadKRPC h (ReaderT (Manager h) h) where 101 => MonadKRPC h (ReaderT (Manager h) h) where
102
94 liftHandler = lift 103 liftHandler = lift
95 104
96sockAddrFamily :: SockAddr -> Family 105sockAddrFamily :: SockAddr -> Family
@@ -178,23 +187,33 @@ queryResponse ares = do
178query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b 187query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b
179query addr params = do 188query addr params = do
180 Manager {..} <- getManager 189 Manager {..} <- getManager
181 liftIO $ do 190 tid <- liftIO $ genTransactionId transactionCounter
182 tid <- genTransactionId transactionCounter 191 let queryMethod = method :: Method a b
183 let Method name = method :: Method a b 192 let signature = T.pack (show queryMethod)
184 let q = KQuery (toBEncode params) name tid 193 <> " @" <> T.pack (show addr)
185 194 <> " #" <> T.decodeUtf8 tid
195 $(logDebugS) "query.sending" signature
196
197 mres <- liftIO $ do
186 ares <- registerQuery (tid, addr) pendingCalls 198 ares <- registerQuery (tid, addr) pendingCalls
199
200 let q = KQuery (toBEncode params) (methodName queryMethod) tid
187 sendMessage sock addr q 201 sendMessage sock addr q
188 `onException` unregisterQuery (tid, addr) pendingCalls 202 `onException` unregisterQuery (tid, addr) pendingCalls
189 203
190 mres <- timeout (queryTimeout * 10 ^ (6 :: Int)) $ do 204 timeout (queryTimeout * 10 ^ (6 :: Int)) $ do
191 queryResponse ares 205 queryResponse ares
192 206
193 case mres of 207 case mres of
194 Just res -> return res 208 Just res -> do
195 Nothing -> do 209 $(logDebugS) "query.responded" $ signature
196 _ <- unregisterQuery (tid, addr) pendingCalls 210 return res
197 throwIO $ timeoutExpired tid 211
212 Nothing -> do
213 _ <- liftIO $ unregisterQuery (tid, addr) pendingCalls
214 $(logWarnS) "query.not_responding" $ signature
215 <> " for " <> T.pack (show queryTimeout) <> " seconds"
216 throw $ timeoutExpired tid
198 217
199{----------------------------------------------------------------------- 218{-----------------------------------------------------------------------
200-- Handlers 219-- Handlers
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs
index f70923f5..68f1fa4e 100644
--- a/src/Network/KRPC/Method.hs
+++ b/src/Network/KRPC/Method.hs
@@ -38,7 +38,7 @@ import Network.KRPC.Message
38-- 38--
39-- * result: Type of return value of the method. 39-- * result: Type of return value of the method.
40-- 40--
41newtype Method param result = Method MethodName 41newtype Method param result = Method { methodName :: MethodName }
42 deriving (Eq, Ord, IsString, BEncode) 42 deriving (Eq, Ord, IsString, BEncode)
43 43
44-- | Example: 44-- | Example:
@@ -74,7 +74,9 @@ showsMethod (Method name) =
74-- method = \"ping\" 74-- method = \"ping\"
75-- @ 75-- @
76-- 76--
77class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where 77class (Typeable req, BEncode req, Typeable resp, BEncode resp)
78 => KRPC req resp | req -> resp where
79
78 -- | Method name. Default implementation uses lowercased @req@ 80 -- | Method name. Default implementation uses lowercased @req@
79 -- datatype name. 81 -- datatype name.
80 -- 82 --