summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--krpc.cabal54
-rw-r--r--src/Network/KRPC.hs4
-rw-r--r--src/Network/KRPC/Manager.hs12
-rw-r--r--tests/Client.hs80
-rw-r--r--tests/Network/KRPC/MethodSpec.hs52
-rw-r--r--tests/Network/KRPCSpec.hs33
-rw-r--r--tests/Server.hs20
-rw-r--r--tests/Shared.hs39
8 files changed, 114 insertions, 180 deletions
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
64 default-language: Haskell2010 64 default-language: Haskell2010
65 hs-source-dirs: tests 65 hs-source-dirs: tests
66 main-is: Spec.hs 66 main-is: Spec.hs
67 other-modules: Network.KRPCSpec
68 Network.KRPC.MethodSpec
69 Network.KRPC.MessageSpec
67 build-depends: base == 4.* 70 build-depends: base == 4.*
68 , bytestring 71 , bytestring
72 , network
73 , mtl
69 74
70 , hspec 75 , hspec
71 , QuickCheck 76 , QuickCheck
@@ -74,55 +79,24 @@ test-suite spec
74 , bencoding 79 , bencoding
75 , krpc 80 , krpc
76 81
77--test-suite test-client 82--executable bench-server
78-- type: exitcode-stdio-1.0
79-- default-language: Haskell2010
80-- hs-source-dirs: tests
81-- main-is: Client.hs
82-- other-modules: Shared
83-- build-depends: base == 4.*
84-- , bytestring
85-- , process
86-- , filepath
87--
88-- , bencoding
89-- , krpc
90-- , network
91--
92-- , HUnit
93-- , test-framework
94-- , test-framework-hunit
95
96
97--executable test-server
98-- default-language: Haskell2010 83-- default-language: Haskell2010
99-- hs-source-dirs: tests 84-- hs-source-dirs: bench
100-- main-is: Server.hs 85-- main-is: Server.hs
101-- other-modules: Shared
102-- build-depends: base == 4.* 86-- build-depends: base == 4.*
103-- , bytestring 87-- , bytestring
104-- , bencoding
105-- , krpc 88-- , krpc
106-- , network 89-- , network
90-- ghc-options: -fforce-recomp
107 91
108--executable bench-server 92--benchmark bench-client
93-- type: exitcode-stdio-1.0
109-- default-language: Haskell2010 94-- default-language: Haskell2010
110-- hs-source-dirs: bench 95-- hs-source-dirs: bench
111-- main-is: Server.hs 96-- main-is: Main.hs
112-- build-depends: base == 4.* 97-- build-depends: base == 4.*
113-- , bytestring 98-- , bytestring
99-- , criterion
114-- , krpc 100-- , krpc
115-- , network 101-- , network
116-- ghc-options: -fforce-recomp 102-- ghc-options: -O2 -fforce-recomp \ No newline at end of file
117
118benchmark bench-client
119 type: exitcode-stdio-1.0
120 default-language: Haskell2010
121 hs-source-dirs: bench
122 main-is: Main.hs
123 build-depends: base == 4.*
124 , bytestring
125 , criterion
126 , krpc
127 , network
128 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
94 -- * RPC 94 -- * RPC
95 , Handler 95 , Handler
96 , handler 96 , handler
97 , listen
98 , query 97 , query
99 98
100 -- * Manager 99 -- * Manager
@@ -102,9 +101,12 @@ module Network.KRPC
102 , Manager 101 , Manager
103 , newManager 102 , newManager
104 , closeManager 103 , closeManager
104 , withManager
105 , listen
105 106
106 -- * Exceptions 107 -- * Exceptions
107 , KError (..) 108 , KError (..)
109 , ErrorCode (..)
108 ) where 110 ) where
109 111
110import Network.KRPC.Message 112import 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
9 , Manager 9 , Manager
10 , newManager 10 , newManager
11 , closeManager 11 , closeManager
12 , withManager
13
12 , query 14 , query
13 15
14 , Handler 16 , Handler
@@ -102,6 +104,9 @@ closeManager Manager {..} = do
102 -- TODO unblock calls 104 -- TODO unblock calls
103 close sock 105 close sock
104 106
107withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a
108withManager addr hs = bracket (newManager addr hs) closeManager
109
105sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () 110sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m ()
106sendMessage sock addr a = do 111sendMessage sock addr a = do
107 liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr 112 liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr
@@ -136,6 +141,11 @@ queryResponse ares = do
136 Right r -> pure r 141 Right r -> pure r
137 Left e -> throwIO $ decodeError e respId 142 Left e -> throwIO $ decodeError e respId
138 143
144-- |
145--
146-- This function will throw exception if quered node respond with
147-- @error@ message or timeout expires.
148--
139query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b 149query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b
140query addr params = do 150query addr params = do
141 Manager {..} <- getManager 151 Manager {..} <- getManager
@@ -161,6 +171,8 @@ query addr params = do
161-- Handlers 171-- Handlers
162-----------------------------------------------------------------------} 172-----------------------------------------------------------------------}
163 173
174-- | Any thrown exception will be supressed and send over wire back to
175-- the quering node.
164handler :: forall h a b. (KRPC a b, Monad h) 176handler :: forall h a b. (KRPC a b, Monad h)
165 => (SockAddr -> a -> h b) -> Handler h 177 => (SockAddr -> a -> h b) -> Handler h
166handler body = (name, wrapper) 178handler 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 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Main (main) where
3
4import Control.Concurrent
5import Control.Exception
6import qualified Data.ByteString as B
7import Data.BEncode as BE
8import Data.BEncode.BDict as BE
9import System.Process
10import System.FilePath
11
12import Test.HUnit hiding (Test)
13import Test.Framework
14import Test.Framework.Providers.HUnit
15
16import Network.KRPC
17import Network.Socket
18import Shared
19
20
21addr :: SockAddr
22addr = SockAddrInet 6000 0
23
24withServ :: FilePath -> IO () -> IO ()
25withServ serv_path = bracket up terminateProcess . const
26 where
27 up = do
28 (_, _, _, h) <- createProcess (proc serv_path [])
29 threadDelay 1000000
30 return h
31
32main :: IO ()
33main = do
34 let serv_path = "dist" </> "build" </> "test-server" </> "test-server"
35 withServ serv_path $
36 defaultMain tests
37
38
39(==?) :: (Eq a, Show a) => a -> IO a -> Assertion
40expected ==? action = do
41 actual <- action
42 expected @=? actual
43
44tests :: [Test]
45tests =
46 [ testCase "unit" $
47 () ==? call addr unitM ()
48
49 , testCase "echo int" $
50 1234 ==? call addr echoM 1234
51
52 , testCase "reverse 1..100" $
53 reverse [1..100] ==? call addr reverseM [1..100]
54
55 , testCase "reverse empty list" $
56 reverse [] ==? call addr reverseM []
57
58 , testCase "reverse singleton list" $
59 reverse [1] ==? call addr reverseM [1]
60
61 , testCase "swap pair" $
62 (1, 0) ==? call addr swapM (0, 1)
63
64 , testCase "shift triple" $
65 ([2..10], (), 1) ==? call addr shiftR ((), 1, [2..10])
66
67 , testCase "echo bytestring" $
68 let bs = B.replicate 400 0 in
69 bs ==? call addr echoBytes bs
70
71 , testCase "raw method" $
72 BInteger 10 ==? call addr rawM (BInteger 10)
73
74 , testCase "raw dict" $
75 let dict = BDict $ BE.fromAscList
76 [ ("some_int", BInteger 100)
77 , ("some_list", BList [BInteger 10])
78 ]
79 in dict ==? call addr rawDictM dict
80 ]
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 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE DeriveDataTypeable #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
7module Network.KRPC.MethodSpec where
8import Control.Applicative
9import Data.BEncode
10import Data.ByteString as BS
11import Data.Typeable
12import Network.KRPC
13import Test.Hspec
14
15
16data Ping = Ping
17 deriving (Show, Eq, Typeable)
18
19instance BEncode Ping where
20 toBEncode Ping = toBEncode ()
21 fromBEncode b = Ping <$ (fromBEncode b :: Result ())
22
23instance KRPC Ping Ping
24
25ping :: Monad h => Handler h
26ping = handler $ \ _ Ping -> return Ping
27
28newtype Echo a = Echo a
29 deriving (Show, Eq, BEncode, Typeable)
30
31echo :: Monad h => Handler h
32echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString))
33
34instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a)
35
36spec :: Spec
37spec = do
38 describe "ping method" $ do
39 it "name is ping" $ do
40 (method :: Method Ping Ping) `shouldBe` "ping"
41
42 it "has pretty Show instance" $ do
43 show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping"
44
45 describe "echo method" $ do
46 it "is overloadable" $ do
47 (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int"
48 (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool"
49
50 it "has pretty Show instance" $ do
51 show (method :: Method (Echo Int) (Echo Int))
52 `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 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Network.KRPCSpec (spec) where
3import Control.Monad.Reader
4import Network.Socket (SockAddr (..))
5import Network.KRPC
6import Network.KRPC.MethodSpec hiding (spec)
7import Test.Hspec
8
9servAddr :: SockAddr
10servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127)
11
12handlers :: [Handler IO]
13handlers =
14 [ handler $ \ _ Ping -> return Ping
15 , handler $ \ _ (Echo a) -> return (Echo (a :: Bool))
16 , handler $ \ _ (Echo a) -> return (Echo (a :: Int))
17 ]
18
19spec :: Spec
20spec = do
21 describe "query" $ do
22 it "run handlers" $ do
23 let int = 0xabcd :: Int
24 (withManager servAddr handlers $ runReaderT $ do
25 listen
26 query servAddr (Echo int))
27 `shouldReturn` Echo int
28
29 it "throw timeout exception" $ do
30 (withManager servAddr handlers $ runReaderT $ do
31 query servAddr (Echo (0xabcd :: Int))
32 )
33 `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 @@
1{-# LANGUAGE IncoherentInstances #-}
2module Main (main) where
3
4import Data.BEncode
5import Network.KRPC
6import Network.Socket
7import Shared
8
9
10main :: IO ()
11main = server (SockAddrInet 6000 0)
12 [ unitM ==> return
13 , echoM ==> return
14 , echoBytes ==> return
15 , swapM ==> \(a, b) -> return (b, a)
16 , reverseM ==> return . reverse
17 , shiftR ==> \(a, b, c) -> return (c, a, b)
18 , rawM ==> return
19 , rawDictM ==> return
20 ]
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 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Shared
3 ( echoM
4 , echoBytes
5 , unitM
6 , swapM
7 , reverseM
8 , shiftR
9 , rawM
10 , rawDictM
11 ) where
12
13import Data.ByteString (ByteString)
14import Data.BEncode
15import Network.KRPC
16
17unitM :: Method () ()
18unitM = method "unit" [] []
19
20echoM :: Method Int Int
21echoM = method "echo" ["x"] ["x"]
22
23echoBytes :: Method ByteString ByteString
24echoBytes = method "echoBytes" ["x"] ["x"]
25
26reverseM :: Method [Int] [Int]
27reverseM = method "reverse" ["xs"] ["ys"]
28
29swapM :: Method (Int, Int) (Int, Int)
30swapM = method "swap" ["x", "y"] ["b", "a"]
31
32shiftR :: Method ((), Int, [Int]) ([Int], (), Int)
33shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"]
34
35rawM :: Method BValue BValue
36rawM = method "rawM" [""] [""]
37
38rawDictM :: Method BValue BValue
39rawDictM = method "m" [] [] \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:37:00 +0000