diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/network-msgpack-rpc.cabal b/network-msgpack-rpc.cabal
--- a/network-msgpack-rpc.cabal
+++ b/network-msgpack-rpc.cabal
@@ -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
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
+ .
+ This is a fork of 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
diff --git a/src/Network/MessagePack/Capabilities.hs b/src/Network/MessagePack/Capabilities.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/MessagePack/Capabilities.hs
@@ -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
+
+
diff --git a/src/Network/MessagePack/Client.hs b/src/Network/MessagePack/Client.hs
--- a/src/Network/MessagePack/Client.hs
+++ b/src/Network/MessagePack/Client.hs
@@ -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
--- 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 = 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)
diff --git a/src/Network/MessagePack/Client/Basic.hs b/src/Network/MessagePack/Client/Basic.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/MessagePack/Client/Basic.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Trustworthy #-}
+
+-------------------------------------------------------------------
+-- |
+-- 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 = 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 []
diff --git a/src/Network/MessagePack/Client/Internal.hs b/src/Network/MessagePack/Client/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/MessagePack/Client/Internal.hs
@@ -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 }
diff --git a/src/Network/MessagePack/Protocol.hs b/src/Network/MessagePack/Protocol.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/MessagePack/Protocol.hs
@@ -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)
+ ]
diff --git a/src/Network/MessagePack/Server.hs b/src/Network/MessagePack/Server.hs
--- a/src/Network/MessagePack/Server.hs
+++ b/src/Network/MessagePack/Server.hs
@@ -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
--- .
---
--- 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)
diff --git a/src/Network/MessagePack/Server/Basic.hs b/src/Network/MessagePack/Server/Basic.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/MessagePack/Server/Basic.hs
@@ -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
+-- .
+--
+-- 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 "*")
diff --git a/src/Network/MessagePack/Types.hs b/src/Network/MessagePack/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/MessagePack/Types.hs
@@ -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