From 46b6ba10202b73ba413d18bd21a284e3897c12b0 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 24 Dec 2013 23:50:23 +0400 Subject: Update tests --- tests/Network/KRPCSpec.hs | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 tests/Network/KRPCSpec.hs (limited to 'tests/Network/KRPCSpec.hs') diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs new file mode 100644 index 00000000..27148682 --- /dev/null +++ b/tests/Network/KRPCSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.KRPCSpec (spec) where +import Control.Monad.Reader +import Network.Socket (SockAddr (..)) +import Network.KRPC +import Network.KRPC.MethodSpec hiding (spec) +import Test.Hspec + +servAddr :: SockAddr +servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127) + +handlers :: [Handler IO] +handlers = + [ handler $ \ _ Ping -> return Ping + , handler $ \ _ (Echo a) -> return (Echo (a :: Bool)) + , handler $ \ _ (Echo a) -> return (Echo (a :: Int)) + ] + +spec :: Spec +spec = do + describe "query" $ do + it "run handlers" $ do + let int = 0xabcd :: Int + (withManager servAddr handlers $ runReaderT $ do + listen + query servAddr (Echo int)) + `shouldReturn` Echo int + + it "throw timeout exception" $ do + (withManager servAddr handlers $ runReaderT $ do + query servAddr (Echo (0xabcd :: Int)) + ) + `shouldThrow` (== KError GenericError "timeout expired" "0") -- cgit v1.2.3 From 3616542dc310d9e38f6aa2b2ad30274ce4a2db91 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 00:02:10 +0400 Subject: Update tests and benchmarks --- bench/Main.hs | 8 ++++++-- krpc.cabal | 2 ++ tests/Network/KRPCSpec.hs | 8 ++++++-- 3 files changed, 14 insertions(+), 4 deletions(-) (limited to 'tests/Network/KRPCSpec.hs') diff --git a/bench/Main.hs b/bench/Main.hs index 97f97425..13727ff9 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Monad +import Control.Monad.Logger import Control.Monad.Reader import Criterion.Main import Data.ByteString as BS @@ -11,6 +12,9 @@ import Network.KRPC instance KRPC ByteString ByteString where method = "echo" +instance MonadLogger IO where + monadLoggerLog _ _ _ _ = return () + echo :: Handler IO echo = handler $ \ _ bs -> return (bs :: ByteString) @@ -26,7 +30,7 @@ main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do repetitions = [1, 10, 100, 1000] benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes] where - mkbench m r n = + mkbench action r n = bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $ replicateM r $ - runReaderT (query addr (BS.replicate n 0)) m + runReaderT (query addr (BS.replicate n 0)) action diff --git a/krpc.cabal b/krpc.cabal index 7b0cafa2..b5004026 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -70,6 +70,7 @@ test-suite spec , bytestring , network , mtl + , monad-logger , hspec , QuickCheck , quickcheck-instances @@ -84,6 +85,7 @@ benchmark bench build-depends: base == 4.* , bytestring , mtl + , monad-logger , criterion , krpc ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 27148682..7f5b2794 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.KRPCSpec (spec) where +import Control.Monad.Logger import Control.Monad.Reader -import Network.Socket (SockAddr (..)) import Network.KRPC import Network.KRPC.MethodSpec hiding (spec) import Test.Hspec @@ -16,6 +17,9 @@ handlers = , handler $ \ _ (Echo a) -> return (Echo (a :: Int)) ] +instance MonadLogger IO where + monadLoggerLog _ _ _ _ = return () + spec :: Spec spec = do describe "query" $ do -- cgit v1.2.3 From 6e77e14e2c011760eccc9d6989cd229420bdc741 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 03:53:05 +0400 Subject: Allow to pass options from outside --- bench/Main.hs | 2 +- krpc.cabal | 1 + src/Network/KRPC.hs | 3 +++ src/Network/KRPC/Manager.hs | 60 +++++++++++++++++++++++++++++++++++---------- tests/Network/KRPCSpec.hs | 7 ++++-- 5 files changed, 57 insertions(+), 16 deletions(-) (limited to 'tests/Network/KRPCSpec.hs') diff --git a/bench/Main.hs b/bench/Main.hs index 13727ff9..8466f4a3 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -22,7 +22,7 @@ addr :: SockAddr addr = SockAddrInet 6000 (256 * 256 * 256 + 127) main :: IO () -main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do +main = withManager def addr [echo] $ \ m -> (`runReaderT` m) $ do listen liftIO $ defaultMain (benchmarks m) where diff --git a/krpc.cabal b/krpc.cabal index b5004026..be19775f 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -46,6 +46,7 @@ library build-depends: base == 4.* , bytestring >= 0.10 , text >= 0.11 + , data-default-class , lifted-base >= 0.1.1 , transformers >= 0.2 , mtl diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index a1767161..7c02702c 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -62,6 +62,8 @@ module Network.KRPC -- * Manager , MonadKRPC (..) + , Options (..) + , def , Manager , newManager , closeManager @@ -76,6 +78,7 @@ module Network.KRPC , SockAddr (..) ) where +import Data.Default.Class import Network.KRPC.Message import Network.KRPC.Method import Network.KRPC.Manager diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 4d1cfb69..7edcf72d 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -18,6 +18,7 @@ module Network.KRPC.Manager ( -- * Manager MonadKRPC (..) + , Options (..) , Manager , newManager , closeManager @@ -43,6 +44,7 @@ import Data.BEncode as BE import Data.ByteString as BS import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL +import Data.Default.Class import Data.IORef import Data.List as L import Data.Map as M @@ -58,6 +60,41 @@ import System.IO.Error import System.Timeout +{----------------------------------------------------------------------- +-- Options +-----------------------------------------------------------------------} + +-- | RPC manager options. +data Options = Options + { -- | Initial 'TransactionId' incremented with each 'query'; + optSeedTransaction :: Int + + -- | Time to wait for response from remote node, in seconds. + , optQueryTimeout :: Int + } deriving (Show, Eq) + +defaultSeedTransaction :: Int +defaultSeedTransaction = 0 + +defaultQueryTimeout :: Int +defaultQueryTimeout = 120 + +-- | Permissive defaults. +instance Default Options where + def = Options + { optSeedTransaction = defaultSeedTransaction + , optQueryTimeout = defaultQueryTimeout + } + +validateOptions :: Options -> IO () +validateOptions Options {..} + | optQueryTimeout < 1 = throwIO (userError "non-positive query timeout") + | otherwise = return () + +{----------------------------------------------------------------------- +-- Options +-----------------------------------------------------------------------} + type KResult = Either KError KResponse type TransactionCounter = IORef Int @@ -108,23 +145,19 @@ sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 sockAddrFamily (SockAddrUnix _ ) = AF_UNIX -seedTransaction :: Int -seedTransaction = 0 - -defaultQueryTimeout :: Int -defaultQueryTimeout = 120 - -- | Bind socket to the specified address. To enable query handling -- run 'listen'. -newManager :: SockAddr -- ^ address to listen on; +newManager :: Options -- ^ various protocol options; + -> SockAddr -- ^ address to listen on; -> [Handler h] -- ^ handlers to run on incoming queries. - -> IO (Manager h) -- ^ new manager. -newManager servAddr handlers = do + -> IO (Manager h) -- ^ new rpc manager. +newManager opts @ Options {..} servAddr handlers = do + validateOptions opts sock <- bindServ tref <- newEmptyMVar - tran <- newIORef seedTransaction + tran <- newIORef optSeedTransaction calls <- newIORef M.empty - return $ Manager sock defaultQueryTimeout tref tran calls handlers + return $ Manager sock optQueryTimeout tref tran calls handlers where bindServ = do let family = sockAddrFamily servAddr @@ -143,8 +176,9 @@ closeManager Manager {..} = do -- | Normally you should use Control.Monad.Trans.Resource.allocate -- function. -withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a -withManager addr hs = bracket (newManager addr hs) closeManager +withManager :: Options -> SockAddr -> [Handler h] + -> (Manager h -> IO a) -> IO a +withManager opts addr hs = bracket (newManager opts addr hs) closeManager {----------------------------------------------------------------------- -- Logging diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 7f5b2794..e73b1ec0 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -20,18 +20,21 @@ handlers = instance MonadLogger IO where monadLoggerLog _ _ _ _ = return () +opts :: Options +opts = def { optQueryTimeout = 1 } + spec :: Spec spec = do describe "query" $ do it "run handlers" $ do let int = 0xabcd :: Int - (withManager servAddr handlers $ runReaderT $ do + (withManager opts servAddr handlers $ runReaderT $ do listen query servAddr (Echo int)) `shouldReturn` Echo int it "throw timeout exception" $ do - (withManager servAddr handlers $ runReaderT $ do + (withManager opts servAddr handlers $ runReaderT $ do query servAddr (Echo (0xabcd :: Int)) ) `shouldThrow` (== KError GenericError "timeout expired" "0") -- cgit v1.2.3 From 6f909c0d81d04b997f8c81ec1ac05e94d7d1e5b6 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 06:26:35 +0400 Subject: Add HandlerFailure exceptions --- src/Network/KRPC.hs | 13 +++++----- src/Network/KRPC/Manager.hs | 60 ++++++++++++++++++++++++++++++++++++++------- src/Network/KRPC/Message.hs | 17 ------------- tests/Network/KRPCSpec.hs | 2 +- 4 files changed, 58 insertions(+), 34 deletions(-) (limited to 'tests/Network/KRPCSpec.hs') diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 96971803..69a4efca 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -56,13 +56,15 @@ module Network.KRPC , KRPC (..) -- * RPC - , Handler - , handler - -- ** Query , QueryFailure (..) , query + -- ** Handler + , HandlerFailure (..) + , Handler + , handler + -- * Manager , MonadKRPC (..) , Options (..) @@ -73,11 +75,8 @@ module Network.KRPC , withManager , listen - -- * Exceptions - , KError (..) + -- * Re-expor , ErrorCode (..) - - -- * Re-export , SockAddr (..) ) where diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 6799277f..222b961a 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -31,6 +31,7 @@ module Network.KRPC.Manager , query -- * Handlers + , HandlerFailure (..) , Handler , handler ) where @@ -39,7 +40,8 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Lifted (fork) import Control.Exception hiding (Handler) -import Control.Exception.Lifted as Lifted (catch, finally) +import qualified Control.Exception.Lifted as E (Handler (..)) +import Control.Exception.Lifted as Lifted (catches, finally) import Control.Monad import Control.Monad.Logger import Control.Monad.Reader @@ -288,9 +290,38 @@ query addr params = do {----------------------------------------------------------------------- -- Handlers -----------------------------------------------------------------------} +-- we already throw: +-- +-- * ErrorCode(MethodUnknown) in the 'dispatchHandler'; +-- +-- * ErrorCode(ServerError) in the 'runHandler'; (those can be +-- async exception too) +-- +-- * ErrorCode(GenericError) on + +-- | Used to signal protocol errors. +data HandlerFailure + = BadAddress -- ^ for e.g.: node calls herself; + | InvalidParameter Text -- ^ for e.g.: bad session token. + deriving (Show, Eq, Typeable) + +instance Exception HandlerFailure + +prettyHF :: HandlerFailure -> BS.ByteString +prettyHF BadAddress = T.encodeUtf8 "bad address" +prettyHF (InvalidParameter reason) = T.encodeUtf8 $ + "invalid parameter: " <> reason + +prettyQF :: QueryFailure -> BS.ByteString +prettyQF e = T.encodeUtf8 $ "handler fail while performing query: " + <> T.pack (show e) -- | Make handler from handler function. Any thrown exception will be -- supressed and send over the wire back to the querying node. +-- +-- If the handler make some 'query' normally it /should/ handle +-- corresponding 'QueryFailure's. +-- handler :: forall h a b. (KRPC a b, Monad h) => (SockAddr -> a -> h b) -> Handler h handler body = (name, wrapper) @@ -305,7 +336,7 @@ handler body = (name, wrapper) runHandler :: MonadKRPC h m => HandlerBody h -> SockAddr -> KQuery -> m KResult -runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback +runHandler h addr KQuery {..} = Lifted.catches wrapper failbacks where signature = querySignature queryMethod queryId addr @@ -315,22 +346,33 @@ runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback case result of Left msg -> do - $(logDebugS) "handler.failed" $ signature <> " !" <> T.pack msg - return $ Left $ decodeError msg queryId + $(logDebugS) "handler.bad_query" $ signature <> " !" <> T.pack msg + return $ Left $ KError ProtocolError (BC.pack msg) queryId Right a -> do $(logDebugS) "handler.success" signature - return $ Right $ a `KResponse` queryId + return $ Right $ KResponse a queryId + + failbacks = + [ E.Handler $ \ (e :: HandlerFailure) -> do + $(logDebugS) "handler.failed" signature + return $ Left $ KError ProtocolError (prettyHF e) queryId + + -- may happen if handler makes query and fail + , E.Handler $ \ (e :: QueryFailure) -> do + return $ Left $ KError ServerError (prettyQF e) queryId - failback e = do - $(logDebugS) "handler.errored" signature - return $ Left $ serverError e queryId + -- since handler thread exit after sendMessage we can safely + -- suppress async exception here + , E.Handler $ \ (e :: SomeException) -> do + return $ Left $ KError GenericError (BC.pack (show e)) queryId + ] dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult dispatchHandler q @ KQuery {..} addr = do Manager {..} <- getManager case L.lookup queryMethod handlers of - Nothing -> return $ Left $ unknownMethod queryMethod queryId + Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId Just h -> runHandler h addr q {----------------------------------------------------------------------- diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index d6279f11..96945843 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -26,11 +26,8 @@ module Network.KRPC.Message -- * Error , ErrorCode (..) , KError(..) - , serverError , decodeError - , unknownMethod , unknownMessage - , timeoutExpired -- * Query , KQuery(..) @@ -143,29 +140,15 @@ instance BEncode KError where instance Exception KError --- | Happen when some query handler fail. -serverError :: SomeException -> TransactionId -> KError -serverError e = KError ServerError (BC.pack (show e)) - -- | Received 'queryArgs' or 'respVals' can not be decoded. decodeError :: String -> TransactionId -> KError decodeError msg = KError ProtocolError (BC.pack msg) --- | If /remote/ node send query /this/ node doesn't know about then --- this error message should be sent in response. -unknownMethod :: MethodName -> TransactionId -> KError -unknownMethod = KError MethodUnknown - -- | A remote node has send some 'KMessage' this node is unable to -- decode. unknownMessage :: String -> KError unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction --- | A /remote/ node is not responding to the /our/ request the for --- specified period of time. -timeoutExpired :: TransactionId -> KError -timeoutExpired = KError GenericError "timeout expired" - {----------------------------------------------------------------------- -- Query messages -----------------------------------------------------------------------} diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index e73b1ec0..756c6855 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -37,4 +37,4 @@ spec = do (withManager opts servAddr handlers $ runReaderT $ do query servAddr (Echo (0xabcd :: Int)) ) - `shouldThrow` (== KError GenericError "timeout expired" "0") + `shouldThrow` (== TimeoutExpired) -- cgit v1.2.3 From 1fb619d9d5edc1c352e2b72cbf5dfcf5c64d05ff Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 06:56:28 +0400 Subject: Allow to ask for query count --- src/Network/KRPC.hs | 1 + src/Network/KRPC/Manager.hs | 8 ++++++++ tests/Network/KRPCSpec.hs | 9 +++++++++ 3 files changed, 18 insertions(+) (limited to 'tests/Network/KRPCSpec.hs') diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 69a4efca..3b722ac2 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -59,6 +59,7 @@ module Network.KRPC -- ** Query , QueryFailure (..) , query + , getQueryCount -- ** Handler , HandlerFailure (..) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 468744c1..e2b60b6a 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -29,6 +29,7 @@ module Network.KRPC.Manager -- * Queries , QueryFailure (..) , query + , getQueryCount -- * Handlers , HandlerFailure (..) @@ -232,6 +233,13 @@ genTransactionId ref = do cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur) return $ BC.pack (show cur) +-- | How many times 'query' call have been performed. +getQueryCount :: MonadKRPC h m => m Int +getQueryCount = do + Manager {..} <- getManager + curTrans <- liftIO $ readIORef transactionCounter + return $ curTrans - optSeedTransaction options + registerQuery :: CallId -> PendingCalls -> IO CallRes registerQuery cid ref = do ares <- newEmptyMVar diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 756c6855..e695a646 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -33,6 +33,15 @@ spec = do query servAddr (Echo int)) `shouldReturn` Echo int + it "count transactions properly" $ do + (withManager opts servAddr handlers $ runReaderT $ do + listen + _ <- query servAddr (Echo (0xabcd :: Int)) + _ <- query servAddr (Echo (0xabcd :: Int)) + getQueryCount + ) + `shouldReturn` 2 + it "throw timeout exception" $ do (withManager opts servAddr handlers $ runReaderT $ do query servAddr (Echo (0xabcd :: Int)) -- cgit v1.2.3 From 2cf3882c4b455abba8aebf7c5bc66e3720ca1598 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 19 Feb 2014 05:16:36 +0400 Subject: Add spec for isActive function --- tests/Network/KRPCSpec.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'tests/Network/KRPCSpec.hs') diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index e695a646..0a6dc8fb 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -25,6 +25,13 @@ opts = def { optQueryTimeout = 1 } spec :: Spec spec = do + describe "manager" $ do + it "is active until closeManager called" $ do + m <- newManager opts servAddr [] + isActive m `shouldReturn` True + closeManager m + isActive m `shouldReturn` False + describe "query" $ do it "run handlers" $ do let int = 0xabcd :: Int -- cgit v1.2.3 From 4ebd950f3f61dcc7f8287a3f9d1dcf44b9bfeac8 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 16 Aug 2014 13:10:38 +0100 Subject: Disambiguate KRPC instance inside spec --- tests/Network/KRPCSpec.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'tests/Network/KRPCSpec.hs') diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 0a6dc8fb..eabcc817 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -25,6 +25,9 @@ opts = def { optQueryTimeout = 1 } spec :: Spec spec = do + let qr :: MonadKRPC h m => SockAddr -> Echo Int -> m (Echo Int) + qr = query + describe "manager" $ do it "is active until closeManager called" $ do m <- newManager opts servAddr [] @@ -43,14 +46,14 @@ spec = do it "count transactions properly" $ do (withManager opts servAddr handlers $ runReaderT $ do listen - _ <- query servAddr (Echo (0xabcd :: Int)) - _ <- query servAddr (Echo (0xabcd :: Int)) + _ <- qr servAddr (Echo 0xabcd) + _ <- qr servAddr (Echo 0xabcd) getQueryCount ) `shouldReturn` 2 it "throw timeout exception" $ do (withManager opts servAddr handlers $ runReaderT $ do - query servAddr (Echo (0xabcd :: Int)) + qr servAddr (Echo 0xabcd) ) `shouldThrow` (== TimeoutExpired) -- cgit v1.2.3