msgpack-rpc 0.1 → 0.3.1
raw patch · 3 files changed
+172/−63 lines, 3 filesdep +deepseqdep +iterateedep +transformersdep −mtldep ~basedep ~msgpackdep ~network
Dependencies added: deepseq, iteratee, transformers
Dependencies removed: mtl
Dependency ranges changed: base, msgpack, network, random
Files
- msgpack-rpc.cabal +19/−16
- src/Network/MessagePackRpc/Client.hs +82/−20
- src/Network/MessagePackRpc/Server.hs +71/−27
msgpack-rpc.cabal view
@@ -1,30 +1,33 @@ Name: msgpack-rpc-Version: 0.1+Version: 0.3.1 Synopsis: A MessagePack-RPC Implementation- Description:- A MessagePack-RPC Implementation <http://msgpack.sourceforge.net/>+ A MessagePack-RPC Implementation <http://msgpack.org/> License: BSD3 License-file: LICENSE--Author: Hideyuki Tanaka-Maintainer: tanaka.hideyuki@gmail.com- Copyright: Copyright (c) 2010, Hideyuki Tanaka- Category: Network--Build-type: Simple-+Author: Hideyuki Tanaka+Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>+Homepage: http://github.com/msgpack/msgpack-rpc+Stability: Experimental+Tested-with: GHC == 6.12.3 Cabal-version: >=1.2+Build-type: Simple Library+ Build-depends: base >= 4 && <5,+ msgpack >= 0.3.1 && < 0.4,+ network >= 2.2.1.7 && < 2.2.2,+ random >= 1.0.0.2 && < 1.1,+ transformers >= 0.2.1 && < 0.2.2,+ iteratee >= 0.4.0.2 && < 0.4.1,+ deepseq >= 1.1 && < 1.2++ Ghc-options: -O2 -Wall+ Hs-source-dirs: src+ Exposed-modules: Network.MessagePackRpc.Server Network.MessagePackRpc.Client-- Hs-source-dirs: src- - Build-depends: base>=4 && <5, network, random, mtl, msgpack- Ghc-options: -O2 -Wall
src/Network/MessagePackRpc/Client.hs view
@@ -1,38 +1,97 @@+{-# Language DeriveDataTypeable #-}++-------------------------------------------------------------------+-- |+-- Module : Network.MessagePackRpc.Client+-- Copyright : (c) Hideyuki Tanaka, 2010+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- This module is client library of MessagePack-RPC.+-- The specification of MessagePack-RPC is at <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>.+--+-- A simple example:+--+-- >import Network.MessagePackRpc.Client+-- >+-- >add :: RpcMethod (Int -> Int -> IO Int)+-- >add = method "add"+-- >+-- >main = do+-- > conn <- connect "127.0.0.1" 1234+-- > print =<< add conn 123 456+--+--------------------------------------------------------------------+ module Network.MessagePackRpc.Client (+ -- * RPC connection Connection, connect, + -- * RPC error+ RpcError(..),+ + -- * Call RPC method RpcMethod, call, method, ) where +import Control.Exception import Control.Monad import Data.Functor import Data.MessagePack+import Data.Typeable import Network import System.IO import System.Random +-- | RPC connection type data Connection = Connection { connHandle :: Handle } -connect :: String -> Int -> IO Connection+-- | Connect to RPC server+connect :: String -- ^ Host name+ -> Int -- ^ Port number+ -> IO Connection -- ^ Connection connect addr port = withSocketsDo $ do h <- connectTo addr (PortNumber $ fromIntegral port) return $ Connection { connHandle = h }- ++-- | RPC error type+data RpcError+ = ServerError Object -- ^ An error occurred at server+ | ResultTypeError String -- ^ Result type mismatch+ | ProtocolError String -- ^ A protocol error occurred+ deriving (Eq, Ord, Typeable)++instance Exception RpcError++instance Show RpcError where+ show (ServerError err) =+ "server error: " ++ show err+ show (ResultTypeError err) =+ "result type error: " ++ err+ show (ProtocolError err) =+ "protocol error: " ++ err+ class RpcType r where rpcc :: Connection -> String -> [Object] -> r fromObject' :: OBJECT o => Object -> o-fromObject' o = let Right r = fromObject o in r+fromObject' o =+ case fromObject o of+ Left err -> throw $ ResultTypeError err+ Right r -> r instance OBJECT o => RpcType (IO o) where- rpcc c m args = fromObject' <$> rpcCall c m (reverse args)+ rpcc c m args = return . fromObject' =<< rpcCall c m (reverse args) instance (OBJECT o, RpcType r) => RpcType (o -> r) where rpcc c m args arg = rpcc c m (toObject arg:args)@@ -40,27 +99,30 @@ rpcCall :: Connection -> String -> [Object] -> IO Object rpcCall Connection{ connHandle = h } m args = do msgid <- (`mod`2^(32::Int)) <$> randomIO :: IO Int- packToHandle h $ do- put [ toObject (0 :: Int)- , toObject msgid- , toObject m- , toObject args- ]- unpackFromHandle h $ do- [ rtype, rmsgid, rerror, rresult ] <- get- Right 1 <- return (fromObject rtype :: Result Int)- Right rmsgid <- return $ fromObject rmsgid- when (rmsgid /= msgid) $ fail $ "msgid mismatch: " ++ show msgid ++ " <-> " ++ show rmsgid- Right () <- return $ fromObject rerror- Right rresult <- return $ fromObject rresult- return rresult+ packToHandle' h $ put (0 ::Int, msgid, m, args)+ unpackFromHandleI h $ do+ (rtype, rmsgid, rerror, rresult) <- getI+ when (rtype /= (1 :: Int)) $+ throw $ ProtocolError $ "response type is not 1 (got " ++ show rtype ++ ")"+ when (rmsgid /= msgid) $+ throw $ ProtocolError $ "message id mismatch: expect " ++ show msgid ++ ", but got " ++ show rmsgid+ case fromObject rerror of+ Left _ ->+ throw $ ServerError rerror+ Right () ->+ return rresult -- -call :: RpcType a => Connection -> String -> a+-- | Call an RPC Method+call :: RpcType a =>+ Connection -- ^ Connection+ -> String -- ^ Method name+ -> a call c m = rpcc c m [] -method :: RpcType a => String -> Connection -> a+-- | Create an RPC Method (call c m == method m c)+method :: RpcType a => String -> RpcMethod a method c m = call m c type RpcMethod a = Connection -> a
src/Network/MessagePackRpc/Server.hs view
@@ -1,13 +1,45 @@+-------------------------------------------------------------------+-- |+-- Module : Network.MessagePackRpc.Server+-- Copyright : (c) Hideyuki Tanaka, 2010+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- This module is server library of MessagePack-RPC.+-- The specification of MessagePack-RPC is at <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>.+--+-- A simple example:+--+-- >import Network.MessagePackRpc.Server+-- >+-- >add :: Int -> Int -> IO Int+-- >add x y = return $ x + y+-- >+-- >main =+-- > serve 1234 [("add", fun add)]+--+--------------------------------------------------------------------+ module Network.MessagePackRpc.Server (+ -- * RPC method types RpcMethod,+ RpcMethodType(..),+ -- * Create RPC method fun,+ -- * Start RPC server serve, ) where import Control.Applicative import Control.Concurrent-import Control.Exception+import Control.DeepSeq+import Control.Exception as E import Control.Monad+import Control.Monad.IO.Class+import Data.Iteratee.Exception as I import Data.Maybe import Data.MessagePack import Network@@ -24,47 +56,59 @@ toRpcMethod m = \[] -> toObject <$> m instance (OBJECT o, RpcMethodType r) => RpcMethodType (o -> r) where- toRpcMethod f = \(x:xs) -> toRpcMethod (f (fromObject' x)) xs+ toRpcMethod f = \(x:xs) -> toRpcMethod (f $! fromObject' x) xs fromObject' :: OBJECT o => Object -> o-fromObject' o = let Right r = fromObject o in r+fromObject' o =+ case fromObject o of+ Left err -> error $ "argument type error: " ++ err+ Right r -> r -- +-- | Create a RPC method from a Haskell function. fun :: RpcMethodType f => f -> RpcMethod fun = toRpcMethod -serve :: Int -> [(String, RpcMethod)] -> IO ()+-- | Start RPC server with a set of RPC methods.+serve :: Int -- ^ Port number+ -> [(String, RpcMethod)] -- ^ list of (method name, RPC method)+ -> IO () serve port methods = withSocketsDo $ do sock <- listenOn (PortNumber $ fromIntegral port) forever $ do- (h, host, port) <- accept sock+ (h, host, hostport) <- accept sock forkIO $- processRequests h `finally` hClose h- `catch` \(SomeException e) -> print e- + (processRequests h `finally` hClose h) `catches`+ [ Handler $ \e -> let _ = (e :: I.EofException) in return ()+ , Handler $ \e -> hPutStrLn stderr $ host ++ ":" ++ show hostport ++ ": "++ show (e :: SomeException)]+ where processRequests h =- forever $ processRequest h+ unpackFromHandleI h $ forever $ processRequest h processRequest h = do- (msgid, method, args) <- unpackFromHandle h $ do- [ rtype, rmsgid, rmethod, rargs ] <- get- 0 <- return (fromObject' rtype :: Int)- msgid <- return (fromObject' rmsgid :: Int)- method <- return (fromObject' rmethod :: String)- args <- return (fromObject' rargs :: [Object])- return (msgid, method, args)- - ret <- callMethod method args+ (rtype, msgid, method, args) <- getI+ liftIO $ do+ resp <- try $ getResponse rtype method args+ case resp of+ Left err ->+ packToHandle' h $+ put (1 :: Int, msgid :: Int, show (err :: SomeException), ())+ Right ret ->+ packToHandle' h $+ put (1 :: Int, msgid :: Int, (), ret)++ getResponse rtype method args = do+ when (rtype /= (0 :: Int)) $+ fail "request type is not 0" - packToHandle h $ do- put [ toObject (1 :: Int)- , toObject msgid- , toObject ()- , ret- ]+ r <- callMethod (method :: String) (args :: [Object])+ r `deepseq` return r - callMethod methodName args = do- let method = fromJust $ lookup methodName methods- method args+ callMethod methodName args =+ case lookup methodName methods of+ Nothing ->+ fail $ "method '" ++ methodName ++ "' not found"+ Just method ->+ method args