diff --git a/Network/MessagePackRpc/Client.hs b/Network/MessagePackRpc/Client.hs deleted file mode 100644 --- a/Network/MessagePackRpc/Client.hs +++ /dev/null @@ -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 --- Stability : experimental --- Portability: portable --- --- This module is client library of MessagePack-RPC. --- The specification of MessagePack-RPC is at --- . --- --- 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 [] diff --git a/Network/MessagePackRpc/Server.hs b/Network/MessagePackRpc/Server.hs deleted file mode 100644 --- a/Network/MessagePackRpc/Server.hs +++ /dev/null @@ -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 --- . --- --- 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 diff --git a/msgpack-rpc.cabal b/msgpack-rpc.cabal --- a/msgpack-rpc.cabal +++ b/msgpack-rpc.cabal @@ -1,46 +1,53 @@ -name: msgpack-rpc -version: 0.9.0 -synopsis: A MessagePack-RPC Implementation -description: A MessagePack-RPC Implementation -homepage: http://msgpack.org/ -license: BSD3 -license-file: LICENSE -author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka -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 +homepage: http://msgpack.org/ +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Hideyuki Tanaka +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 diff --git a/src/Network/MessagePack/Client.hs b/src/Network/MessagePack/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/MessagePack/Client.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------- +-- | +-- Module : Network.MessagePackRpc.Client +-- Copyright : (c) Hideyuki Tanaka, 2010-2015 +-- License : BSD3 +-- +-- Maintainer: Hideyuki Tanaka +-- Stability : experimental +-- Portability: portable +-- +-- This module is client library of MessagePack-RPC. +-- The specification of MessagePack-RPC is at +-- . +-- +-- 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 [] diff --git a/src/Network/MessagePack/Server.hs b/src/Network/MessagePack/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/MessagePack/Server.hs @@ -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 +-- . +-- +-- 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 diff --git a/test.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -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" diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -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"