From eff48f66c6d8e7231eef0ef3c3561e19865a2637 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 07:17:15 +0400 Subject: + Add basic bench. --- bench/Main.hs | 17 +++++++++++++++++ bench/Server.hs | 11 +++++++++++ 2 files changed, 28 insertions(+) create mode 100644 bench/Main.hs create mode 100644 bench/Server.hs (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 00000000..411282a0 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Criterion.Main +import Remote.KRPC + + +addr :: RemoteAddr +addr = (0, 6000) + +echo :: Method [Int] [Int] +echo = method "echo" ["x"] ["x"] + +main :: IO () +main = defaultMain $ map mkbench [1, 10, 100, 1000] + where + mkbench n = bench (show n) $ nfIO $ call addr echo [1..n] \ No newline at end of file diff --git a/bench/Server.hs b/bench/Server.hs new file mode 100644 index 00000000..cb5ed316 --- /dev/null +++ b/bench/Server.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Remote.KRPC + + +echo :: Method [Int] [Int] +echo = method "echo" ["x"] ["x"] + +main :: IO () +main = server 6000 [ echo ==> return ] -- cgit v1.2.3 From d0038e9bde22751c9c926796a6c46be62a3cb81b Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:27:36 +0400 Subject: ~ Minor changes. --- bench/Main.hs | 11 ++++++++--- bench/Server.hs | 3 ++- examples/Client.hs | 4 ++++ examples/Server.hs | 1 + examples/Shared.hs | 6 +++++- krpc.cabal | 12 ++++++------ src/Remote/KRPC/Protocol.hs | 4 ++-- 7 files changed, 28 insertions(+), 13 deletions(-) (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs index 411282a0..87d39f14 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Criterion.Main import Remote.KRPC @@ -8,10 +11,12 @@ import Remote.KRPC addr :: RemoteAddr addr = (0, 6000) -echo :: Method [Int] [Int] +echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () -main = defaultMain $ map mkbench [1, 10, 100, 1000] +main = defaultMain $ map (mkbench 1) [1, 10, 100, 1000, 32 * 1024] + ++ map (mkbench 10) [1, 10, 100, 1000] where - mkbench n = bench (show n) $ nfIO $ call addr echo [1..n] \ No newline at end of file + mkbench r n = bench (show r ++ "/" ++ show n) $ nfIO $ + replicateM r $ call addr echo (B.replicate n 0) \ No newline at end of file diff --git a/bench/Server.hs b/bench/Server.hs index cb5ed316..ece5a7a9 100644 --- a/bench/Server.hs +++ b/bench/Server.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Data.ByteString (ByteString) import Remote.KRPC -echo :: Method [Int] [Int] +echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () diff --git a/examples/Client.hs b/examples/Client.hs index cd340a03..ec86639e 100644 --- a/examples/Client.hs +++ b/examples/Client.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import qualified Data.ByteString as B import System.Environment import Remote.KRPC import Shared @@ -16,6 +17,9 @@ main = do call addr reverseM [1..1000] print =<< call addr swapM (0, 1) print =<< call addr shiftR ((), 1, [2..10]) + let bs = B.replicate (32 * 1024) 0 + bs' <- call addr echoBytes bs + print (bs == bs') {- forM_ [1..] $ const $ do diff --git a/examples/Server.hs b/examples/Server.hs index 0407c304..f636b0be 100644 --- a/examples/Server.hs +++ b/examples/Server.hs @@ -9,6 +9,7 @@ main :: IO () main = server 6000 [ unitM ==> return , echoM ==> return + , echoBytes ==> return , swapM ==> \(a, b) -> return (b, a) , reverseM ==> return . reverse , shiftR ==> \(a, b, c) -> return (c, a, b) diff --git a/examples/Shared.hs b/examples/Shared.hs index 2d5b9cbb..e0e5268c 100644 --- a/examples/Shared.hs +++ b/examples/Shared.hs @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Shared - (echoM, unitM, swapM, reverseM, shiftR + (echoM, echoBytes, unitM, swapM, reverseM, shiftR ) where +import Data.ByteString (ByteString) import Remote.KRPC unitM :: Method () () @@ -11,6 +12,9 @@ unitM = method "unit" [] [] echoM :: Method Int Int echoM = method "echo" ["x"] ["x"] +echoBytes :: Method ByteString ByteString +echoBytes = method "echoBytes" ["x"] ["x"] + reverseM :: Method [Int] [Int] reverseM = method "reverse" ["xs"] ["ys"] diff --git a/krpc.cabal b/krpc.cabal index e0fdb718..b9bd0f1a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -46,13 +46,13 @@ library executable exsample-client main-is: Client.hs other-modules: Shared - build-depends: base == 4.*, krpc + build-depends: base == 4.*, krpc, bytestring hs-source-dirs: examples executable exsample-server main-is: Server.hs other-modules: Shared - build-depends: base == 4.*, krpc + build-depends: base == 4.*, krpc, bytestring hs-source-dirs: examples @@ -60,13 +60,13 @@ executable exsample-server executable bench-server main-is: Server.hs - build-depends: base == 4.*, krpc + build-depends: base == 4.*, krpc, bytestring hs-source-dirs: bench - ghc-options: -O2 + ghc-options: -O2 -fforce-recomp benchmark bench-client type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench - build-depends: base == 4.5.*, krpc, criterion - ghc-options: -O2 \ No newline at end of file + build-depends: base == 4.5.*, krpc, criterion, bytestring + ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 133c899a..29aaefed 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -6,7 +6,7 @@ -- Portability : portable -- -- This module provides straightforward implementation of KRPC --- protocol. In many situations Network.KRPC should be prefered +-- protocol. In many situations 'Network.KRPC' should be prefered -- since it gives more safe, convenient and high level api. -- -- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol @@ -176,7 +176,7 @@ withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) maxMsgSize :: Int -maxMsgSize = 16 * 1024 +maxMsgSize = 512 {-# INLINE maxMsgSize #-} -- cgit v1.2.3 From dca81a23bcec19ab7562322c2eb988b286afe944 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 12:01:47 +0400 Subject: + Add hunit tests. --- bench/Main.hs | 7 ++++++- krpc.cabal | 24 +++++++++++++++++------- tests/Client.hs | 53 +++++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 62 insertions(+), 22 deletions(-) (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs index 87d39f14..f9650d97 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -19,4 +19,9 @@ main = defaultMain $ map (mkbench 1) [1, 10, 100, 1000, 32 * 1024] ++ map (mkbench 10) [1, 10, 100, 1000] where mkbench r n = bench (show r ++ "/" ++ show n) $ nfIO $ - replicateM r $ call addr echo (B.replicate n 0) \ No newline at end of file + replicateM r $ call addr echo (B.replicate n 0) + +{- + forM_ [1..] $ const $ do + async addr myconcat (replicate 100 [1..10]) +-} diff --git a/krpc.cabal b/krpc.cabal index b9bd0f1a..bb3fdea6 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -42,18 +42,28 @@ library - -executable exsample-client +test-suite test-client + type: exitcode-stdio-1.0 main-is: Client.hs other-modules: Shared - build-depends: base == 4.*, krpc, bytestring - hs-source-dirs: examples + build-depends: base == 4.* + , bytestring + , krpc + + , HUnit + , test-framework + , test-framework-hunit -executable exsample-server + hs-source-dirs: tests + +executable test-server main-is: Server.hs other-modules: Shared - build-depends: base == 4.*, krpc, bytestring - hs-source-dirs: examples + build-depends: base == 4.* + , bytestring + , krpc + + hs-source-dirs: tests diff --git a/tests/Client.hs b/tests/Client.hs index ec86639e..c2ac6d01 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -3,6 +3,11 @@ module Main (main) where import qualified Data.ByteString as B import System.Environment + +import Test.HUnit hiding (Test) +import Test.Framework +import Test.Framework.Providers.HUnit + import Remote.KRPC import Shared @@ -11,17 +16,37 @@ addr :: RemoteAddr addr = (0, 6000) main :: IO () -main = do - print =<< call addr unitM () - print =<< call addr echoM 0 - call addr reverseM [1..1000] - print =<< call addr swapM (0, 1) - print =<< call addr shiftR ((), 1, [2..10]) - let bs = B.replicate (32 * 1024) 0 - bs' <- call addr echoBytes bs - print (bs == bs') - -{- - forM_ [1..] $ const $ do - async addr myconcat (replicate 100 [1..10]) --} +main = defaultMain tests + +(==?) :: (Eq a, Show a) => a -> IO a -> Assertion +expected ==? action = do + actual <- action + expected @=? actual + +tests :: [Test] +tests = + [ testCase "unit" $ + () ==? call addr unitM () + + , testCase "echo int" $ + 1234 ==? call addr echoM 1234 + + , testCase "reverse 1..100" $ + reverse [1..100] ==? call addr reverseM [1..100] + + , testCase "reverse empty list" $ + reverse [] ==? call addr reverseM [] + + , testCase "reverse singleton list" $ + reverse [1] ==? call addr reverseM [1] + + , testCase "swap pair" $ + (1, 0) ==? call addr swapM (0, 1) + + , testCase "shift triple" $ + ([2..10], (), 1) ==? call addr shiftR ((), 1, [2..10]) + + , testCase "echo bytestring" $ + let bs = B.replicate 400 0 in + bs ==? call addr echoBytes bs + ] -- cgit v1.2.3 From 0d11413c087536e34999c3d2295cace55600af4a Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 14:37:06 +0400 Subject: ~ Expose some functions. --- bench/Main.hs | 16 +++++++++++++--- src/Remote/KRPC.hs | 29 ++++++++++++++++++++++------- src/Remote/KRPC/Protocol.hs | 15 ++++++--------- 3 files changed, 41 insertions(+), 19 deletions(-) (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs index f9650d97..ed0d5a35 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -15,12 +15,22 @@ echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () -main = defaultMain $ map (mkbench 1) [1, 10, 100, 1000, 32 * 1024] - ++ map (mkbench 10) [1, 10, 100, 1000] +main = withRemote $ \remote -> do { + ; let sizes = [10, 100, 1000, 10000, 16 * 1024] + ; let repetitions = [1, 10, 100, 1000] + ; let params = [(r, s) | r <- repetitions, s <- sizes] + ; let benchmarks = (concatMap (\(a, b) -> [a, b]) $ zip + (map (uncurry (mkbench remote)) params) + (map (uncurry (mkbench_ remote)) params)) + ; defaultMain benchmarks + } where - mkbench r n = bench (show r ++ "/" ++ show n) $ nfIO $ + mkbench _ r n = bench (show r ++ "/" ++ show n) $ nfIO $ replicateM r $ call addr echo (B.replicate n 0) + mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ + replicateM r $ call_ re addr echo (B.replicate n 0) + {- forM_ [1..] $ const $ do async addr myconcat (replicate 100 [1..10]) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 0e9838f1..e1ad0853 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -100,6 +100,10 @@ module Remote.KRPC -- * Server , MethodHandler, (==>), server + + -- * Internal + , call_ + , withRemote ) where import Control.Applicative @@ -186,7 +190,8 @@ injectVals ps (toBEncode -> BList as) = L.zip ps as injectVals _ _ = error "KRPC.injectVals: impossible" {-# INLINE injectVals #-} - +-- | Alias to Socket, through might change in future. +type Remote = Socket -- | Represent any error mentioned by protocol specification that -- 'call', 'await' might throw. @@ -208,10 +213,10 @@ queryCall sock addr m arg = sendMessage q addr sock q = kquery (methodName m) (injectVals (methodParams m) arg) getResult :: BEncodable result - => KRemote -> KRemoteAddr + => KRemote -> Method param result -> IO result -getResult sock addr m = do - resp <- recvResponse addr sock +getResult sock m = do + resp <- recvResponse sock case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do @@ -228,9 +233,19 @@ call :: (MonadBaseControl IO host, MonadIO host) -> Method param result -- ^ Procedure to call. -> param -- ^ Arguments passed by callee to procedure. -> host result -- ^ Values returned by callee from the procedure. -call addr m arg = liftIO $ withRemote $ \sock -> do +call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg + +-- | The same as 'call' but use already opened socket. +call_ :: (MonadBaseControl IO host, MonadIO host) + => (BEncodable param, BEncodable result) + => Remote -- ^ Socket to use + -> RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. +call_ sock addr m arg = liftIO $ do queryCall sock addr m arg - getResult sock addr m + getResult sock m -- | Asynchonous result typically get from 'async' call. Used to defer @@ -265,7 +280,7 @@ async addr m arg = do liftIO $ withRemote $ \sock -> queryCall sock addr m arg return $ Async $ withRemote $ \sock -> - getResult sock addr m + getResult sock m -- | Will wait until the callee finished processing of procedure call -- and return its results. Throws 'RPCException' on any error diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 29aaefed..3f3b16d0 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -162,11 +162,6 @@ kresponse = KResponse . M.fromList type KRemoteAddr = (HostAddress, PortNumber) -remoteAddr :: KRemoteAddr -> SockAddr -remoteAddr = SockAddrInet <$> snd <*> fst -{-# INLINE remoteAddr #-} - - type KRemote = Socket withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a @@ -176,8 +171,11 @@ withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) maxMsgSize :: Int -maxMsgSize = 512 {-# INLINE maxMsgSize #-} +-- release +--maxMsgSize = 512 -- size of payload of one udp packet +-- bench +maxMsgSize = 64 * 1024 -- max udp size -- TODO eliminate toStrict @@ -189,9 +187,8 @@ sendMessage msg (host, port) sock = -- TODO check scheme -recvResponse :: KRemoteAddr -> KRemote -> IO (Either KError KResponse) -recvResponse addr sock = do - connect sock (remoteAddr addr) +recvResponse :: KRemote -> IO (Either KError KResponse) +recvResponse sock = do (raw, _) <- recvFrom sock maxMsgSize return $ case decoded raw of Right resp -> Right resp -- cgit v1.2.3 From 8a18d0d510bef4284688dfc6c9b7209983d1d193 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 09:12:18 +0400 Subject: ~ Remove duplicated benchmarks. --- bench/Main.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs index ed0d5a35..697ecce9 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -19,15 +19,10 @@ main = withRemote $ \remote -> do { ; let sizes = [10, 100, 1000, 10000, 16 * 1024] ; let repetitions = [1, 10, 100, 1000] ; let params = [(r, s) | r <- repetitions, s <- sizes] - ; let benchmarks = (concatMap (\(a, b) -> [a, b]) $ zip - (map (uncurry (mkbench remote)) params) - (map (uncurry (mkbench_ remote)) params)) + ; let benchmarks = map (uncurry (mkbench_ remote)) params ; defaultMain benchmarks } where - mkbench _ r n = bench (show r ++ "/" ++ show n) $ nfIO $ - replicateM r $ call addr echo (B.replicate n 0) - mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ replicateM r $ call_ re addr echo (B.replicate n 0) -- cgit v1.2.3 From 4bef345a5871255e12e685ca01f5cfb127ff691a Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:45:54 +0400 Subject: Update imports --- bench/Main.hs | 2 +- bench/Server.hs | 2 +- krpc.cabal | 6 +++--- src/Network/KRPC.hs | 4 ++-- src/Network/KRPC/Protocol.hs | 2 +- src/Network/KRPC/Scheme.hs | 6 +++--- tests/Client.hs | 2 +- tests/Server.hs | 2 +- tests/Shared.hs | 2 +- 9 files changed, 14 insertions(+), 14 deletions(-) (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs index 697ecce9..fdf76cc2 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -5,7 +5,7 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as B import Criterion.Main -import Remote.KRPC +import Network.KRPC addr :: RemoteAddr diff --git a/bench/Server.hs b/bench/Server.hs index ece5a7a9..444362c1 100644 --- a/bench/Server.hs +++ b/bench/Server.hs @@ -2,7 +2,7 @@ module Main (main) where import Data.ByteString (ByteString) -import Remote.KRPC +import Network.KRPC echo :: Method ByteString ByteString diff --git a/krpc.cabal b/krpc.cabal index 0ac9faac..435f446a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -38,9 +38,9 @@ library default-extensions: PatternGuards , RecordWildCards hs-source-dirs: src - exposed-modules: Remote.KRPC - , Remote.KRPC.Protocol - , Remote.KRPC.Scheme + exposed-modules: Network.KRPC + , Network.KRPC.Protocol + , Network.KRPC.Scheme build-depends: base == 4.* , lifted-base >= 0.1.1 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 5c913daa..e667853a 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -94,7 +94,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} -module Remote.KRPC +module Network.KRPC ( -- * Method Method(..) , method, idM @@ -128,7 +128,7 @@ import Data.Typeable import Network import GHC.Generics -import Remote.KRPC.Protocol +import Network.KRPC.Protocol -- | Method datatype used to describe name, parameters and return diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index d28fdbeb..69d900cc 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -17,7 +17,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DefaultSignatures #-} -module Remote.KRPC.Protocol +module Network.KRPC.Protocol ( -- * Error KError(..), ErrorCode, errorCode, mkKError diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs index ebdc7740..15f0b677 100644 --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -module Remote.KRPC.Scheme +module Network.KRPC.Scheme ( KMessage(..) , KQueryScheme(..), methodQueryScheme , KResponseScheme(..), methodRespScheme @@ -24,8 +24,8 @@ import Control.Applicative import Data.Map as M import Data.Set as S -import Remote.KRPC.Protocol -import Remote.KRPC +import Network.KRPC.Protocol +import Network.KRPC -- | Used to validate any message by its scheme diff --git a/tests/Client.hs b/tests/Client.hs index 313cd56e..db7a3219 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -14,7 +14,7 @@ import Test.HUnit hiding (Test) import Test.Framework import Test.Framework.Providers.HUnit -import Remote.KRPC +import Network.KRPC import Shared diff --git a/tests/Server.hs b/tests/Server.hs index aaf6d9f2..9e70b70b 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -2,7 +2,7 @@ module Main (main) where import Data.BEncode -import Remote.KRPC +import Network.KRPC import Shared diff --git a/tests/Shared.hs b/tests/Shared.hs index 1060cfc8..16547644 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -12,7 +12,7 @@ module Shared import Data.ByteString (ByteString) import Data.BEncode -import Remote.KRPC +import Network.KRPC unitM :: Method () () unitM = method "unit" [] [] -- cgit v1.2.3 From 258f21eb490ee3588dd3a1c7316ff41f7f355be7 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 1 Oct 2013 06:10:41 +0400 Subject: Allow passing ipv6 addresses --- README.md | 4 ++++ bench/Main.hs | 3 ++- bench/Server.hs | 3 ++- krpc.cabal | 4 ++++ src/Network/KRPC.hs | 9 +++++---- src/Network/KRPC/Protocol.hs | 25 ++++++++----------------- tests/Client.hs | 3 ++- tests/Server.hs | 3 ++- 8 files changed, 29 insertions(+), 25 deletions(-) (limited to 'bench') diff --git a/README.md b/README.md index ccbd6789..189bda04 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,10 @@ language, thus it's hard to shoot yourself in the foot accidently. See bittorrent DHT [specification][spec] for detailed protocol description. +### Example + +TODO + #### Modules * Remote.KRPC — simple interface which reduce all RPC related stuff to diff --git a/bench/Main.hs b/bench/Main.hs index fdf76cc2..024d4d93 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -6,10 +6,11 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Criterion.Main import Network.KRPC +import Network.Socket addr :: RemoteAddr -addr = (0, 6000) +addr = SockAddrInet 6000 0 echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] diff --git a/bench/Server.hs b/bench/Server.hs index 444362c1..ef20c08a 100644 --- a/bench/Server.hs +++ b/bench/Server.hs @@ -3,10 +3,11 @@ module Main (main) where import Data.ByteString (ByteString) import Network.KRPC +import Network.Socket echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () -main = server 6000 [ echo ==> return ] +main = server (SockAddrInet 6000 0) [ echo ==> return ] diff --git a/krpc.cabal b/krpc.cabal index d6995410..9929cea7 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -69,6 +69,7 @@ test-suite test-client , bencoding , krpc + , network , HUnit , test-framework @@ -84,6 +85,7 @@ executable test-server , bytestring , bencoding , krpc + , network executable bench-server default-language: Haskell2010 @@ -92,6 +94,7 @@ executable bench-server build-depends: base == 4.* , bytestring , krpc + , network ghc-options: -fforce-recomp benchmark bench-client @@ -103,4 +106,5 @@ benchmark bench-client , bytestring , criterion , krpc + , network ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index e667853a..3c9f9bee 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -97,7 +97,8 @@ module Network.KRPC ( -- * Method Method(..) - , method, idM + , method + , idM -- * Client , RemoteAddr @@ -349,11 +350,11 @@ infix 1 ==>@ -- it will not create new thread for each connection. -- server :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port used to accept incoming connections. + => KRemoteAddr -- ^ Port used to accept incoming connections. -> [MethodHandler remote] -- ^ Method table. -> remote () -server servport handlers = do - remoteServer servport $ \addr q -> do +server servAddr handlers = do + remoteServer servAddr $ \addr q -> do case dispatch (queryMethod q) of Nothing -> return $ Left $ MethodUnknown (queryMethod q) Just m -> m addr q diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index ad1dabca..2d905f06 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -202,10 +202,7 @@ kresponse :: [(ValName, BValue)] -> KResponse kresponse = KResponse . M.fromList {-# INLINE kresponse #-} - - -type KRemoteAddr = (HostAddress, PortNumber) - +type KRemoteAddr = SockAddr type KRemote = Socket withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a @@ -224,8 +221,7 @@ maxMsgSize = 64 * 1024 -- max udp size -- TODO eliminate toStrict sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg (host, port) sock = - sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) +sendMessage msg addr sock = sendAllTo sock (LB.toStrict (encoded msg)) addr {-# INLINE sendMessage #-} recvResponse :: KRemote -> IO (Either KError KResponse) @@ -239,26 +235,21 @@ recvResponse sock = do -- | Run server using a given port. Method invocation should be done manually. remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port number to listen. + => KRemoteAddr -- ^ Port number to listen. -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) -- ^ Handler. -> remote () -remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop +remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where bindServ = do sock <- socket AF_INET Datagram defaultProtocol - bindSocket sock (SockAddrInet servport iNADDR_ANY) + bindSocket sock servAddr return sock loop sock = forever $ do - (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - case addr of - SockAddrInet port host -> do - let kaddr = (host, port) - reply <- handleMsg bs kaddr - liftIO $ sendMessage reply kaddr sock - _ -> return () - + (bs, addr) <- liftIO $ recvFrom sock maxMsgSize + reply <- handleMsg bs addr + liftIO $ sendMessage reply addr sock where handleMsg bs addr = case decoded bs of Right query -> (either toBEncode toBEncode <$> action addr query) diff --git a/tests/Client.hs b/tests/Client.hs index db7a3219..cda01631 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -15,11 +15,12 @@ import Test.Framework import Test.Framework.Providers.HUnit import Network.KRPC +import Network.Socket import Shared addr :: RemoteAddr -addr = (0, 6000) +addr = SockAddrInet 6000 0 withServ :: FilePath -> IO () -> IO () withServ serv_path = bracket up terminateProcess . const diff --git a/tests/Server.hs b/tests/Server.hs index 9e70b70b..b4b34891 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -3,11 +3,12 @@ module Main (main) where import Data.BEncode import Network.KRPC +import Network.Socket import Shared main :: IO () -main = server 6000 +main = server (SockAddrInet 6000 0) [ unitM ==> return , echoM ==> return , echoBytes ==> return -- cgit v1.2.3 From d5bae29716f894f4f9c2623455db38260664ae16 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 00:47:43 +0400 Subject: Update benchmarks --- bench/Main.hs | 45 ++++++++++++++++++++++----------------------- bench/Server.hs | 13 ------------- krpc.cabal | 37 +++++++++++-------------------------- src/Network/KRPC.hs | 4 ++++ 4 files changed, 37 insertions(+), 62 deletions(-) delete mode 100644 bench/Server.hs (limited to 'bench') diff --git a/bench/Main.hs b/bench/Main.hs index 024d4d93..97f97425 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,33 +1,32 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where - import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Control.Monad.Reader import Criterion.Main +import Data.ByteString as BS import Network.KRPC -import Network.Socket +instance KRPC ByteString ByteString where + method = "echo" -addr :: RemoteAddr -addr = SockAddrInet 6000 0 +echo :: Handler IO +echo = handler $ \ _ bs -> return (bs :: ByteString) -echo :: Method ByteString ByteString -echo = method "echo" ["x"] ["x"] +addr :: SockAddr +addr = SockAddrInet 6000 (256 * 256 * 256 + 127) main :: IO () -main = withRemote $ \remote -> do { - ; let sizes = [10, 100, 1000, 10000, 16 * 1024] - ; let repetitions = [1, 10, 100, 1000] - ; let params = [(r, s) | r <- repetitions, s <- sizes] - ; let benchmarks = map (uncurry (mkbench_ remote)) params - ; defaultMain benchmarks - } +main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do + listen + liftIO $ defaultMain (benchmarks m) where - mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ - replicateM r $ call_ re addr echo (B.replicate n 0) - -{- - forM_ [1..] $ const $ do - async addr myconcat (replicate 100 [1..10]) --} + sizes = [10, 100, 1000, 10000, 16 * 1024] + repetitions = [1, 10, 100, 1000] + benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes] + where + mkbench m r n = + bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $ + replicateM r $ + runReaderT (query addr (BS.replicate n 0)) m diff --git a/bench/Server.hs b/bench/Server.hs deleted file mode 100644 index ef20c08a..00000000 --- a/bench/Server.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Data.ByteString (ByteString) -import Network.KRPC -import Network.Socket - - -echo :: Method ByteString ByteString -echo = method "echo" ["x"] ["x"] - -main :: IO () -main = server (SockAddrInet 6000 0) [ echo ==> return ] diff --git a/krpc.cabal b/krpc.cabal index c4c0ae10..ffd23298 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -43,7 +43,6 @@ library Network.KRPC.Message Network.KRPC.Method Network.KRPC.Manager - build-depends: base == 4.* , bytestring >= 0.10 , lifted-base >= 0.1.1 @@ -53,10 +52,8 @@ library , bencoding >= 0.4.3 , network >= 2.3 , containers - if impl(ghc < 7.6) build-depends: ghc-prim - ghc-options: -Wall test-suite spec @@ -71,32 +68,20 @@ test-suite spec , bytestring , network , mtl - , hspec , QuickCheck , quickcheck-instances - , bencoding , krpc ---executable bench-server --- default-language: Haskell2010 --- hs-source-dirs: bench --- main-is: Server.hs --- build-depends: base == 4.* --- , bytestring --- , krpc --- , network --- ghc-options: -fforce-recomp - ---benchmark bench-client --- type: exitcode-stdio-1.0 --- default-language: Haskell2010 --- hs-source-dirs: bench --- main-is: Main.hs --- build-depends: base == 4.* --- , bytestring --- , criterion --- , krpc --- , network --- ghc-options: -O2 -fforce-recomp \ No newline at end of file +benchmark bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base == 4.* + , bytestring + , mtl + , criterion + , krpc + ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 10d2eb55..286c063e 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -107,8 +107,12 @@ module Network.KRPC -- * Exceptions , KError (..) , ErrorCode (..) + + -- * Re-export + , SockAddr (..) ) where import Network.KRPC.Message import Network.KRPC.Method import Network.KRPC.Manager +import Network.Socket (SockAddr (..)) \ No newline at end of file -- 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 'bench') 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 'bench') 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