network-msgpack-rpc 0.0.1 → 0.0.2
raw patch · 11 files changed
+548/−249 lines, 11 filesdep +data-default-classdep +taggeddep ~data-msgpacksetup-changed
Dependencies added: data-default-class, tagged
Dependency ranges changed: data-msgpack
Files
- Setup.hs +0/−2
- Setup.lhs +3/−0
- network-msgpack-rpc.cabal +22/−3
- src/Network/MessagePack/Capabilities.hs +27/−0
- src/Network/MessagePack/Client.hs +26/−113
- src/Network/MessagePack/Client/Basic.hs +90/−0
- src/Network/MessagePack/Client/Internal.hs +67/−0
- src/Network/MessagePack/Protocol.hs +49/−0
- src/Network/MessagePack/Server.hs +17/−131
- src/Network/MessagePack/Server/Basic.hs +202/−0
- src/Network/MessagePack/Types.hs +45/−0
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
network-msgpack-rpc.cabal view
@@ -1,7 +1,6 @@ name: network-msgpack-rpc-version: 0.0.1+version: 0.0.2 synopsis: A MessagePack-RPC Implementation-description: A MessagePack-RPC Implementation <http://msgpack.org/> homepage: http://msgpack.org/ license: BSD3 license-file: LICENSE@@ -12,6 +11,12 @@ stability: Experimental cabal-version: >= 1.10 build-type: Simple+description:+ A MessagePack-RPC Implementation <http://msgpack.org/>+ .+ This is a fork of msgpack-haskell <https://github.com/msgpack/msgpack-haskell>,+ since the original author is unreachable. This fork incorporates a number of+ bugfixes and is actively being developed. source-repository head type: git@@ -19,11 +24,20 @@ library default-language: Haskell2010+ ghc-options:+ -Wall hs-source-dirs: src exposed-modules: Network.MessagePack.Client Network.MessagePack.Server+ other-modules:+ Network.MessagePack.Capabilities+ Network.MessagePack.Client.Basic+ Network.MessagePack.Client.Internal+ Network.MessagePack.Protocol+ Network.MessagePack.Server.Basic+ Network.MessagePack.Types build-depends: base < 5 , binary@@ -31,20 +45,25 @@ , bytestring , conduit , conduit-extra- , data-msgpack+ , data-default-class+ , data-msgpack >= 0.0.4 , exceptions , monad-control , mtl , network+ , tagged test-suite testsuite type: exitcode-stdio-1.0 default-language: Haskell2010+ ghc-options:+ -Wall hs-source-dirs: test main-is: testsuite.hs build-depends: base < 5 , async+ , bytestring , hspec , mtl , network
+ src/Network/MessagePack/Capabilities.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.MessagePack.Capabilities where++import Data.MessagePack (MessagePack)+import GHC.Generics (Generic)+++data ServerCapability+ = SCapMethodList+ -- ^ Server supports method lists and can handle more efficient method codes+ -- instead of strings for names. It supports the "internal.methodList" call+ -- to return an ordered list of method names. The client can send an index+ -- in this list instead of the name itself when performing an RPC call.+ deriving (Eq, Read, Show, Generic)++instance MessagePack ServerCapability+++data ClientCapability+ = CCapMethodList+ -- ^ Client supports method lists and can send more efficient method codes+ -- instead of strings for names.+ deriving (Eq, Read, Show, Generic)++instance MessagePack ClientCapability++
src/Network/MessagePack/Client.hs view
@@ -1,130 +1,43 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE Trustworthy #-}------------------------------------------------------------------------ |--- 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 = execClient "localhost" 5000 $ do--- > ret <- add 123 456--- > liftIO $ print ret--------------------------------------------------------------------------module Network.MessagePack.Client+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+module Network.MessagePack.Client ( -- * MessagePack Client type- ( Client+ Client , execClient+ , runClient -- * Call RPC method , call -- * RPC error , RpcError (..)+ , RpcType (..) ) where -import Control.Applicative (Applicative)-import Control.Exception (Exception)-import Control.Monad ()-import Control.Monad.Catch (MonadThrow, throwM)-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 (appSink, appSource,- clientSettings,- runTCPClient)-import Data.Conduit.Serialization.Binary-import Data.MessagePack-import qualified Data.MessagePack.Result as R-import Data.Typeable (Typeable)+import Control.Applicative (Applicative, pure)+import Control.Monad (when)+import Control.Monad.Catch (MonadCatch, catch)+import qualified Data.ByteString as S+import Data.Default.Class (Default (..)) -newtype Client a- = ClientT { runClient :: StateT Connection IO a }- deriving (Functor, Applicative, Monad, MonadIO, MonadThrow)+import Network.MessagePack.Capabilities+import Network.MessagePack.Client.Basic+import qualified Network.MessagePack.Client.Internal as Internal+import qualified Network.MessagePack.Protocol as Protocol --- | 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)+useDefault :: (Applicative m, Default a) => RpcError -> m a+useDefault _ = pure def --- | RPC error type-data RpcError- = ServerError Object -- ^ Server error- | ResultTypeError String Object -- ^ Result type mismatch- | ProtocolError String -- ^ Protocol error- deriving (Show, Eq, Ord, Typeable) -instance Exception RpcError+initClient :: Client ()+initClient = do+ caps <- Protocol.capabilitiesC [CCapMethodList] `catch` useDefault+ when (SCapMethodList `elem` caps) $ do+ mths <- Protocol.methodListC+ Internal.setMethodList mths -class RpcType r where- rpcc :: String -> [Object] -> r -instance MessagePack o => RpcType (Client o) where- rpcc name args = do- res <- rpcCall name (reverse args)- case fromObject res of- R.Success ok ->- return ok- R.Failure msg ->- throwM $ ResultTypeError msg res--instance (MessagePack o, RpcType r) => RpcType (o -> r) where- rpcc name args arg = rpcc name (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 ++ "): " ++ show res-- 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 []+runClient :: S.ByteString -> Int -> Client a -> IO a+runClient host port client =+ execClient host port (initClient >> client)
+ src/Network/MessagePack/Client/Basic.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}++-------------------------------------------------------------------+-- |+-- 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 = execClient "localhost" 5000 $ do+-- > ret <- add 123 456+-- > liftIO $ print ret+--+--------------------------------------------------------------------++module Network.MessagePack.Client.Basic (+ -- * MessagePack Client type+ Client+ , execClient++ -- * Call RPC method+ , call++ -- * RPC error+ , RpcError (..)+ , RpcType (..)+ ) where++import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.State.Strict as CMS+import qualified Data.ByteString as S+import Data.Conduit (($$+))+import Data.Conduit.Network (appSink, appSource,+ clientSettings,+ runTCPClient)+import Data.MessagePack (MessagePack, Object,+ fromObject, toObject)+import qualified Data.MessagePack.Result as R++import Network.MessagePack.Client.Internal+import Network.MessagePack.Types+++execClient :: S.ByteString -> Int -> Client a -> IO a+execClient host port client =+ runTCPClient (clientSettings port host) $ \ad -> do+ (rsrc, _) <- appSource ad $$+ return ()+ evalStateT (runClient client) Connection+ { connSource = rsrc+ , connSink = appSink ad+ , connMsgId = 0+ , connMths = []+ }+++class RpcType r where+ rpcc :: String -> [Object] -> r+++instance MessagePack o => RpcType (Client o) where+ rpcc name args = do+ res <- rpcCall name (reverse args)+ case fromObject res of+ R.Success ok ->+ return ok+ R.Failure msg ->+ throwM $ ResultTypeError msg res++instance (MessagePack o, RpcType r) => RpcType (o -> r) where+ rpcc name args arg = rpcc name (toObject arg : args)+++-- | Call an RPC Method+call :: RpcType a => String -> a+call name = rpcc name []
+ src/Network/MessagePack/Client/Internal.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.MessagePack.Client.Internal where++import Control.Applicative (Applicative)+import Control.Monad.Catch (MonadCatch, MonadThrow,+ throwM)+import Control.Monad.State.Strict as CMS+import Data.Binary as Binary+import qualified Data.ByteString as S+import Data.Conduit (ResumableSource, Sink, ($$),+ ($$++))+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Serialization.Binary (sinkGet)+import Data.MessagePack (Object, fromObject)++import Network.MessagePack.Types+++-- | RPC connection type+data Connection = Connection+ { connSource :: ResumableSource IO S.ByteString+ , connSink :: Sink S.ByteString IO ()+ , connMsgId :: Int+ , connMths :: [String]+ }+++newtype Client a+ = ClientT { runClient :: StateT Connection IO a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch)+++rpcCall :: String -> [Object] -> Client Object+rpcCall methodName args = ClientT $ do+ conn <- CMS.get+ let msgid = connMsgId conn++ (rsrc', res) <- lift $ do+ let req = packRequest (connMths conn) (0, msgid, methodName, args)+ CB.sourceLbs req $$ connSink conn+ connSource conn $$++ sinkGet Binary.get++ CMS.put conn+ { connSource = rsrc'+ , connMsgId = msgid + 1+ }++ case unpackResponse res of+ Nothing -> throwM $ ProtocolError "invalid response data"+ Just (rtype, rmsgid, rerror, rresult) -> do+ when (rtype /= 1) $+ throwM $ ProtocolError $+ "invalid response type (expect 1, but got " ++ show rtype ++ "): " ++ show res++ when (rmsgid /= msgid) $+ throwM $ ProtocolError $+ "message id mismatch: expect " ++ show msgid ++ ", but got " ++ show rmsgid++ case fromObject rerror of+ Nothing -> throwM $ RemoteError rerror+ Just () -> return rresult+++setMethodList :: [String] -> Client ()+setMethodList mths = ClientT $ do+ conn <- CMS.get+ CMS.put conn { connMths = mths }
+ src/Network/MessagePack/Protocol.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.MessagePack.Protocol where++import Control.Applicative (Applicative, pure)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.Trans (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl)++import Network.MessagePack.Capabilities+import Network.MessagePack.Client.Basic+import Network.MessagePack.Server.Basic+++capabilitiesN :: String+capabilitiesN = "rpc.capabilities"++capabilitiesC :: [ClientCapability] -> Client [ServerCapability]+capabilitiesC = call capabilitiesN++capabilitiesS+ :: Applicative m+ => [Method m]+ -> [ClientCapability]+ -> ServerT m [ServerCapability]+capabilitiesS _ _ = pure [SCapMethodList]+++methodListN :: String+methodListN = "rpc.methodList"++methodListC :: Client [String]+methodListC = call methodListN++methodListS+ :: Applicative m+ => [Method m]+ -> ServerT m [String]+methodListS = pure . map methodName+++protocolMethods+ :: (MonadBaseControl IO m, MonadIO m, MonadCatch m)+ => [Method m]+ -> [Method m]+protocolMethods methods = methods +++ [ method capabilitiesN (capabilitiesS methods)+ , method methodListN (methodListS methods)+ ]
src/Network/MessagePack/Server.hs view
@@ -1,40 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}------------------------------------------------------------------------ |--- 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+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.MessagePack.Server ( -- * RPC method types- ( Method+ Method , MethodType (..) , ServerT (..) , Server@@ -44,104 +12,22 @@ -- * Start RPC server , serve+ , runServer ) 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-import Network.Socket (SocketOption (ReuseAddr),- setSocketOption)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.Trans (MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl) --- ^ MessagePack RPC method-data Method m- = Method- { methodName :: String- , methodBody :: [Object] -> m Object- }+import Network.MessagePack.Protocol (protocolMethods)+import Network.MessagePack.Server.Basic -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 (Functor m, 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- toBody _ [] = error "messagepack-rpc methodtype instance toBody failed"---- | 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)- => Int -- ^ Port number- -> [Method m] -- ^ list of methods- -> m ()-serve port methods =- runGeneralTCPServer settings $- \ad ->- do (rsrc,_) <- appSource ad $$+ return ()- (_ :: Either ParseError ()) <-- try $ processRequests rsrc (appSink ad)- return ()- where- settings =- setAfterBind- (\s ->- setSocketOption s ReuseAddr 1)- (serverSettings port "*")- 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,name,args) = do- when (rtype /= 0) $- throwM $ ServerError $ "request type is not 0, got " ++ show rtype- ret <- callMethod name 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+runServer+ :: (MonadBaseControl IO m, MonadIO m, MonadCatch m)+ => Int -- ^ Port number+ -> [Method m] -- ^ list of methods+ -> m ()+runServer port methods =+ serve port (protocolMethods methods)
+ src/Network/MessagePack/Server/Basic.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}++-------------------------------------------------------------------+-- |+-- 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.Basic (+ -- * RPC method types+ Method+ , MethodType (..)+ , ServerT (..)+ , Server++ -- * Build a method+ , method++ -- * Get the method name+ , methodName++ -- * Start RPC server+ , serve+ ) where++import Control.Applicative (Applicative, pure, (<$>),+ (<|>))+import Control.Monad.Catch (MonadCatch, MonadThrow,+ catch, throwM)+import Control.Monad.Trans (MonadIO, MonadTrans, lift)+import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.Binary as Binary+import qualified Data.ByteString as S+import Data.Conduit (($$), ($$+), ($$++))+import Data.Conduit (ResumableSource, Sink)+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Network (appSink, appSource,+ runGeneralTCPServer,+ serverSettings,+ setAfterBind)+import Data.Conduit.Serialization.Binary (ParseError, sinkGet)+import qualified Data.List as List+import Data.MessagePack (MessagePack, Object,+ fromObject, toObject)+import qualified Data.MessagePack.Result as R+import Data.Traversable (sequenceA)+import Network.Socket (SocketOption (ReuseAddr),+ setSocketOption)++import Network.MessagePack.Types++-- ^ MessagePack RPC method+data Method m = Method+ { methodName :: String+ , methodBody :: [Object] -> m Object+ }+++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 Haskell function+ toBody :: String -> f -> [Object] -> m Object+++instance (Functor m, MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where+ toBody _ m [] = toObject <$> runServerT m+ toBody n _ ls =+ throwM $ ServerError $+ "invalid arguments for method '" ++ n ++ "': " ++ show ls+++instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where+ toBody n f (x : xs) =+ case fromObject x of+ Nothing -> throwM $ ServerError "argument type error"+ Just r -> toBody n (f r) xs+ toBody _ _ [] = error "messagepack-rpc methodtype instance toBody failed"+++-- | Build a method+method+ :: MethodType m f+ => String -- ^ Method name+ -> f -- ^ Method body+ -> Method m+method name body = Method name $ toBody name body+++processRequests+ :: (Applicative m, MonadThrow m, MonadCatch m)+ => [Method m]+ -> ResumableSource m S.ByteString+ -> Sink S.ByteString m t+ -> m b+processRequests methods rsrc sink = do+ (rsrc', res) <-+ rsrc $$++ do+ obj <- sinkGet Binary.get+ case unpackRequest obj of+ Nothing ->+ throwM $ ServerError "invalid request"+ Just req@(_, msgid, _, _) ->+ lift $ getResponse methods req `catch` \(ServerError err) ->+ return (1, msgid, toObject err, toObject ())++ _ <- CB.sourceLbs (packResponse res) $$ sink+ processRequests methods rsrc' sink+++getResponse+ :: Applicative m+ => [Method m]+ -> Request Object+ -> m Response+getResponse methods (0, msgid, mth, args) =+ process <$> callMethod methods mth args+ where+ process (R.Failure err) = (1, msgid, toObject err, toObject ())+ process (R.Success ok ) = (1, msgid, toObject (), ok)++getResponse _ (rtype, msgid, _, _) =+ pure (1, msgid, toObject ["request type is not 0, got " ++ show rtype], toObject ())+++callMethod+ :: (Applicative m)+ => [Method m]+ -> Object+ -> [Object]+ -> m (R.Result Object)+callMethod methods mth args = sequenceA $+ (stringCall =<< fromObject mth)+ <|>+ (intCall =<< fromObject mth)++ where+ stringCall name =+ case List.find ((== name) . methodName) methods of+ Nothing -> R.Failure $ "method '" ++ name ++ "' not found"+ Just m -> R.Success $ methodBody m args++ intCall ix =+ case drop ix methods of+ [] -> R.Failure $ "method #" ++ show ix ++ " not found"+ m:_ -> R.Success $ methodBody m args+++ignoreParseError :: Applicative m => ParseError -> m ()+ignoreParseError _ = pure ()+++-- | Start RPC server with a set of RPC methods.+serve+ :: (MonadBaseControl IO m, MonadIO m, MonadCatch m)+ => Int -- ^ Port number+ -> [Method m] -- ^ list of methods+ -> m ()+serve port methods =+ runGeneralTCPServer settings $ \ad -> do+ (rsrc, _) <- appSource ad $$+ return ()+ processRequests methods rsrc (appSink ad) `catch` ignoreParseError++ where+ settings =+ setAfterBind+ (\s -> setSocketOption s ReuseAddr 1)+ (serverSettings port "*")
+ src/Network/MessagePack/Types.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Network.MessagePack.Types where++import Control.Exception (Exception)+import qualified Data.ByteString.Lazy as L+import qualified Data.List as List+import Data.MessagePack (MessagePack, Object, fromObject, pack)+import Data.Typeable (Typeable)+++type Request ix = (Int, Int, ix, [Object])+type Response = (Int, Int, Object, Object)++packRequest :: (Eq mth, MessagePack mth) => [mth] -> Request mth -> L.ByteString+packRequest [] req = pack req+packRequest mths req@(rtype, msgid, mth, obj) =+ case List.elemIndex mth mths of+ Nothing -> pack req+ Just ix -> pack (rtype, msgid, ix, obj)+++packResponse :: Response -> L.ByteString+packResponse = pack++unpackResponse :: Object -> Maybe Response+unpackResponse = fromObject++unpackRequest :: MessagePack ix => Object -> Maybe (Request ix)+unpackRequest = fromObject+++-- | RPC error type+data RpcError+ = RemoteError Object -- ^ Server error+ | ResultTypeError String Object -- ^ Result type mismatch+ | ProtocolError String -- ^ Protocol error+ deriving (Show, Eq, Ord, Typeable)++instance Exception RpcError+++data ServerError = ServerError String+ deriving (Show, Typeable)++instance Exception ServerError