diff options
-rw-r--r-- | src/Network/KRPC.hs | 41 | ||||
-rw-r--r-- | src/Network/KRPC/Protocol.hs | 20 | ||||
-rw-r--r-- | tests/Client.hs | 2 |
3 files changed, 20 insertions, 43 deletions
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 | |||
101 | , idM | 101 | , idM |
102 | 102 | ||
103 | -- * Client | 103 | -- * Client |
104 | , RemoteAddr | ||
105 | , RPCException(..) | ||
106 | , call | 104 | , call |
107 | 105 | ||
108 | -- * Server | 106 | -- * Server |
@@ -128,6 +126,7 @@ import Data.List as L | |||
128 | import Data.Monoid | 126 | import Data.Monoid |
129 | import Data.Typeable | 127 | import Data.Typeable |
130 | import Network | 128 | import Network |
129 | import Network.Socket | ||
131 | import GHC.Generics | 130 | import GHC.Generics |
132 | 131 | ||
133 | import Network.KRPC.Protocol | 132 | import Network.KRPC.Protocol |
@@ -253,46 +252,28 @@ invalidParamList pl be | |||
253 | = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ | 252 | = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ |
254 | "while procedure args are: " ++ show be | 253 | "while procedure args are: " ++ show be |
255 | 254 | ||
256 | -- | Alias to Socket, through might change in future. | 255 | queryCall :: BEncode param => Socket -> SockAddr |
257 | type Remote = Socket | ||
258 | |||
259 | -- | Represent any error mentioned by protocol specification that | ||
260 | -- 'call', 'await' might throw. | ||
261 | -- For more details see 'Remote.KRPC.Protocol'. | ||
262 | -- | ||
263 | data RPCException = RPCException KError | ||
264 | deriving (Show, Eq, Typeable) | ||
265 | |||
266 | instance Exception RPCException | ||
267 | |||
268 | -- | Address of remote can be called by client. | ||
269 | type RemoteAddr = KRemoteAddr | ||
270 | |||
271 | queryCall :: BEncode param | ||
272 | => KRemote -> KRemoteAddr | ||
273 | -> Method param result -> param -> IO () | 256 | -> Method param result -> param -> IO () |
274 | queryCall sock addr m arg = sendMessage q addr sock | 257 | queryCall sock addr m arg = sendMessage q addr sock |
275 | where | 258 | where |
276 | q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) | 259 | q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) |
277 | 260 | ||
278 | getResult :: BEncode result | 261 | getResult :: BEncode result => Socket -> Method param result -> IO result |
279 | => KRemote | ||
280 | -> Method param result -> IO result | ||
281 | getResult sock m = do | 262 | getResult sock m = do |
282 | resp <- recvResponse sock | 263 | resp <- recvResponse sock |
283 | case resp of | 264 | case resp of |
284 | Left e -> throw (RPCException e) | 265 | Left e -> throw e |
285 | Right (respVals -> dict) -> do | 266 | Right (respVals -> dict) -> do |
286 | case fromBEncode =<< extractArgs (methodVals m) dict of | 267 | case fromBEncode =<< extractArgs (methodVals m) dict of |
287 | Right vals -> return vals | 268 | Right vals -> return vals |
288 | Left e -> throw (RPCException (ProtocolError (BC.pack e))) | 269 | Left e -> throw (ProtocolError (BC.pack e)) |
289 | 270 | ||
290 | 271 | ||
291 | -- | Makes remote procedure call. Throws RPCException on any error | 272 | -- | Makes remote procedure call. Throws RPCException on any error |
292 | -- occurred. | 273 | -- occurred. |
293 | call :: (MonadBaseControl IO host, MonadIO host) | 274 | call :: (MonadBaseControl IO host, MonadIO host) |
294 | => (BEncode param, BEncode result) | 275 | => (BEncode param, BEncode result) |
295 | => RemoteAddr -- ^ Address of callee. | 276 | => SockAddr -- ^ Address of callee. |
296 | -> Method param result -- ^ Procedure to call. | 277 | -> Method param result -- ^ Procedure to call. |
297 | -> param -- ^ Arguments passed by callee to procedure. | 278 | -> param -- ^ Arguments passed by callee to procedure. |
298 | -> host result -- ^ Values returned by callee from the procedure. | 279 | -> 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 | |||
301 | -- | The same as 'call' but use already opened socket. | 282 | -- | The same as 'call' but use already opened socket. |
302 | call_ :: (MonadBaseControl IO host, MonadIO host) | 283 | call_ :: (MonadBaseControl IO host, MonadIO host) |
303 | => (BEncode param, BEncode result) | 284 | => (BEncode param, BEncode result) |
304 | => Remote -- ^ Socket to use | 285 | => Socket -- ^ Socket to use |
305 | -> RemoteAddr -- ^ Address of callee. | 286 | -> SockAddr -- ^ Address of callee. |
306 | -> Method param result -- ^ Procedure to call. | 287 | -> Method param result -- ^ Procedure to call. |
307 | -> param -- ^ Arguments passed by callee to procedure. | 288 | -> param -- ^ Arguments passed by callee to procedure. |
308 | -> host result -- ^ Values returned by callee from the procedure. | 289 | -> host result -- ^ Values returned by callee from the procedure. |
@@ -311,7 +292,7 @@ call_ sock addr m arg = liftIO $ do | |||
311 | getResult sock m | 292 | getResult sock m |
312 | 293 | ||
313 | 294 | ||
314 | type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) | 295 | type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) |
315 | 296 | ||
316 | -- | Procedure signature and implementation binded up. | 297 | -- | Procedure signature and implementation binded up. |
317 | type MethodHandler remote = (MethodName, HandlerBody remote) | 298 | type MethodHandler remote = (MethodName, HandlerBody remote) |
@@ -333,7 +314,7 @@ infix 1 ==> | |||
333 | (BEncode param, BEncode result) | 314 | (BEncode param, BEncode result) |
334 | => Monad remote | 315 | => Monad remote |
335 | => Method param result -- ^ Signature. | 316 | => Method param result -- ^ Signature. |
336 | -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. | 317 | -> (SockAddr -> param -> remote result) -- ^ Implementation. |
337 | -> MethodHandler remote -- ^ Handler used by server. | 318 | -> MethodHandler remote -- ^ Handler used by server. |
338 | {-# INLINE (==>@) #-} | 319 | {-# INLINE (==>@) #-} |
339 | m ==>@ body = (methodName m, newbody) | 320 | m ==>@ body = (methodName m, newbody) |
@@ -353,7 +334,7 @@ infix 1 ==>@ | |||
353 | -- it will not create new thread for each connection. | 334 | -- it will not create new thread for each connection. |
354 | -- | 335 | -- |
355 | server :: (MonadBaseControl IO remote, MonadIO remote) | 336 | server :: (MonadBaseControl IO remote, MonadIO remote) |
356 | => KRemoteAddr -- ^ Port used to accept incoming connections. | 337 | => SockAddr -- ^ Port used to accept incoming connections. |
357 | -> [MethodHandler remote] -- ^ Method table. | 338 | -> [MethodHandler remote] -- ^ Method table. |
358 | -> remote () | 339 | -> remote () |
359 | server servAddr handlers = do | 340 | 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 | |||
40 | , recvResponse | 40 | , recvResponse |
41 | 41 | ||
42 | -- * Remote | 42 | -- * Remote |
43 | , KRemote | ||
44 | , KRemoteAddr | ||
45 | , withRemote | 43 | , withRemote |
46 | , remoteServer | 44 | , remoteServer |
47 | ) where | 45 | ) where |
@@ -102,6 +100,8 @@ instance BEncode KError where | |||
102 | 100 | ||
103 | fromBEncode _ = decodingError "KError" | 101 | fromBEncode _ = decodingError "KError" |
104 | 102 | ||
103 | instance Exception KError | ||
104 | |||
105 | type ErrorCode = Int | 105 | type ErrorCode = Int |
106 | 106 | ||
107 | errorCode :: KError -> ErrorCode | 107 | errorCode :: KError -> ErrorCode |
@@ -194,29 +194,26 @@ kresponse :: BDict -> KResponse | |||
194 | kresponse = KResponse | 194 | kresponse = KResponse |
195 | {-# INLINE kresponse #-} | 195 | {-# INLINE kresponse #-} |
196 | 196 | ||
197 | type KRemoteAddr = SockAddr | ||
198 | type KRemote = Socket | ||
199 | |||
200 | sockAddrFamily :: SockAddr -> Family | 197 | sockAddrFamily :: SockAddr -> Family |
201 | sockAddrFamily (SockAddrInet _ _ ) = AF_INET | 198 | sockAddrFamily (SockAddrInet _ _ ) = AF_INET |
202 | sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 | 199 | sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 |
203 | sockAddrFamily (SockAddrUnix _ ) = AF_UNIX | 200 | sockAddrFamily (SockAddrUnix _ ) = AF_UNIX |
204 | 201 | ||
205 | withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a | 202 | withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a |
206 | withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) | 203 | withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) |
207 | (liftIO . sClose) | 204 | (liftIO . sClose) |
208 | {-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} | 205 | {-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} |
209 | 206 | ||
210 | maxMsgSize :: Int | 207 | maxMsgSize :: Int |
211 | --maxMsgSize = 512 -- release: size of payload of one udp packet | 208 | --maxMsgSize = 512 -- release: size of payload of one udp packet |
212 | maxMsgSize = 64 * 1024 -- bench: max UDP MTU | 209 | maxMsgSize = 64 * 1024 -- bench: max UDP MTU |
213 | {-# INLINE maxMsgSize #-} | 210 | {-# INLINE maxMsgSize #-} |
214 | 211 | ||
215 | sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () | 212 | sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () |
216 | sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr | 213 | sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr |
217 | {-# INLINE sendMessage #-} | 214 | {-# INLINE sendMessage #-} |
218 | 215 | ||
219 | recvResponse :: KRemote -> IO (Either KError KResponse) | 216 | recvResponse :: Socket -> IO (Either KError KResponse) |
220 | recvResponse sock = do | 217 | recvResponse sock = do |
221 | (raw, _) <- recvFrom sock maxMsgSize | 218 | (raw, _) <- recvFrom sock maxMsgSize |
222 | return $ case decode raw of | 219 | return $ case decode raw of |
@@ -227,9 +224,8 @@ recvResponse sock = do | |||
227 | 224 | ||
228 | -- | Run server using a given port. Method invocation should be done manually. | 225 | -- | Run server using a given port. Method invocation should be done manually. |
229 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) | 226 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) |
230 | => KRemoteAddr -- ^ Port number to listen. | 227 | => SockAddr -- ^ Port number to listen. |
231 | -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) | 228 | -> (SockAddr -> KQuery -> remote (Either KError KResponse)) |
232 | -- ^ Handler. | ||
233 | -> remote () | 229 | -> remote () |
234 | remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop | 230 | remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop |
235 | where | 231 | 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 | |||
18 | import Shared | 18 | import Shared |
19 | 19 | ||
20 | 20 | ||
21 | addr :: RemoteAddr | 21 | addr :: SockAddr |
22 | addr = SockAddrInet 6000 0 | 22 | addr = SockAddrInet 6000 0 |
23 | 23 | ||
24 | withServ :: FilePath -> IO () -> IO () | 24 | withServ :: FilePath -> IO () -> IO () |