From 50490ccb9ac98dc03a499972e693da8514779be6 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:57:25 +0400 Subject: ~ Move exsamples to tests. --- tests/Client.hs | 27 +++++++++++++++++++++++++++ tests/Server.hs | 16 ++++++++++++++++ tests/Shared.hs | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 93 insertions(+) create mode 100644 tests/Client.hs create mode 100644 tests/Server.hs create mode 100644 tests/Shared.hs (limited to 'tests') diff --git a/tests/Client.hs b/tests/Client.hs new file mode 100644 index 00000000..ec86639e --- /dev/null +++ b/tests/Client.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.ByteString as B +import System.Environment +import Remote.KRPC +import Shared + + +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]) +-} diff --git a/tests/Server.hs b/tests/Server.hs new file mode 100644 index 00000000..f636b0be --- /dev/null +++ b/tests/Server.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE IncoherentInstances #-} +module Main (main) where + +import Remote.KRPC +import Shared + + +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/tests/Shared.hs b/tests/Shared.hs new file mode 100644 index 00000000..e0e5268c --- /dev/null +++ b/tests/Shared.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +module Shared + (echoM, echoBytes, unitM, swapM, reverseM, shiftR + ) where + +import Data.ByteString (ByteString) +import Remote.KRPC + +unitM :: Method () () +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"] + +swapM :: Method (Int, Int) (Int, Int) +swapM = method "swap" ["x", "y"] ["b", "a"] + +shiftR :: Method ((), Int, [Int]) ([Int], (), Int) +shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] + + + +{- +type NodeId = Int +type InfoHashe = Int +type NodeAddr = Int +type Token = Int +type + +ping :: Method NodeId NodeId +ping = method "ping" ["id"] ["id"] + +find_node :: Method (NodeId, NodeId) (NodeId, NodeAddr) +find_node = method "find_node" ["id", "target"] ["id", "nodes"] + +get_peers :: Method (NodeId :*: InfoHash) (NodeId, Token, NodeAddr :|: NodeAddr) +get_peers = method "get_peers" + ("id", "target") + ("id", "token", view ("values" :|: "nodes")) +view :: BEncodable -> Maybe BEncodable +view = undefined +announce_peer :: Method (NodeId, InfoHash, PortNumber, Token) NodeId +announce_peer = undefined +-} \ No newline at end of file -- 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 'tests') 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 835854192f3b49b9abca0827df5c7c81d9ec0a75 Mon Sep 17 00:00:00 2001 From: Sam T Date: Wed, 15 May 2013 18:46:33 +0400 Subject: - Remove some useless comments. --- tests/Shared.hs | 25 ------------------------- 1 file changed, 25 deletions(-) (limited to 'tests') diff --git a/tests/Shared.hs b/tests/Shared.hs index e0e5268c..bf29365b 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -23,28 +23,3 @@ swapM = method "swap" ["x", "y"] ["b", "a"] shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] - - - -{- -type NodeId = Int -type InfoHashe = Int -type NodeAddr = Int -type Token = Int -type - -ping :: Method NodeId NodeId -ping = method "ping" ["id"] ["id"] - -find_node :: Method (NodeId, NodeId) (NodeId, NodeAddr) -find_node = method "find_node" ["id", "target"] ["id", "nodes"] - -get_peers :: Method (NodeId :*: InfoHash) (NodeId, Token, NodeAddr :|: NodeAddr) -get_peers = method "get_peers" - ("id", "target") - ("id", "token", view ("values" :|: "nodes")) -view :: BEncodable -> Maybe BEncodable -view = undefined -announce_peer :: Method (NodeId, InfoHash, PortNumber, Token) NodeId -announce_peer = undefined --} \ No newline at end of file -- cgit v1.2.3 From 3093d1ffb375b70e125bba4aacefa03d56d094c6 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 07:31:40 +0400 Subject: ~ Run server from test client. --- krpc.cabal | 3 +++ tests/Client.hs | 18 +++++++++++++++++- 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index bb3fdea6..446c612d 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -48,6 +48,9 @@ test-suite test-client other-modules: Shared build-depends: base == 4.* , bytestring + , process + , filepath + , krpc , HUnit diff --git a/tests/Client.hs b/tests/Client.hs index c2ac6d01..d762976d 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -1,8 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Control.Concurrent +import Control.Exception import qualified Data.ByteString as B import System.Environment +import System.Process +import System.FilePath import Test.HUnit hiding (Test) import Test.Framework @@ -15,8 +19,20 @@ import Shared addr :: RemoteAddr addr = (0, 6000) +withServ :: FilePath -> IO () -> IO () +withServ serv_path = bracket up terminateProcess . const + where + up = do + (_, _, _, h) <- createProcess (proc serv_path []) + threadDelay 1000000 + return h + main :: IO () -main = defaultMain tests +main = do + let serv_path = "dist" "build" "test-server" "test-server" + withServ serv_path $ + defaultMain tests + (==?) :: (Eq a, Show a) => a -> IO a -> Assertion expected ==? action = do -- cgit v1.2.3 From 2be391c59deb670fd8084c6bd0fa9c2cbe2fd5cf Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 21:03:55 +0400 Subject: ~ Add test case, fix cabal. --- krpc.cabal | 5 +++-- tests/Client.hs | 4 ++++ tests/Server.hs | 2 ++ tests/Shared.hs | 12 +++++++++++- 4 files changed, 20 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index 78a4aaeb..54746433 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -43,7 +43,6 @@ library , network >= 2.3 - hs-source-dirs: src extensions: PatternGuards ghc-options: -Wall @@ -59,6 +58,7 @@ test-suite test-client , process , filepath + , bencoding , krpc , HUnit @@ -72,6 +72,7 @@ executable test-server other-modules: Shared build-depends: base == 4.* , bytestring + , bencoding , krpc hs-source-dirs: tests @@ -89,5 +90,5 @@ benchmark bench-client type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench - build-depends: base == 4.5.*, krpc, criterion, bytestring + build-depends: base == 4.*, krpc, criterion, bytestring ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/tests/Client.hs b/tests/Client.hs index d762976d..1b9ef8d2 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -4,6 +4,7 @@ module Main (main) where import Control.Concurrent import Control.Exception import qualified Data.ByteString as B +import Data.BEncode import System.Environment import System.Process import System.FilePath @@ -65,4 +66,7 @@ tests = , testCase "echo bytestring" $ let bs = B.replicate 400 0 in bs ==? call addr echoBytes bs + + , testCase "raw method" $ + BInteger 10 ==? call addr rawM (BInteger 10) ] diff --git a/tests/Server.hs b/tests/Server.hs index f636b0be..7cd6a5d6 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE IncoherentInstances #-} module Main (main) where +import Data.BEncode import Remote.KRPC import Shared @@ -13,4 +14,5 @@ main = server 6000 , swapM ==> \(a, b) -> return (b, a) , reverseM ==> return . reverse , shiftR ==> \(a, b, c) -> return (c, a, b) + , rawM ==> return ] diff --git a/tests/Shared.hs b/tests/Shared.hs index bf29365b..a04b6093 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -1,9 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module Shared - (echoM, echoBytes, unitM, swapM, reverseM, shiftR + ( echoM + , echoBytes + , unitM + , swapM + , reverseM + , shiftR + , rawM ) where import Data.ByteString (ByteString) +import Data.BEncode import Remote.KRPC unitM :: Method () () @@ -23,3 +30,6 @@ swapM = method "swap" ["x", "y"] ["b", "a"] shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] + +rawM :: Method BEncode BEncode +rawM = method "rawM" [""] [""] \ No newline at end of file -- cgit v1.2.3 From 76b4937c99f131bbe52ef22b03a0bb7317280257 Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 22:34:16 +0400 Subject: ~ Allow passing raw dictionaries. We need this in Kademlia DHT -- there are method which return dictionaries with different keys depending on DHT server state. --- krpc.cabal | 1 + src/Remote/KRPC.hs | 18 +++++++++++++++--- tests/Client.hs | 8 ++++++++ tests/Server.hs | 1 + tests/Shared.hs | 6 +++++- 5 files changed, 30 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index 059f6348..779d7abc 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -57,6 +57,7 @@ test-suite test-client other-modules: Shared build-depends: base == 4.* , bytestring + , containers , process , filepath diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index e1ad0853..1b4ae4b6 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -175,7 +175,9 @@ extractArgs :: BEncodable arg => [ParamName] -> Map ParamName BEncode -> Result arg extractArgs as d = fromBEncode =<< case as of - [] -> Right (BList []) + [] -> if M.null d + then Right (BList []) + else Right (BDict d) [x] -> f x xs -> BList <$> mapM f xs where @@ -184,12 +186,22 @@ extractArgs as d = fromBEncode =<< {-# INLINE extractArgs #-} injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)] -injectVals [] (toBEncode -> BList []) = [] +injectVals [] (toBEncode -> be) + = case be of + BList [] -> [] + BDict d -> M.toList d + _ -> invalidParamList [] be + injectVals [p] (toBEncode -> arg) = [(p, arg)] injectVals ps (toBEncode -> BList as) = L.zip ps as -injectVals _ _ = error "KRPC.injectVals: impossible" +injectVals pl a = invalidParamList pl (toBEncode a) {-# INLINE injectVals #-} +invalidParamList :: [ParamName] -> BEncode -> a +invalidParamList pl be + = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ + "while procedure args are: " ++ show be + -- | Alias to Socket, through might change in future. type Remote = Socket diff --git a/tests/Client.hs b/tests/Client.hs index 1b9ef8d2..313cd56e 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -5,6 +5,7 @@ import Control.Concurrent import Control.Exception import qualified Data.ByteString as B import Data.BEncode +import Data.Map import System.Environment import System.Process import System.FilePath @@ -69,4 +70,11 @@ tests = , testCase "raw method" $ BInteger 10 ==? call addr rawM (BInteger 10) + + , testCase "raw dict" $ + let dict = BDict $ fromList + [ ("some_int", BInteger 100) + , ("some_list", BList [BInteger 10]) + ] + in dict ==? call addr rawDictM dict ] diff --git a/tests/Server.hs b/tests/Server.hs index 7cd6a5d6..aaf6d9f2 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -15,4 +15,5 @@ main = server 6000 , reverseM ==> return . reverse , shiftR ==> \(a, b, c) -> return (c, a, b) , rawM ==> return + , rawDictM ==> return ] diff --git a/tests/Shared.hs b/tests/Shared.hs index a04b6093..f64112da 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -7,6 +7,7 @@ module Shared , reverseM , shiftR , rawM + , rawDictM ) where import Data.ByteString (ByteString) @@ -32,4 +33,7 @@ shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] rawM :: Method BEncode BEncode -rawM = method "rawM" [""] [""] \ No newline at end of file +rawM = method "rawM" [""] [""] + +rawDictM :: Method BEncode BEncode +rawDictM = method "m" [] [] \ No newline at end of file -- cgit v1.2.3 From a2a6f703d679340e5abcdd12e5f88f8afd3204d6 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:38:03 +0400 Subject: Use newer bencodable package --- krpc.cabal | 2 +- src/Remote/KRPC.hs | 22 +++++++++++----------- src/Remote/KRPC/Protocol.hs | 24 +++++++++++------------- tests/Shared.hs | 4 ++-- 4 files changed, 25 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index f382244c..0ac9faac 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -49,7 +49,7 @@ library , bytestring >= 0.10 , containers >= 0.4 - , bencoding == 0.2.2.* + , bencoding == 0.3.* , network >= 2.3 ghc-options: -Wall diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 3659ec66..5c913daa 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -164,7 +164,7 @@ data Method param result = Method { , methodVals :: [ValName] } deriving (Eq, Ord, Generic) -instance BEncodable (Method a b) +instance BEncode (Method a b) instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod @@ -224,16 +224,16 @@ method :: MethodName -> [ParamName] -> [ValName] -> Method param result method = Method {-# INLINE method #-} -lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode +lookupKey :: ParamName -> BDict -> Result BValue lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x -extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode +extractArgs :: [ParamName] -> BDict -> Result BValue extractArgs [] d = Right $ if M.null d then BList [] else BDict d extractArgs [x] d = lookupKey x d extractArgs xs d = BList <$> mapM (`lookupKey` d) xs {-# INLINE extractArgs #-} -injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] +injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] injectVals [] (BList []) = [] injectVals [] (BDict d ) = M.toList d injectVals [] be = invalidParamList [] be @@ -242,7 +242,7 @@ injectVals ps (BList as) = L.zip ps as injectVals ps be = invalidParamList ps be {-# INLINE injectVals #-} -invalidParamList :: [ParamName] -> BEncode -> a +invalidParamList :: [ParamName] -> BValue -> a invalidParamList pl be = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ "while procedure args are: " ++ show be @@ -262,14 +262,14 @@ instance Exception RPCException -- | Address of remote can be called by client. type RemoteAddr = KRemoteAddr -queryCall :: BEncodable param +queryCall :: BEncode param => KRemote -> KRemoteAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) -getResult :: BEncodable result +getResult :: BEncode result => KRemote -> Method param result -> IO result getResult sock m = do @@ -285,7 +285,7 @@ getResult sock m = do -- | Makes remote procedure call. Throws RPCException on any error -- occurred. call :: (MonadBaseControl IO host, MonadIO host) - => (BEncodable param, BEncodable result) + => (BEncode param, BEncode result) => RemoteAddr -- ^ Address of callee. -> Method param result -- ^ Procedure to call. -> param -- ^ Arguments passed by callee to procedure. @@ -294,7 +294,7 @@ 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) + => (BEncode param, BEncode result) => Remote -- ^ Socket to use -> RemoteAddr -- ^ Address of callee. -> Method param result -- ^ Procedure to call. @@ -313,7 +313,7 @@ type MethodHandler remote = (MethodName, HandlerBody remote) -- we can safely erase types in (==>) -- | Assign method implementation to the method signature. (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) + (BEncode param, BEncode result) => Monad remote => Method param result -- ^ Signature. -> (param -> remote result) -- ^ Implementation. @@ -324,7 +324,7 @@ infix 1 ==> -- | Similar to '==>@' but additionally pass caller address. (==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) + (BEncode param, BEncode result) => Monad remote => Method param result -- ^ Signature. -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 06e54f78..d28fdbeb 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -74,8 +74,8 @@ data KError | MethodUnknown { errorMessage :: ByteString } deriving (Show, Read, Eq, Ord) -instance BEncodable KError where - {-# SPECIALIZE instance BEncodable KError #-} +instance BEncode KError where + {-# SPECIALIZE instance BEncode KError #-} {-# INLINE toBEncode #-} toBEncode e = fromAscAssocs -- WARN: keep keys sorted [ "e" --> (errorCode e, errorMessage e) @@ -125,11 +125,11 @@ type ParamName = ByteString -- data KQuery = KQuery { queryMethod :: MethodName - , queryArgs :: Map ParamName BEncode + , queryArgs :: Map ParamName BValue } deriving (Show, Read, Eq, Ord) -instance BEncodable KQuery where - {-# SPECIALIZE instance BEncodable KQuery #-} +instance BEncode KQuery where + {-# SPECIALIZE instance BEncode KQuery #-} {-# INLINE toBEncode #-} toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted [ "a" --> BDict args @@ -145,7 +145,7 @@ instance BEncodable KQuery where fromBEncode _ = decodingError "KQuery" -kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery +kquery :: MethodName -> [(ParamName, BValue)] -> KQuery kquery name args = KQuery name (M.fromList args) {-# INLINE kquery #-} @@ -163,12 +163,10 @@ type ValName = ByteString -- -- > { "y" : "r", "r" : [, , ...] } -- -newtype KResponse = KResponse { - respVals :: Map ValName BEncode - } deriving (Show, Read, Eq, Ord) +newtype KResponse = KResponse { respVals :: BDict } + deriving (Show, Read, Eq, Ord) -instance BEncodable KResponse where - {-# SPECIALIZE instance BEncodable KResponse #-} +instance BEncode KResponse where {-# INLINE toBEncode #-} toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted [ "r" --> vals @@ -183,7 +181,7 @@ instance BEncodable KResponse where fromBEncode _ = decodingError "KDict" -kresponse :: [(ValName, BEncode)] -> KResponse +kresponse :: [(ValName, BValue)] -> KResponse kresponse = KResponse . M.fromList {-# INLINE kresponse #-} @@ -208,7 +206,7 @@ maxMsgSize = 64 * 1024 -- max udp size -- TODO eliminate toStrict -sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () sendMessage msg (host, port) sock = sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) {-# INLINE sendMessage #-} diff --git a/tests/Shared.hs b/tests/Shared.hs index f64112da..1060cfc8 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -32,8 +32,8 @@ swapM = method "swap" ["x", "y"] ["b", "a"] shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] -rawM :: Method BEncode BEncode +rawM :: Method BValue BValue rawM = method "rawM" [""] [""] -rawDictM :: Method BEncode BEncode +rawDictM :: Method BValue BValue rawDictM = method "m" [] [] \ No newline at end of file -- 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 'tests') 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 'tests') 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 913915b3e2b88305c7e4eeeee2c4191465970655 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:52:34 +0400 Subject: Update tests to use newer bencoding --- tests/Client.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/tests/Client.hs b/tests/Client.hs index cda01631..b92f7094 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -4,9 +4,8 @@ module Main (main) where import Control.Concurrent import Control.Exception import qualified Data.ByteString as B -import Data.BEncode -import Data.Map -import System.Environment +import Data.BEncode as BE +import Data.BEncode.BDict as BE import System.Process import System.FilePath @@ -73,7 +72,7 @@ tests = BInteger 10 ==? call addr rawM (BInteger 10) , testCase "raw dict" $ - let dict = BDict $ fromList + let dict = BDict $ BE.fromAscList [ ("some_int", BInteger 100) , ("some_list", BList [BInteger 10]) ] -- cgit v1.2.3 From f349e9427db4a1b35d0af6801f6ad00b8a17991e Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 01:50:38 +0400 Subject: Remove useless type synonyms --- src/Network/KRPC.hs | 41 +++++++++++------------------------------ src/Network/KRPC/Protocol.hs | 20 ++++++++------------ tests/Client.hs | 2 +- 3 files changed, 20 insertions(+), 43 deletions(-) (limited to 'tests') diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index b6e14bb0..8cc3fcab 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -101,8 +101,6 @@ module Network.KRPC , idM -- * Client - , RemoteAddr - , RPCException(..) , call -- * Server @@ -128,6 +126,7 @@ import Data.List as L import Data.Monoid import Data.Typeable import Network +import Network.Socket import GHC.Generics import Network.KRPC.Protocol @@ -253,46 +252,28 @@ invalidParamList pl be = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ "while procedure args are: " ++ show be --- | Alias to Socket, through might change in future. -type Remote = Socket - --- | Represent any error mentioned by protocol specification that --- 'call', 'await' might throw. --- For more details see 'Remote.KRPC.Protocol'. --- -data RPCException = RPCException KError - deriving (Show, Eq, Typeable) - -instance Exception RPCException - --- | Address of remote can be called by client. -type RemoteAddr = KRemoteAddr - -queryCall :: BEncode param - => KRemote -> KRemoteAddr +queryCall :: BEncode param => Socket -> SockAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) -getResult :: BEncode result - => KRemote - -> Method param result -> IO result +getResult :: BEncode result => Socket -> Method param result -> IO result getResult sock m = do resp <- recvResponse sock case resp of - Left e -> throw (RPCException e) + Left e -> throw e Right (respVals -> dict) -> do case fromBEncode =<< extractArgs (methodVals m) dict of Right vals -> return vals - Left e -> throw (RPCException (ProtocolError (BC.pack e))) + Left e -> throw (ProtocolError (BC.pack e)) -- | Makes remote procedure call. Throws RPCException on any error -- occurred. call :: (MonadBaseControl IO host, MonadIO host) => (BEncode param, BEncode result) - => RemoteAddr -- ^ Address of callee. + => SockAddr -- ^ 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. @@ -301,8 +282,8 @@ 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) => (BEncode param, BEncode result) - => Remote -- ^ Socket to use - -> RemoteAddr -- ^ Address of callee. + => Socket -- ^ Socket to use + -> SockAddr -- ^ 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. @@ -311,7 +292,7 @@ call_ sock addr m arg = liftIO $ do getResult sock m -type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) +type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. type MethodHandler remote = (MethodName, HandlerBody remote) @@ -333,7 +314,7 @@ infix 1 ==> (BEncode param, BEncode result) => Monad remote => Method param result -- ^ Signature. - -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. + -> (SockAddr -> param -> remote result) -- ^ Implementation. -> MethodHandler remote -- ^ Handler used by server. {-# INLINE (==>@) #-} m ==>@ body = (methodName m, newbody) @@ -353,7 +334,7 @@ infix 1 ==>@ -- it will not create new thread for each connection. -- server :: (MonadBaseControl IO remote, MonadIO remote) - => KRemoteAddr -- ^ Port used to accept incoming connections. + => SockAddr -- ^ Port used to accept incoming connections. -> [MethodHandler remote] -- ^ Method table. -> remote () server servAddr handlers = do diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 16027362..adc02b5f 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -40,8 +40,6 @@ module Network.KRPC.Protocol , recvResponse -- * Remote - , KRemote - , KRemoteAddr , withRemote , remoteServer ) where @@ -102,6 +100,8 @@ instance BEncode KError where fromBEncode _ = decodingError "KError" +instance Exception KError + type ErrorCode = Int errorCode :: KError -> ErrorCode @@ -194,29 +194,26 @@ kresponse :: BDict -> KResponse kresponse = KResponse {-# INLINE kresponse #-} -type KRemoteAddr = SockAddr -type KRemote = Socket - sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 sockAddrFamily (SockAddrUnix _ ) = AF_UNIX -withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a +withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) (liftIO . sClose) -{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} +{-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} maxMsgSize :: Int --maxMsgSize = 512 -- release: size of payload of one udp packet maxMsgSize = 64 * 1024 -- bench: max UDP MTU {-# INLINE maxMsgSize #-} -sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr {-# INLINE sendMessage #-} -recvResponse :: KRemote -> IO (Either KError KResponse) +recvResponse :: Socket -> IO (Either KError KResponse) recvResponse sock = do (raw, _) <- recvFrom sock maxMsgSize return $ case decode raw of @@ -227,9 +224,8 @@ recvResponse sock = do -- | Run server using a given port. Method invocation should be done manually. remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => KRemoteAddr -- ^ Port number to listen. - -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) - -- ^ Handler. + => SockAddr -- ^ Port number to listen. + -> (SockAddr -> KQuery -> remote (Either KError KResponse)) -> remote () remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where diff --git a/tests/Client.hs b/tests/Client.hs index b92f7094..2b49bd82 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -18,7 +18,7 @@ import Network.Socket import Shared -addr :: RemoteAddr +addr :: SockAddr addr = SockAddrInet 6000 0 withServ :: FilePath -> IO () -> IO () -- cgit v1.2.3 From 857988ceb7c9d73926c07bb1522ce86a1669f4c5 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Mon, 23 Dec 2013 03:28:54 +0400 Subject: Add spec for Message module --- krpc.cabal | 34 +++++++++++++------ src/Network/KRPC/Message.hs | 1 + tests/Network/KRPC/MessageSpec.hs | 71 +++++++++++++++++++++++++++++++++++++++ tests/Spec.hs | 1 + 4 files changed, 97 insertions(+), 10 deletions(-) create mode 100644 tests/Network/KRPC/MessageSpec.hs create mode 100644 tests/Spec.hs (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index 908fd770..fb7b01fe 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -59,25 +59,39 @@ library ghc-options: -Wall - -test-suite test-client +test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests - main-is: Client.hs - other-modules: Shared + main-is: Spec.hs build-depends: base == 4.* , bytestring - , process - , filepath + + , hspec + , QuickCheck + , quickcheck-instances , bencoding , krpc - , network - , HUnit - , test-framework - , test-framework-hunit +--test-suite test-client +-- type: exitcode-stdio-1.0 +-- default-language: Haskell2010 +-- hs-source-dirs: tests +-- main-is: Client.hs +-- other-modules: Shared +-- build-depends: base == 4.* +-- , bytestring +-- , process +-- , filepath +-- +-- , bencoding +-- , krpc +-- , network +-- +-- , HUnit +-- , test-framework +-- , test-framework-hunit --executable test-server diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 0bd34400..1e1dc065 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -227,6 +227,7 @@ data KMessage = Q KQuery | R KResponse | E KError + deriving (Show, Eq) instance BEncode KMessage where toBEncode (Q q) = toBEncode q diff --git a/tests/Network/KRPC/MessageSpec.hs b/tests/Network/KRPC/MessageSpec.hs new file mode 100644 index 00000000..7aca4489 --- /dev/null +++ b/tests/Network/KRPC/MessageSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.KRPC.MessageSpec (spec) where +import Control.Applicative +import Data.ByteString.Lazy as BL +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Data.BEncode as BE +import Network.KRPC.Message + +instance Arbitrary ErrorCode where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary KError where + arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary KQuery where + arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary + +instance Arbitrary KResponse where + arbitrary = KResponse <$> pure (BList []) <*> arbitrary + +instance Arbitrary KMessage where + arbitrary = frequency + [ (1, Q <$> arbitrary) + , (1, R <$> arbitrary) + , (1, E <$> arbitrary) + ] + +spec :: Spec +spec = do + describe "error message" $ do + it "properly bencoded (iso)" $ property $ \ ke -> + BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError) + + it "properly bencoded" $ do + BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee" + `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa") + + BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee" + `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb") + + BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee" + `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc") + + BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee" + `shouldBe` Right + (KError MethodUnknown "Attempt to call unknown method" "dd") + + describe "query message" $ do + it "properly bencoded (iso)" $ property $ \ kq -> + BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery) + + it "properly bencoded" $ do + BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe` + Right (KQuery (BList []) "ping" "aa") + + + describe "response message" $ do + it "properly bencoded (iso)" $ property $ \ kr -> + BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse) + + it "properly bencoded" $ do + BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe` + Right (KResponse (BList []) "aa") + + describe "generic message" $ do + it "properly bencoded (iso)" $ property $ \ km -> + BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) \ No newline at end of file diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 00000000..52ef578f --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} \ No newline at end of file -- cgit v1.2.3 From 46b6ba10202b73ba413d18bd21a284e3897c12b0 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 24 Dec 2013 23:50:23 +0400 Subject: Update tests --- krpc.cabal | 54 +++++++-------------------- src/Network/KRPC.hs | 4 +- src/Network/KRPC/Manager.hs | 12 ++++++ tests/Client.hs | 80 ---------------------------------------- tests/Network/KRPC/MethodSpec.hs | 52 ++++++++++++++++++++++++++ tests/Network/KRPCSpec.hs | 33 +++++++++++++++++ tests/Server.hs | 20 ---------- tests/Shared.hs | 39 -------------------- 8 files changed, 114 insertions(+), 180 deletions(-) delete mode 100644 tests/Client.hs create mode 100644 tests/Network/KRPC/MethodSpec.hs create mode 100644 tests/Network/KRPCSpec.hs delete mode 100644 tests/Server.hs delete mode 100644 tests/Shared.hs (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index fb7b01fe..c4c0ae10 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -64,8 +64,13 @@ test-suite spec default-language: Haskell2010 hs-source-dirs: tests main-is: Spec.hs + other-modules: Network.KRPCSpec + Network.KRPC.MethodSpec + Network.KRPC.MessageSpec build-depends: base == 4.* , bytestring + , network + , mtl , hspec , QuickCheck @@ -74,55 +79,24 @@ test-suite spec , bencoding , krpc ---test-suite test-client --- type: exitcode-stdio-1.0 --- default-language: Haskell2010 --- hs-source-dirs: tests --- main-is: Client.hs --- other-modules: Shared --- build-depends: base == 4.* --- , bytestring --- , process --- , filepath --- --- , bencoding --- , krpc --- , network --- --- , HUnit --- , test-framework --- , test-framework-hunit - - ---executable test-server +--executable bench-server -- default-language: Haskell2010 --- hs-source-dirs: tests +-- hs-source-dirs: bench -- main-is: Server.hs --- other-modules: Shared -- build-depends: base == 4.* -- , bytestring --- , bencoding -- , krpc -- , network +-- ghc-options: -fforce-recomp ---executable bench-server +--benchmark bench-client +-- type: exitcode-stdio-1.0 -- default-language: Haskell2010 -- hs-source-dirs: bench --- main-is: Server.hs --- build-depends: base == 4.* +-- main-is: Main.hs +-- build-depends: base == 4.* -- , bytestring +-- , criterion -- , 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 +-- ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index e10fcb58..10d2eb55 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -94,7 +94,6 @@ module Network.KRPC -- * RPC , Handler , handler - , listen , query -- * Manager @@ -102,9 +101,12 @@ module Network.KRPC , Manager , newManager , closeManager + , withManager + , listen -- * Exceptions , KError (..) + , ErrorCode (..) ) where import Network.KRPC.Message diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 304f43f2..9d8688d3 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -9,6 +9,8 @@ module Network.KRPC.Manager , Manager , newManager , closeManager + , withManager + , query , Handler @@ -102,6 +104,9 @@ closeManager Manager {..} = do -- TODO unblock calls close sock +withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a +withManager addr hs = bracket (newManager addr hs) closeManager + sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () sendMessage sock addr a = do liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr @@ -136,6 +141,11 @@ queryResponse ares = do Right r -> pure r Left e -> throwIO $ decodeError e respId +-- | +-- +-- This function will throw exception if quered node respond with +-- @error@ message or timeout expires. +-- query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b query addr params = do Manager {..} <- getManager @@ -161,6 +171,8 @@ query addr params = do -- Handlers -----------------------------------------------------------------------} +-- | Any thrown exception will be supressed and send over wire back to +-- the quering node. handler :: forall h a b. (KRPC a b, Monad h) => (SockAddr -> a -> h b) -> Handler h handler body = (name, wrapper) diff --git a/tests/Client.hs b/tests/Client.hs deleted file mode 100644 index 2b49bd82..00000000 --- a/tests/Client.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Control.Concurrent -import Control.Exception -import qualified Data.ByteString as B -import Data.BEncode as BE -import Data.BEncode.BDict as BE -import System.Process -import System.FilePath - -import Test.HUnit hiding (Test) -import Test.Framework -import Test.Framework.Providers.HUnit - -import Network.KRPC -import Network.Socket -import Shared - - -addr :: SockAddr -addr = SockAddrInet 6000 0 - -withServ :: FilePath -> IO () -> IO () -withServ serv_path = bracket up terminateProcess . const - where - up = do - (_, _, _, h) <- createProcess (proc serv_path []) - threadDelay 1000000 - return h - -main :: IO () -main = do - let serv_path = "dist" "build" "test-server" "test-server" - withServ serv_path $ - 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 - - , testCase "raw method" $ - BInteger 10 ==? call addr rawM (BInteger 10) - - , testCase "raw dict" $ - let dict = BDict $ BE.fromAscList - [ ("some_int", BInteger 100) - , ("some_list", BList [BInteger 10]) - ] - in dict ==? call addr rawDictM dict - ] diff --git a/tests/Network/KRPC/MethodSpec.hs b/tests/Network/KRPC/MethodSpec.hs new file mode 100644 index 00000000..c1c58282 --- /dev/null +++ b/tests/Network/KRPC/MethodSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.KRPC.MethodSpec where +import Control.Applicative +import Data.BEncode +import Data.ByteString as BS +import Data.Typeable +import Network.KRPC +import Test.Hspec + + +data Ping = Ping + deriving (Show, Eq, Typeable) + +instance BEncode Ping where + toBEncode Ping = toBEncode () + fromBEncode b = Ping <$ (fromBEncode b :: Result ()) + +instance KRPC Ping Ping + +ping :: Monad h => Handler h +ping = handler $ \ _ Ping -> return Ping + +newtype Echo a = Echo a + deriving (Show, Eq, BEncode, Typeable) + +echo :: Monad h => Handler h +echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString)) + +instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a) + +spec :: Spec +spec = do + describe "ping method" $ do + it "name is ping" $ do + (method :: Method Ping Ping) `shouldBe` "ping" + + it "has pretty Show instance" $ do + show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping" + + describe "echo method" $ do + it "is overloadable" $ do + (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int" + (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool" + + it "has pretty Show instance" $ do + show (method :: Method (Echo Int) (Echo Int)) + `shouldBe` "echo int :: Echo Int -> Echo Int" \ No newline at end of file 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") diff --git a/tests/Server.hs b/tests/Server.hs deleted file mode 100644 index b4b34891..00000000 --- a/tests/Server.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE IncoherentInstances #-} -module Main (main) where - -import Data.BEncode -import Network.KRPC -import Network.Socket -import Shared - - -main :: IO () -main = server (SockAddrInet 6000 0) - [ unitM ==> return - , echoM ==> return - , echoBytes ==> return - , swapM ==> \(a, b) -> return (b, a) - , reverseM ==> return . reverse - , shiftR ==> \(a, b, c) -> return (c, a, b) - , rawM ==> return - , rawDictM ==> return - ] diff --git a/tests/Shared.hs b/tests/Shared.hs deleted file mode 100644 index 16547644..00000000 --- a/tests/Shared.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Shared - ( echoM - , echoBytes - , unitM - , swapM - , reverseM - , shiftR - , rawM - , rawDictM - ) where - -import Data.ByteString (ByteString) -import Data.BEncode -import Network.KRPC - -unitM :: Method () () -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"] - -swapM :: Method (Int, Int) (Int, Int) -swapM = method "swap" ["x", "y"] ["b", "a"] - -shiftR :: Method ((), Int, [Int]) ([Int], (), Int) -shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] - -rawM :: Method BValue BValue -rawM = method "rawM" [""] [""] - -rawDictM :: Method BValue BValue -rawDictM = method "m" [] [] \ 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 'tests') 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') 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') 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') 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') 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') 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 From 5d0791e6ed2e500c08e7dadda39a254c8340cef5 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 17 Jan 2017 18:42:09 -0500 Subject: Handle reflected IP addresses (see bep 42). --- krpc.cabal | 14 +++++++-- src/Network/KRPC.hs | 4 ++- src/Network/KRPC/Manager.hs | 61 ++++++++++++++++++++++++--------------- src/Network/KRPC/Message.hs | 45 ++++++++++++++++++++++++++--- src/Network/KRPC/Method.hs | 3 +- tests/Network/KRPC/MessageSpec.hs | 7 +++-- 6 files changed, 99 insertions(+), 35 deletions(-) (limited to 'tests') diff --git a/krpc.cabal b/krpc.cabal index c565bd2a..66c08ccb 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -34,6 +34,11 @@ source-repository this branch: master tag: v0.6.1.0 +flag builder + description: Use older bytestring package and bytestring-builder. + default: False + + library default-language: Haskell2010 default-extensions: PatternGuards @@ -44,7 +49,6 @@ library Network.KRPC.Method Network.KRPC.Manager build-depends: base == 4.* - , bytestring >= 0.10 , text >= 0.11 , data-default-class , lifted-base >= 0.1.1 @@ -54,7 +58,13 @@ library , monad-logger >= 0.3 , bencoding >= 0.4.3 , network >= 2.3 + , cereal , containers + if flag(builder) + build-depends: bytestring >= 0.9, bytestring-builder + else + build-depends: bytestring >= 0.10 + if impl(ghc < 7.6) build-depends: ghc-prim ghc-options: -Wall @@ -89,4 +99,4 @@ benchmark bench , monad-logger , criterion , krpc - ghc-options: -O2 -fforce-recomp \ No newline at end of file + ghc-options: -O2 -fforce-recomp diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index b15927cf..d185fb4c 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -59,6 +59,8 @@ module Network.KRPC -- ** Query , QueryFailure (..) , query + , query' + , queryRaw , getQueryCount -- ** Handler @@ -86,4 +88,4 @@ import Data.Default.Class import Network.KRPC.Message import Network.KRPC.Method import Network.KRPC.Manager -import Network.Socket (SockAddr (..)) \ No newline at end of file +import Network.Socket (SockAddr (..)) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 4436a9ba..9477d23c 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -30,6 +30,8 @@ module Network.KRPC.Manager -- * Queries , QueryFailure (..) , query + , query' + , queryRaw , getQueryCount -- * Handlers @@ -49,6 +51,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control import Data.BEncode as BE +import Data.BEncode.Internal as BE import Data.ByteString as BS import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL @@ -118,7 +121,7 @@ type KResult = Either KError KResponse type TransactionCounter = IORef Int type CallId = (TransactionId, SockAddr) -type CallRes = MVar KResult +type CallRes = MVar (BValue, KResult) type PendingCalls = IORef (Map CallId CallRes) type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue) @@ -163,6 +166,7 @@ sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 sockAddrFamily (SockAddrUnix _ ) = AF_UNIX +sockAddrFamily (SockAddrCan _ ) = AF_CAN -- | Bind socket to the specified address. To enable query handling -- run 'listen'. @@ -261,15 +265,6 @@ unregisterQuery cid ref = do atomicModifyIORef' ref $ swap . M.updateLookupWithKey (const (const Nothing)) cid -queryResponse :: BEncode a => CallRes -> IO a -queryResponse ares = do - res <- readMVar ares - case res of - Left (KError c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m) - Right (KResponse {..}) -> - case fromBEncode respVals of - Right r -> pure r - Left e -> throwIO $ QueryFailed ProtocolError (T.pack e) -- (sendmsg EINVAL) sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO () @@ -284,7 +279,21 @@ sendQuery sock addr q = handle sockError $ sendMessage sock addr q -- respond with @error@ message or the query timeout expires. -- query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b -query addr params = do +query addr params = queryK addr params (\_ x _ -> x) + +-- | Like 'query' but possibly returns your externally routable IP address. +query' :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, Maybe ReflectedIP) +query' addr params = queryK addr params (const (,)) + +-- | Enqueue a query, but give us the complete BEncoded content sent by the +-- remote Node. This is useful for handling extensions that this library does +-- not otherwise support. +queryRaw :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, BValue) +queryRaw addr params = queryK addr params (\raw x _ -> (x,raw)) + +queryK :: forall h m a b x. (MonadKRPC h m, KRPC a b) => + SockAddr -> a -> (BValue -> b -> Maybe ReflectedIP -> x) -> m x +queryK addr params kont = do Manager {..} <- getManager tid <- liftIO $ genTransactionId transactionCounter let queryMethod = method :: Method a b @@ -299,7 +308,13 @@ query addr params = do `onException` unregisterQuery (tid, addr) pendingCalls timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do - queryResponse ares + (raw,res) <- readMVar ares + case res of + Left (KError c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m) + Right (KResponse {..}) -> + case fromBEncode respVals of + Right r -> pure $ kont raw r respIP + Left e -> throwIO $ QueryFailed ProtocolError (T.pack e) case mres of Just res -> do @@ -378,7 +393,7 @@ runHandler h addr KQuery {..} = Lifted.catches wrapper failbacks Right a -> do $(logDebugS) "handler.success" signature - return $ Right $ KResponse a queryId + return $ Right $ KResponse a queryId (Just $ ReflectedIP addr) failbacks = [ E.Handler $ \ (e :: HandlerFailure) -> do @@ -419,20 +434,20 @@ handleQuery q addr = void $ fork $ do res <- dispatchHandler q addr sendMessage sock addr $ either toBEncode toBEncode res -handleResponse :: MonadKRPC h m => KResult -> SockAddr -> m () -handleResponse result addr = do +handleResponse :: MonadKRPC h m => BValue -> KResult -> SockAddr -> m () +handleResponse raw result addr = do Manager {..} <- getManager liftIO $ do let resultId = either errorId respId result mcall <- unregisterQuery (resultId, addr) pendingCalls case mcall of Nothing -> return () - Just ares -> putMVar ares result + Just ares -> putMVar ares (raw,result) -handleMessage :: MonadKRPC h m => KMessage -> SockAddr -> m () -handleMessage (Q q) = handleQuery q -handleMessage (R r) = handleResponse (Right r) -handleMessage (E e) = handleResponse (Left e) +handleMessage :: MonadKRPC h m => BValue -> KMessage -> SockAddr -> m () +handleMessage _ (Q q) = handleQuery q +handleMessage raw (R r) = handleResponse raw (Right r) +handleMessage raw (E e) = handleResponse raw (Left e) listener :: MonadKRPC h m => m () listener = do @@ -441,10 +456,10 @@ listener = do (bs, addr) <- liftIO $ do handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) - case BE.decode bs of + case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of -- TODO ignore unknown messages at all? - Left e -> liftIO $ sendMessage sock addr $ unknownMessage e - Right m -> handleMessage m addr + Left e -> liftIO $ sendMessage sock addr $ unknownMessage e + Right (raw,m) -> handleMessage raw m addr where exceptions :: IOError -> IO (BS.ByteString, SockAddr) exceptions e diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index ebf5573e..6f4ae620 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -35,17 +35,22 @@ module Network.KRPC.Message -- * Response , KResponse(..) + , ReflectedIP(..) -- * Message , KMessage (..) ) where import Control.Applicative +import Control.Arrow import Control.Exception.Lifted as Lifted import Data.BEncode as BE import Data.ByteString as B import Data.ByteString.Char8 as BC +import qualified Data.Serialize as S +import Data.Word import Data.Typeable +import Network.Socket (SockAddr (..),PortNumber,HostAddress) -- | This transaction ID is generated by the querying node and is @@ -188,6 +193,35 @@ instance BEncode KQuery where KQuery <$>! "a" <*>! "q" <*>! "t" {-# INLINE fromBEncode #-} +newtype ReflectedIP = ReflectedIP SockAddr + deriving (Eq, Ord, Show) + +instance BEncode ReflectedIP where + toBEncode (ReflectedIP addr) = BString (encodeAddr addr) + fromBEncode (BString bs) = ReflectedIP <$> decodeAddr bs + fromBEncode _ = Left "ReflectedIP should be a bencoded string" + +port16 :: Word16 -> PortNumber +port16 = fromIntegral + +decodeAddr :: ByteString -> Either String SockAddr +decodeAddr bs | B.length bs == 6 + = ( \(a,p) -> SockAddrInet <$> fmap port16 p <*> a ) + $ (S.runGet S.getWord32host *** S.decode ) + $ B.splitAt 4 bs +decodeAddr bs | B.length bs == 18 + = ( \(a,p) -> flip SockAddrInet6 0 <$> fmap port16 p <*> a <*> pure 0 ) + $ (S.decode *** S.decode ) + $ B.splitAt 16 bs +decodeAddr _ = Left "incorrectly sized address and port" + +encodeAddr :: SockAddr -> ByteString +encodeAddr (SockAddrInet port addr) + = S.runPut (S.putWord32host addr >> S.put (fromIntegral port :: Word16)) +encodeAddr (SockAddrInet6 port _ addr _) + = S.runPut (S.put addr >> S.put (fromIntegral port :: Word16)) +encodeAddr _ = B.empty + {----------------------------------------------------------------------- -- Response messages -----------------------------------------------------------------------} @@ -206,7 +240,8 @@ instance BEncode KQuery where data KResponse = KResponse { respVals :: BValue -- ^ 'BDict' containing return values; , respId :: TransactionId -- ^ match to the corresponding 'queryId'. - } deriving (Show, Read, Eq, Ord, Typeable) + , respIP :: Maybe ReflectedIP + } deriving (Show, Eq, Ord, Typeable) -- | Responses, or KRPC message dictionaries with a \"y\" value of -- \"r\", contain one additional key \"r\". The value of \"r\" is a @@ -218,7 +253,8 @@ data KResponse = KResponse -- instance BEncode KResponse where toBEncode KResponse {..} = toDict $ - "r" .=! respVals + "ip" .=? respIP + .: "r" .=! respVals .: "t" .=! respId .: "y" .=! ("r" :: ByteString) .: endDict @@ -226,7 +262,8 @@ instance BEncode KResponse where fromBEncode = fromDict $ do lookAhead $ match "y" (BString "r") - KResponse <$>! "r" <*>! "t" + addr <- optional (field (req "ip")) + (\r t -> KResponse r t addr) <$>! "r" <*>! "t" {-# INLINE fromBEncode #-} {----------------------------------------------------------------------- @@ -249,4 +286,4 @@ instance BEncode KMessage where Q <$> fromBEncode b <|> R <$> fromBEncode b <|> E <$> fromBEncode b - <|> decodingError "KMessage: unknown message or message tag" \ No newline at end of file + <|> decodingError "KMessage: unknown message or message tag" diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index ea9da958..916b38a8 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -47,8 +47,7 @@ newtype Method param result = Method { methodName :: MethodName } instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod -showsMethod :: forall a. forall b. Typeable a => Typeable b - => Method a b -> ShowS +showsMethod :: forall a b. ( Typeable a , Typeable b ) => Method a b -> ShowS showsMethod (Method name) = showString (BC.unpack name) <> showString " :: " <> diff --git a/tests/Network/KRPC/MessageSpec.hs b/tests/Network/KRPC/MessageSpec.hs index 7aca4489..498ef679 100644 --- a/tests/Network/KRPC/MessageSpec.hs +++ b/tests/Network/KRPC/MessageSpec.hs @@ -20,7 +20,8 @@ instance Arbitrary KQuery where arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary instance Arbitrary KResponse where - arbitrary = KResponse <$> pure (BList []) <*> arbitrary + -- TODO: Abitrary instance for ReflectedIP + arbitrary = KResponse <$> pure (BList []) <*> arbitrary <*> pure Nothing instance Arbitrary KMessage where arbitrary = frequency @@ -64,8 +65,8 @@ spec = do it "properly bencoded" $ do BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe` - Right (KResponse (BList []) "aa") + Right (KResponse (BList []) "aa" Nothing) describe "generic message" $ do it "properly bencoded (iso)" $ property $ \ km -> - BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) \ No newline at end of file + BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) -- cgit v1.2.3