msgpack-rpc 0.9.0 → 1.0.0
raw patch · 7 files changed
+356/−338 lines, 7 filesdep +binarydep +binary-conduitdep +conduit-extradep −attoparsec-conduitdep −hspecdep −network-conduitdep ~basedep ~bytestringdep ~conduit
Dependencies added: binary, binary-conduit, conduit-extra, exceptions, tasty, tasty-hunit
Dependencies removed: attoparsec-conduit, hspec, network-conduit
Dependency ranges changed: base, bytestring, conduit, monad-control, msgpack, mtl, network, random, text
Files
- Network/MessagePackRpc/Client.hs +0/−128
- Network/MessagePackRpc/Server.hs +0/−118
- msgpack-rpc.cabal +53/−46
- src/Network/MessagePack/Client.hs +126/−0
- src/Network/MessagePack/Server.hs +132/−0
- test.hs +0/−46
- test/test.hs +45/−0
− Network/MessagePackRpc/Client.hs
@@ -1,128 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}-{-# LANGUAGE GADTs, FlexibleContexts #-}------------------------------------------------------------------------ |--- Module : Network.MessagePackRpc.Client--- Copyright : (c) Hideyuki Tanaka, 2010-2012--- License : BSD3------ Maintainer: Hideyuki Tanaka <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 :: Int -> Int -> Client Int--- > add = call "add"--- >--- > main = runClient "localhost" 5000 $ do--- > ret <- add 123 456--- > liftIO $ print ret--------------------------------------------------------------------------module Network.MessagePackRpc.Client (- -- * MessagePack Client type- ClientT, Client,- runClient,-- -- * Call RPC method- call,-- -- * RPC error- RpcError(..),- ) where--import Control.Exception-import Control.Monad-import Control.Monad.Trans.Control-import Control.Monad.State.Strict as CMS-import qualified Data.ByteString as S-import Data.Conduit-import qualified Data.Conduit.Attoparsec as CA-import qualified Data.Conduit.Binary as CB-import Data.Conduit.Network-import Data.MessagePack as M-import Data.Typeable--type Client = ClientT IO--newtype ClientT m a- = ClientT { unClientT :: StateT (Connection m) m a }- deriving (Monad, MonadIO, MonadThrow)---- It can't derive by newtype deriving...-instance MonadTrans ClientT where- lift = ClientT . lift---- | RPC connection type-data Connection m where- Connection ::- !(ResumableSource m S.ByteString)- -> !(Sink S.ByteString m ())- -> !Int- -> Connection m--runClient :: (MonadIO m, MonadBaseControl IO m)- => S.ByteString -> Int -> ClientT m a -> m ()-runClient host port m = do- runTCPClient (clientSettings port host) $ \ad -> do- (rsrc, _) <- appSource ad $$+ return ()- void $ evalStateT (unClientT m) (Connection rsrc (appSink ad) 0)---- | RPC error type-data RpcError- = ServerError Object -- ^ Server error- | ResultTypeError String -- ^ Result type mismatch- | ProtocolError String -- ^ Protocol error- deriving (Show, Eq, Ord, Typeable)--instance Exception RpcError--class RpcType r where- rpcc :: String -> [Object] -> r--instance (MonadIO m, MonadThrow m, OBJECT o) => RpcType (ClientT m o) where- rpcc m args = do- res <- rpcCall m (reverse args)- case tryFromObject res of- Left err -> monadThrow $ ResultTypeError err- Right r -> return r--instance (OBJECT o, RpcType r) => RpcType (o -> r) where- rpcc m args arg = rpcc m (toObject arg:args)--rpcCall :: (MonadIO m, MonadThrow m) => String -> [Object] -> ClientT m Object-rpcCall methodName args = ClientT $ do- Connection rsrc sink msgid <- CMS.get- (rsrc', (rtype, rmsgid, rerror, rresult)) <- lift $ do- CB.sourceLbs (pack (0 :: Int, msgid, methodName, args)) $$ sink- rsrc $$++ CA.sinkParser M.get- CMS.put $ Connection rsrc' sink (msgid + 1)-- when (rtype /= (1 :: Int)) $- monadThrow $ ProtocolError $- "invalid response type (expect 1, but got " ++ show rtype ++ ")"- when (rmsgid /= msgid) $- monadThrow $ ProtocolError $- "message id mismatch: expect "- ++ show msgid ++ ", but got "- ++ show rmsgid- case tryFromObject rerror of- Left _ ->- monadThrow $ ServerError rerror- Right () ->- return rresult---- | Call an RPC Method-call :: RpcType a- => String -- ^ Method name- -> a-call m = rpcc m []
− Network/MessagePackRpc/Server.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} - -------------------------------------------------------------------- --- | --- Module : Network.MessagePackRpc.Server --- Copyright : (c) Hideyuki Tanaka, 2010-2012 --- 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 -> Method Int --- > add x y = return $ x + y --- > --- > main = serve 1234 [("add", toMethod add)] --- --------------------------------------------------------------------- - -module Network.MessagePackRpc.Server ( - -- * RPC method types - RpcMethod, MethodType(..), - MethodT(..), Method, - -- * Start RPC server - serve, - ) where - -import Control.Applicative -import Control.Exception as E -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.Control -import Data.Conduit -import Data.Conduit.Network -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.Attoparsec as CA -import Data.Data -import Data.MessagePack - -type RpcMethod m = [Object] -> m Object - -type Request = (Int, Int, String, [Object]) -type Response = (Int, Int, Object, Object) - -data ServerError = ServerError String - deriving (Show, Typeable) - -instance Exception ServerError - -type Method = MethodT IO - -newtype MethodT m a = MethodT { unMethodT :: m a } - deriving (Functor, Applicative, Monad, MonadIO) - -instance MonadTrans MethodT where - lift = MethodT - -class MethodType f m | f -> m where - -- | Create a RPC method from a Hakell function - toMethod :: f -> RpcMethod m - -instance (MonadThrow m, MonadBaseControl IO m, OBJECT o) - => MethodType (MethodT m o) m where - toMethod m ls = case ls of - [] -> toObject <$> unMethodT m - _ -> monadThrow $ ServerError "argument error" - -instance (OBJECT o, MethodType r m) => MethodType (o -> r) m where - toMethod f = \(x:xs) -> toMethod (f $! fromObject' x) xs - -fromObject' :: OBJECT o => Object -> o -fromObject' o = - case tryFromObject o of - Left err -> error $ "argument type error: " ++ err - Right r -> r - --- | Start RPC server with a set of RPC methods. -serve :: forall m . (MonadIO m, MonadThrow m, MonadBaseControl IO m) - => Int -- ^ Port number - -> [(String, RpcMethod m)] -- ^ list of (method name, RPC method) - -> m () -serve port methods = runTCPServer (serverSettings port "*") $ \ad -> do - (rsrc, _) <- appSource ad $$+ return () - processRequests rsrc (appSink ad) - where - processRequests rsrc sink = do - (rsrc', res) <- rsrc $$++ do - req <- CA.sinkParser get - lift $ getResponse req - _ <- CB.sourceLbs (pack res) $$ sink - processRequests rsrc' sink - - getResponse :: Request -> m Response - getResponse (rtype, msgid, methodName, args) = do - when (rtype /= 0) $ - monadThrow $ ServerError $ "request type is not 0, got " ++ show rtype - ret <- callMethod methodName args - return (1, msgid, toObject (), ret) - - callMethod :: String -> [Object] -> m Object - callMethod methodName args = - case lookup methodName methods of - Nothing -> - monadThrow $ ServerError $ "method '" ++ methodName ++ "' not found" - Just method -> - method args
msgpack-rpc.cabal view
@@ -1,46 +1,53 @@-name: msgpack-rpc -version: 0.9.0 -synopsis: A MessagePack-RPC Implementation -description: A MessagePack-RPC Implementation <http://msgpack.org/> -homepage: http://msgpack.org/ -license: BSD3 -license-file: LICENSE -author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> -copyright: (c) 2010-2012, Hideyuki Tanaka -category: Network -stability: Experimental -cabal-version: >=1.8 -build-type: Simple - -source-repository head - type: git - location: git://github.com/msgpack/msgpack-haskell.git - -library - build-depends: base >= 4.5 && < 4.7 - , bytestring >= 0.9 - , text == 0.11.* - , network >= 2.2 && < 2.5 - , random == 1.0.* - , mtl >= 2.1 - , monad-control >= 0.3 - , conduit >= 0.5 - , network-conduit >= 0.6 - , attoparsec-conduit >= 0.5 - , msgpack == 0.7.* - - exposed-modules: Network.MessagePackRpc.Server - Network.MessagePackRpc.Client - -test-suite msgpack-rpc-test - type: exitcode-stdio-1.0 - hs-source-dirs: dist - main-is: ../test.hs - - build-depends: base - , mtl - , network - , async >= 2.0 - , hspec >= 1.3 - , msgpack-rpc +name: msgpack-rpc+version: 1.0.0+synopsis: A MessagePack-RPC Implementation+description: A MessagePack-RPC Implementation <http://msgpack.org/>+homepage: http://msgpack.org/+license: BSD3+license-file: LICENSE+author: Hideyuki Tanaka+maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>+copyright: (c) 2010-2015, Hideyuki Tanaka+category: Network+stability: Experimental+cabal-version: >=1.10+build-type: Simple++source-repository head+ type: git+ location: git://github.com/msgpack/msgpack-haskell.git++library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules: Network.MessagePack.Server+ Network.MessagePack.Client++ build-depends: base >=4.5 && <5+ , bytestring >=0.10+ , text >=1.2+ , network >=2.6+ , random >=1.1+ , mtl >=2.2+ , monad-control >=1.0+ , conduit >=1.2+ , conduit-extra >=1.1+ , binary-conduit >=1.2+ , exceptions >=0.8+ , binary >=0.7+ , msgpack >=1.0++test-suite msgpack-rpc-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test.hs++ build-depends: base+ , mtl+ , network+ , async >=2.0+ , tasty >=0.10+ , tasty-hunit >=0.9+ , msgpack-rpc
+ src/Network/MessagePack/Client.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------+-- |+-- Module : Network.MessagePackRpc.Client+-- Copyright : (c) Hideyuki Tanaka, 2010-2015+-- License : BSD3+--+-- Maintainer: Hideyuki Tanaka <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 :: Int -> Int -> Client Int+-- > add = call "add"+-- >+-- > main = runClient "localhost" 5000 $ do+-- > ret <- add 123 456+-- > liftIO $ print ret+--+--------------------------------------------------------------------++module Network.MessagePack.Client (+ -- * MessagePack Client type+ Client, execClient,++ -- * Call RPC method+ call,++ -- * RPC error+ RpcError(..),+ ) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Control.Monad.Catch+import Control.Monad.State.Strict as CMS+import Data.Binary as Binary+import qualified Data.ByteString as S+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Network+import Data.Conduit.Serialization.Binary+import Data.MessagePack+import Data.Typeable+import System.IO++newtype Client a+ = ClientT { runClient :: StateT Connection IO a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow)++-- | RPC connection type+data Connection+ = Connection+ !(ResumableSource IO S.ByteString)+ !(Sink S.ByteString IO ())+ !Int++execClient :: S.ByteString -> Int -> Client a -> IO ()+execClient host port m =+ runTCPClient (clientSettings port host) $ \ad -> do+ (rsrc, _) <- appSource ad $$+ return ()+ void $ evalStateT (runClient m) (Connection rsrc (appSink ad) 0)++-- | RPC error type+data RpcError+ = ServerError Object -- ^ Server error+ | ResultTypeError String -- ^ Result type mismatch+ | ProtocolError String -- ^ Protocol error+ deriving (Show, Eq, Ord, Typeable)++instance Exception RpcError++class RpcType r where+ rpcc :: String -> [Object] -> r++instance MessagePack o => RpcType (Client o) where+ rpcc m args = do+ res <- rpcCall m (reverse args)+ case fromObject res of+ Just r -> return r+ Nothing -> throwM $ ResultTypeError "type mismatch"++instance (MessagePack o, RpcType r) => RpcType (o -> r) where+ rpcc m args arg = rpcc m (toObject arg:args)++rpcCall :: String -> [Object] -> Client Object+rpcCall methodName args = ClientT $ do+ Connection rsrc sink msgid <- CMS.get+ (rsrc', res) <- lift $ do+ CB.sourceLbs (pack (0 :: Int, msgid, methodName, args)) $$ sink+ rsrc $$++ sinkGet Binary.get+ CMS.put $ Connection rsrc' sink (msgid + 1)++ case fromObject res of+ Nothing -> throwM $ ProtocolError "invalid response data"+ Just (rtype, rmsgid, rerror, rresult) -> do++ when (rtype /= (1 :: Int)) $+ throwM $ ProtocolError $+ "invalid response type (expect 1, but got " ++ show rtype ++ ")"++ when (rmsgid /= msgid) $+ throwM $ ProtocolError $+ "message id mismatch: expect "+ ++ show msgid ++ ", but got "+ ++ show rmsgid++ case fromObject rerror of+ Nothing -> throwM $ ServerError rerror+ Just () -> return rresult++-- | Call an RPC Method+call :: RpcType a+ => String -- ^ Method name+ -> a+call m = rpcc m []
+ src/Network/MessagePack/Server.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-------------------------------------------------------------------+-- |+-- Module : Network.MessagePackRpc.Server+-- Copyright : (c) Hideyuki Tanaka, 2010-2015+-- 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 -> Server Int+-- > add x y = return $ x + y+-- >+-- > main = serve 1234 [ method "add" add ]+--+--------------------------------------------------------------------++module Network.MessagePack.Server (+ -- * RPC method types+ Method, MethodType(..),+ ServerT(..), Server,+ -- * Build a method+ method,+ -- * Start RPC server+ serve,+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Binary+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Network+import Data.Conduit.Serialization.Binary+import Data.List+import Data.MessagePack+import Data.Typeable++-- ^ MessagePack RPC method+data Method m+ = Method+ { methodName :: String+ , methodBody :: [Object] -> m Object+ }++type Request = (Int, Int, String, [Object])+type Response = (Int, Int, Object, Object)++data ServerError = ServerError String+ deriving (Show, Typeable)++instance Exception ServerError++newtype ServerT m a = ServerT { runServerT :: m a }+ deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans ServerT where+ lift = ServerT++type Server = ServerT IO++class Monad m => MethodType m f where+ -- | Create a RPC method from a Hakell function+ toBody :: f -> [Object] -> m Object++instance (MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where+ toBody m ls = case ls of+ [] -> toObject <$> runServerT m+ _ -> throwM $ ServerError "argument number error"++instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where+ toBody f (x: xs) =+ case fromObject x of+ Nothing -> throwM $ ServerError "argument type error"+ Just r -> toBody (f r) xs++-- | Build a method+method :: MethodType m f+ => String -- ^ Method name+ -> f -- ^ Method body+ -> Method m+method name body = Method name $ toBody body++-- | Start RPC server with a set of RPC methods.+serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m)+ => Int -- ^ Port number+ -> [Method m] -- ^ list of methods+ -> m ()+serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do+ (rsrc, _) <- appSource ad $$+ return ()+ (_ :: Either ParseError ()) <- try $ processRequests rsrc (appSink ad)+ return ()+ where+ processRequests rsrc sink = do+ (rsrc', res) <- rsrc $$++ do+ obj <- sinkGet get+ case fromObject obj of+ Nothing -> throwM $ ServerError "invalid request"+ Just req -> lift $ getResponse (req :: Request)+ _ <- CB.sourceLbs (pack res) $$ sink+ processRequests rsrc' sink++ getResponse (rtype, msgid, methodName, args) = do+ when (rtype /= 0) $+ throwM $ ServerError $ "request type is not 0, got " ++ show rtype+ ret <- callMethod methodName args+ return ((1, msgid, toObject (), ret) :: Response)++ callMethod name args =+ case find ((== name) . methodName) methods of+ Nothing ->+ throwM $ ServerError $ "method '" ++ name ++ "' not found"+ Just m ->+ methodBody m args
− test.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Control.Concurrent-import Control.Concurrent.Async-import Control.Monad.Trans--import Test.Hspec--import Network (withSocketsDo)-import Network.MessagePackRpc.Server-import Network.MessagePackRpc.Client--port :: Int-port = 5000--main :: IO ()-main = withSocketsDo $ hspec $ do- describe "add service" $ do- it "correct" $ do- server `race_` (threadDelay 1000 >> client)--server :: IO ()-server =- serve port- [ ("add", toMethod add)- , ("echo", toMethod echo)- ]- where- add :: Int -> Int -> Method Int- add x y = return $ x + y-- echo :: String -> Method String- echo s = return $ "***" ++ s ++ "***"--client :: IO ()-client = runClient "localhost" port $ do- r1 <- add 123 456- liftIO $ r1 `shouldBe` 123 + 456- r2 <- echo "hello"- liftIO $ r2 `shouldBe` "***hello***"- where- add :: Int -> Int -> Client Int- add = call "add"-- echo :: String -> Client String- echo = call "echo"
+ test/test.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad.Trans+import Test.Tasty+import Test.Tasty.HUnit++import Network (withSocketsDo)+import Network.MessagePack.Client+import Network.MessagePack.Server++port :: Int+port = 5000++main :: IO ()+main = withSocketsDo $ defaultMain $+ testGroup "simple service"+ [ testCase "test" $ server `race_` (threadDelay 1000 >> client) ]++server :: IO ()+server =+ serve port+ [ method "add" add+ , method "echo" echo+ ]+ where+ add :: Int -> Int -> Server Int+ add x y = return $ x + y++ echo :: String -> Server String+ echo s = return $ "***" ++ s ++ "***"++client :: IO ()+client = execClient "localhost" port $ do+ r1 <- add 123 456+ liftIO $ r1 @?= 123 + 456+ r2 <- echo "hello"+ liftIO $ r2 @?= "***hello***"+ where+ add :: Int -> Int -> Client Int+ add = call "add"++ echo :: String -> Client String+ echo = call "echo"