diff options
-rw-r--r-- | README.md | 4 | ||||
-rw-r--r-- | bench/Main.hs | 3 | ||||
-rw-r--r-- | bench/Server.hs | 3 | ||||
-rw-r--r-- | krpc.cabal | 4 | ||||
-rw-r--r-- | src/Network/KRPC.hs | 9 | ||||
-rw-r--r-- | src/Network/KRPC/Protocol.hs | 25 | ||||
-rw-r--r-- | tests/Client.hs | 3 | ||||
-rw-r--r-- | tests/Server.hs | 3 |
8 files changed, 29 insertions, 25 deletions
@@ -13,6 +13,10 @@ language, thus it's hard to shoot yourself in the foot accidently. | |||
13 | See bittorrent DHT [specification][spec] for detailed protocol | 13 | See bittorrent DHT [specification][spec] for detailed protocol |
14 | description. | 14 | description. |
15 | 15 | ||
16 | ### Example | ||
17 | |||
18 | TODO | ||
19 | |||
16 | #### Modules | 20 | #### Modules |
17 | 21 | ||
18 | * Remote.KRPC — simple interface which reduce all RPC related stuff to | 22 | * 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) | |||
6 | import qualified Data.ByteString as B | 6 | import qualified Data.ByteString as B |
7 | import Criterion.Main | 7 | import Criterion.Main |
8 | import Network.KRPC | 8 | import Network.KRPC |
9 | import Network.Socket | ||
9 | 10 | ||
10 | 11 | ||
11 | addr :: RemoteAddr | 12 | addr :: RemoteAddr |
12 | addr = (0, 6000) | 13 | addr = SockAddrInet 6000 0 |
13 | 14 | ||
14 | echo :: Method ByteString ByteString | 15 | echo :: Method ByteString ByteString |
15 | echo = method "echo" ["x"] ["x"] | 16 | 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 | |||
3 | 3 | ||
4 | import Data.ByteString (ByteString) | 4 | import Data.ByteString (ByteString) |
5 | import Network.KRPC | 5 | import Network.KRPC |
6 | import Network.Socket | ||
6 | 7 | ||
7 | 8 | ||
8 | echo :: Method ByteString ByteString | 9 | echo :: Method ByteString ByteString |
9 | echo = method "echo" ["x"] ["x"] | 10 | echo = method "echo" ["x"] ["x"] |
10 | 11 | ||
11 | main :: IO () | 12 | main :: IO () |
12 | main = server 6000 [ echo ==> return ] | 13 | main = server (SockAddrInet 6000 0) [ echo ==> return ] |
@@ -69,6 +69,7 @@ test-suite test-client | |||
69 | 69 | ||
70 | , bencoding | 70 | , bencoding |
71 | , krpc | 71 | , krpc |
72 | , network | ||
72 | 73 | ||
73 | , HUnit | 74 | , HUnit |
74 | , test-framework | 75 | , test-framework |
@@ -84,6 +85,7 @@ executable test-server | |||
84 | , bytestring | 85 | , bytestring |
85 | , bencoding | 86 | , bencoding |
86 | , krpc | 87 | , krpc |
88 | , network | ||
87 | 89 | ||
88 | executable bench-server | 90 | executable bench-server |
89 | default-language: Haskell2010 | 91 | default-language: Haskell2010 |
@@ -92,6 +94,7 @@ executable bench-server | |||
92 | build-depends: base == 4.* | 94 | build-depends: base == 4.* |
93 | , bytestring | 95 | , bytestring |
94 | , krpc | 96 | , krpc |
97 | , network | ||
95 | ghc-options: -fforce-recomp | 98 | ghc-options: -fforce-recomp |
96 | 99 | ||
97 | benchmark bench-client | 100 | benchmark bench-client |
@@ -103,4 +106,5 @@ benchmark bench-client | |||
103 | , bytestring | 106 | , bytestring |
104 | , criterion | 107 | , criterion |
105 | , krpc | 108 | , krpc |
109 | , network | ||
106 | ghc-options: -O2 -fforce-recomp \ No newline at end of file | 110 | 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 @@ | |||
97 | module Network.KRPC | 97 | module Network.KRPC |
98 | ( -- * Method | 98 | ( -- * Method |
99 | Method(..) | 99 | Method(..) |
100 | , method, idM | 100 | , method |
101 | , idM | ||
101 | 102 | ||
102 | -- * Client | 103 | -- * Client |
103 | , RemoteAddr | 104 | , RemoteAddr |
@@ -349,11 +350,11 @@ infix 1 ==>@ | |||
349 | -- it will not create new thread for each connection. | 350 | -- it will not create new thread for each connection. |
350 | -- | 351 | -- |
351 | server :: (MonadBaseControl IO remote, MonadIO remote) | 352 | server :: (MonadBaseControl IO remote, MonadIO remote) |
352 | => PortNumber -- ^ Port used to accept incoming connections. | 353 | => KRemoteAddr -- ^ Port used to accept incoming connections. |
353 | -> [MethodHandler remote] -- ^ Method table. | 354 | -> [MethodHandler remote] -- ^ Method table. |
354 | -> remote () | 355 | -> remote () |
355 | server servport handlers = do | 356 | server servAddr handlers = do |
356 | remoteServer servport $ \addr q -> do | 357 | remoteServer servAddr $ \addr q -> do |
357 | case dispatch (queryMethod q) of | 358 | case dispatch (queryMethod q) of |
358 | Nothing -> return $ Left $ MethodUnknown (queryMethod q) | 359 | Nothing -> return $ Left $ MethodUnknown (queryMethod q) |
359 | Just m -> m addr q | 360 | 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 | |||
202 | kresponse = KResponse . M.fromList | 202 | kresponse = KResponse . M.fromList |
203 | {-# INLINE kresponse #-} | 203 | {-# INLINE kresponse #-} |
204 | 204 | ||
205 | 205 | type KRemoteAddr = SockAddr | |
206 | |||
207 | type KRemoteAddr = (HostAddress, PortNumber) | ||
208 | |||
209 | type KRemote = Socket | 206 | type KRemote = Socket |
210 | 207 | ||
211 | withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a | 208 | withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a |
@@ -224,8 +221,7 @@ maxMsgSize = 64 * 1024 -- max udp size | |||
224 | 221 | ||
225 | -- TODO eliminate toStrict | 222 | -- TODO eliminate toStrict |
226 | sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () | 223 | sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () |
227 | sendMessage msg (host, port) sock = | 224 | sendMessage msg addr sock = sendAllTo sock (LB.toStrict (encoded msg)) addr |
228 | sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) | ||
229 | {-# INLINE sendMessage #-} | 225 | {-# INLINE sendMessage #-} |
230 | 226 | ||
231 | recvResponse :: KRemote -> IO (Either KError KResponse) | 227 | recvResponse :: KRemote -> IO (Either KError KResponse) |
@@ -239,26 +235,21 @@ recvResponse sock = do | |||
239 | 235 | ||
240 | -- | Run server using a given port. Method invocation should be done manually. | 236 | -- | Run server using a given port. Method invocation should be done manually. |
241 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) | 237 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) |
242 | => PortNumber -- ^ Port number to listen. | 238 | => KRemoteAddr -- ^ Port number to listen. |
243 | -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) | 239 | -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) |
244 | -- ^ Handler. | 240 | -- ^ Handler. |
245 | -> remote () | 241 | -> remote () |
246 | remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop | 242 | remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop |
247 | where | 243 | where |
248 | bindServ = do | 244 | bindServ = do |
249 | sock <- socket AF_INET Datagram defaultProtocol | 245 | sock <- socket AF_INET Datagram defaultProtocol |
250 | bindSocket sock (SockAddrInet servport iNADDR_ANY) | 246 | bindSocket sock servAddr |
251 | return sock | 247 | return sock |
252 | 248 | ||
253 | loop sock = forever $ do | 249 | loop sock = forever $ do |
254 | (bs, addr) <- liftIO $ recvFrom sock maxMsgSize | 250 | (bs, addr) <- liftIO $ recvFrom sock maxMsgSize |
255 | case addr of | 251 | reply <- handleMsg bs addr |
256 | SockAddrInet port host -> do | 252 | liftIO $ sendMessage reply addr sock |
257 | let kaddr = (host, port) | ||
258 | reply <- handleMsg bs kaddr | ||
259 | liftIO $ sendMessage reply kaddr sock | ||
260 | _ -> return () | ||
261 | |||
262 | where | 253 | where |
263 | handleMsg bs addr = case decoded bs of | 254 | handleMsg bs addr = case decoded bs of |
264 | Right query -> (either toBEncode toBEncode <$> action addr query) | 255 | 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 | |||
15 | import Test.Framework.Providers.HUnit | 15 | import Test.Framework.Providers.HUnit |
16 | 16 | ||
17 | import Network.KRPC | 17 | import Network.KRPC |
18 | import Network.Socket | ||
18 | import Shared | 19 | import Shared |
19 | 20 | ||
20 | 21 | ||
21 | addr :: RemoteAddr | 22 | addr :: RemoteAddr |
22 | addr = (0, 6000) | 23 | addr = SockAddrInet 6000 0 |
23 | 24 | ||
24 | withServ :: FilePath -> IO () -> IO () | 25 | withServ :: FilePath -> IO () -> IO () |
25 | withServ serv_path = bracket up terminateProcess . const | 26 | 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 | |||
3 | 3 | ||
4 | import Data.BEncode | 4 | import Data.BEncode |
5 | import Network.KRPC | 5 | import Network.KRPC |
6 | import Network.Socket | ||
6 | import Shared | 7 | import Shared |
7 | 8 | ||
8 | 9 | ||
9 | main :: IO () | 10 | main :: IO () |
10 | main = server 6000 | 11 | main = server (SockAddrInet 6000 0) |
11 | [ unitM ==> return | 12 | [ unitM ==> return |
12 | , echoM ==> return | 13 | , echoM ==> return |
13 | , echoBytes ==> return | 14 | , echoBytes ==> return |