network-msgpack-rpc 0.0.3 → 0.0.4

raw patch · 16 files changed

+461/−208 lines, 16 filesdep +data-default-instances-basedep +data-msgpack-typesdep +textdep ~conduitdep ~data-msgpackPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-default-instances-base, data-msgpack-types, text

Dependency ranges changed: conduit, data-msgpack

API changes (from Hackage documentation)

Files

• network-msgpack-rpc.cabal +12/−3
• src/Network/MessagePack/Capabilities.hs +6/−5
• src/Network/MessagePack/Client.hs +1/−0
• src/Network/MessagePack/Client/Basic.hs +5/−25
• src/Network/MessagePack/Client/Internal.hs +49/−21
• src/Network/MessagePack/Interface/Internal.hs +12/−25
• src/Network/MessagePack/Internal/TypeUtil.hs +8/−3
• src/Network/MessagePack/Protocol.hs +16/−5
• src/Network/MessagePack/Rpc.hs +26/−13
• src/Network/MessagePack/Server/Basic.hs +53/−64
• src/Network/MessagePack/Types.hs +7/−44
• src/Network/MessagePack/Types/Client.hs +22/−0
• src/Network/MessagePack/Types/Error.hs +26/−0
• src/Network/MessagePack/Types/Server.hs +48/−0
• src/Network/MessagePack/Types/Spec.hs +32/−0
• test/Network/MessagePack/ServerSpec.hs +138/−0

@@ -1,5 +1,5 @@ name:                 network-msgpack-rpc-version:              0.0.3+version:              0.0.4 synopsis:             A MessagePack-RPC Implementation homepage:             http://msgpack.org/ license:              BSD3@@ -34,6 +34,7 @@       Network.MessagePack.Interface       Network.MessagePack.Rpc       Network.MessagePack.Server+      Network.MessagePack.Types   other-modules:       Network.MessagePack.Capabilities       Network.MessagePack.Client.Basic@@ -42,7 +43,10 @@       Network.MessagePack.Internal.TypeUtil       Network.MessagePack.Protocol       Network.MessagePack.Server.Basic-      Network.MessagePack.Types+      Network.MessagePack.Types.Client+      Network.MessagePack.Types.Error+      Network.MessagePack.Types.Server+      Network.MessagePack.Types.Spec   build-depends:       base < 5     , MissingH@@ -52,12 +56,15 @@     , conduit     , conduit-extra     , data-default-class-    , data-msgpack      >= 0.0.4+    , data-default-instances-base+    , data-msgpack                      >= 0.0.11+    , data-msgpack-types                >= 0.0.1     , exceptions     , monad-control     , mtl     , network     , tagged+    , text  test-suite testsuite   type: exitcode-stdio-1.0@@ -66,6 +73,8 @@       -Wall   hs-source-dirs: test   main-is: testsuite.hs+  other-modules:+      Network.MessagePack.ServerSpec   build-depends:       base < 5     , async

@@ -1,5 +1,8 @@ {-# LANGUAGE DeriveGeneric #-}-module Network.MessagePack.Capabilities where+module Network.MessagePack.Capabilities+  ( ServerCapability (..)+  , ClientCapability (..)+  ) where  import           Data.MessagePack (MessagePack) import           GHC.Generics     (Generic)@@ -11,7 +14,7 @@     -- 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)+  deriving (Eq, Generic)  instance MessagePack ServerCapability @@ -20,8 +23,6 @@   = CCapMethodList     -- ^ Client supports method lists and can send more efficient method codes     -- instead of strings for names.-  deriving (Eq, Read, Show, Generic)+  deriving (Eq, Generic)  instance MessagePack ClientCapability--

@@ -20,6 +20,7 @@ import           Control.Monad.Catch                 (MonadCatch, catch) import qualified Data.ByteString                     as S import           Data.Default.Class                  (Default (..))+import           Data.Default.Instances.Base         ()  import           Network.MessagePack.Capabilities import           Network.MessagePack.Client.Basic

@@ -51,10 +51,13 @@                                                       runTCPClient) import           Data.MessagePack                    (MessagePack, Object,                                                       fromObject, toObject)-import qualified Data.MessagePack.Result             as R+import qualified Data.MessagePack.Types.Result       as R+import           Data.Text                           (Text)+import qualified Data.Text                           as T  import           Network.MessagePack.Client.Internal-import           Network.MessagePack.Types+import           Network.MessagePack.Types.Client+import           Network.MessagePack.Types.Error   execClient :: S.ByteString -> Int -> Client a -> IO a@@ -67,26 +70,3 @@       , connMsgId  = 0       , connMths   = []       }---class RpcType r where-  rpcc :: String -> [Object] -> r---instance (CMS.MonadIO m, MonadThrow m, MessagePack o)-    => RpcType (ClientT m 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 []

@@ -1,28 +1,42 @@+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.MessagePack.Client.Internal where -import           Control.Applicative               (Applicative)-import           Control.Monad                     (when)-import           Control.Monad.Catch               (MonadCatch, MonadThrow,-                                                    throwM)-import qualified Control.Monad.State.Strict        as CMS-import qualified 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           Control.Applicative                    (Applicative)+import           Control.Monad                          (when)+import           Control.Monad.Catch                    (MonadCatch, MonadThrow,+                                                         throwM)+import qualified Control.Monad.State.Strict             as CMS+import qualified 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                       (MessagePack (fromObject),+                                                         Object)+import qualified Data.MessagePack.Types.Result          as R+import           Data.Monoid                            ((<>))+import           Data.Text                              (Text)+import qualified Data.Text                              as T -import           Network.MessagePack.Types+import           Network.MessagePack.Interface.Internal (IsClientType (..),+                                                         Returns)+import           Network.MessagePack.Types.Client+import           Network.MessagePack.Types.Error+import           Network.MessagePack.Types.Spec   -- | RPC connection type data Connection m = Connection-  { connSource :: ResumableSource m S.ByteString-  , connSink   :: Sink S.ByteString m ()-  , connMsgId  :: Int-  , connMths   :: [String]+  { connSource :: !(ResumableSource m S.ByteString)+  , connSink   :: !(Sink S.ByteString m ())+  , connMsgId  :: !Int+  , connMths   :: ![Text]   }  @@ -32,8 +46,22 @@  type Client a = ClientT IO a +instance IsClientType m (Returns r) where+  type ClientType m (Returns r) = ClientT m r -rpcCall :: (MonadThrow m, CMS.MonadIO m) => String -> [Object] -> ClientT m Object++instance (CMS.MonadIO m, MonadThrow m, MessagePack o)+    => RpcType (ClientT m 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 (T.pack msg) res+++rpcCall :: (MonadThrow m, CMS.MonadIO m) => Text -> [Object] -> ClientT m Object rpcCall methodName args = ClientT $ do   conn <- CMS.get   let msgid = connMsgId conn@@ -53,18 +81,18 @@     Just (rtype, rmsgid, rerror, rresult) -> do       when (rtype /= 1) $         throwM $ ProtocolError $-          "invalid response type (expect 1, but got " ++ show rtype ++ "): " ++ show res+          "invalid response type (expect 1, but got " <> T.pack (show rtype) <> "): " <> T.pack (show res)        when (rmsgid /= msgid) $         throwM $ ProtocolError $-          "message id mismatch: expect " ++ show msgid ++ ", but got " ++ show rmsgid+          "message id mismatch: expect " <> T.pack (show msgid) <> ", but got " <> T.pack (show rmsgid)        case fromObject rerror of         Nothing -> throwM $ RemoteError rerror         Just () -> return rresult  -setMethodList :: Monad m => [String] -> ClientT m ()+setMethodList :: Monad m => [Text] -> ClientT m () setMethodList mths = ClientT $ do   conn <- CMS.get   CMS.put conn { connMths = mths }

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE InstanceSigs          #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe                  #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-}@@ -9,31 +10,31 @@  import           Control.Monad.Catch                   (MonadThrow) import           Control.Monad.Trans                   (MonadIO, liftIO)+import           Data.Text                             (Text) import           Data.Typeable                         (Typeable) -import           Network.MessagePack.Client            (ClientT)-import qualified Network.MessagePack.Client            as Client import qualified Network.MessagePack.Internal.TypeUtil as TypeUtil-import           Network.MessagePack.Server            (Method, MethodDocs (..),-                                                        MethodVal (..), ServerT)-import qualified Network.MessagePack.Server            as Server+import qualified Network.MessagePack.Types.Client      as Client+import           Network.MessagePack.Types.Server      (Method, MethodDocs (..),+                                                        MethodVal (..))+import qualified Network.MessagePack.Types.Server      as Server   data Returns r   data Interface f = Interface-  { name :: String-  , docs :: Doc f+  { name :: !Text+  , docs :: !(Doc f)   }   data InterfaceM (m :: * -> *) f = InterfaceM-  { nameM :: String+  { nameM :: !Text   }  -interface :: String -> Doc f -> Interface f+interface :: Text -> Doc f -> Interface f interface = Interface  @@ -57,14 +58,14 @@   flatDoc :: Doc f -> MethodDocs  instance Typeable r => IsDocType (Returns r) where-  data Doc (Returns r) = Ret String+  data Doc (Returns r) = Ret Text     deriving (Eq, Read, Show)   flatDoc (Ret x) =     let typeName = TypeUtil.typeName (undefined :: r) in     MethodDocs [] (MethodVal x typeName)  instance (Typeable o, IsDocType r) => IsDocType (o -> r) where-  data Doc (o -> r) = Arg String (Doc r)+  data Doc (o -> r) = Arg Text (Doc r)   flatDoc (Arg o r) =     let doc = flatDoc r in     let typeName = TypeUtil.typeName (undefined :: o) in@@ -85,9 +86,6 @@ class IsClientType (m :: * -> *) f where   type ClientType m f -instance IsClientType m (Returns r) where-  type ClientType m (Returns r) = ClientT m r- instance IsClientType m r => IsClientType m (o -> r) where   type ClientType m (o -> r) = o -> ClientType m r @@ -109,12 +107,7 @@    implement :: InterfaceM m f -> HaskellType f -> ServerType m f -instance Monad m => IsReturnType m (Returns r) where-  type HaskellType (Returns r) = r-  type ServerType m (Returns r) = ServerT m r -  implement _ = return- instance IsReturnType m r => IsReturnType m (o -> r) where   type HaskellType (o -> r) = o -> HaskellType r   type ServerType m (o -> r) = o -> ServerType m r@@ -156,12 +149,6 @@   type ServerTypeIO m f    implementIO :: InterfaceM m f -> HaskellTypeIO f -> ServerTypeIO m f--instance MonadIO m => IsReturnTypeIO m (Returns r) where-  type HaskellTypeIO (Returns r) = IO r-  type ServerTypeIO m (Returns r) = ServerT m r--  implementIO _ = liftIO  instance IsReturnTypeIO m r => IsReturnTypeIO m (o -> r) where   type HaskellTypeIO (o -> r) = o -> HaskellTypeIO r

@@ -1,9 +1,14 @@-module Network.MessagePack.Internal.TypeUtil where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe              #-}+module Network.MessagePack.Internal.TypeUtil+  ( typeName+  ) where  import qualified Data.List.Utils as List+import qualified Data.Text       as T import           Data.Typeable   (Typeable) import qualified Data.Typeable   as Typeable  -typeName :: Typeable a => a -> String-typeName = List.replace "[Char]" "String" . show . Typeable.typeOf+typeName :: Typeable a => a -> T.Text+typeName = T.replace "[Char]" "String" . T.pack . show . Typeable.typeOf

@@ -1,18 +1,29 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}-module Network.MessagePack.Protocol where+{-# LANGUAGE OverloadedStrings     #-} +module Network.MessagePack.Protocol+  ( capabilitiesN+  , capabilitiesC+  , capabilitiesS+  , methodListN+  , methodListC+  , methodListS+  , protocolMethods+  ) where+ import           Control.Applicative              (Applicative, pure) import           Control.Monad.Catch              (MonadCatch) import           Control.Monad.Trans              (MonadIO) import           Control.Monad.Trans.Control      (MonadBaseControl)+import           Data.Text                        (Text)  import           Network.MessagePack.Capabilities import           Network.MessagePack.Client.Basic import           Network.MessagePack.Server.Basic  -capabilitiesN :: String+capabilitiesN :: Text capabilitiesN = "rpc.capabilities"  capabilitiesC :: [ClientCapability] -> Client [ServerCapability]@@ -26,16 +37,16 @@ capabilitiesS _ _ = pure [SCapMethodList]  -methodListN :: String+methodListN :: Text methodListN = "rpc.methodList" -methodListC :: Client [String]+methodListC :: Client [Text] methodListC = call methodListN  methodListS   :: Applicative m   => [Method m]-  -> ServerT m [String]+  -> ServerT m [Text] methodListS = pure . map methodName  

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe                  #-} {-# LANGUAGE TypeFamilies          #-} module Network.MessagePack.Rpc   ( I.Returns@@ -12,19 +13,25 @@   ) where  import           Control.Monad.Catch                    (MonadThrow)+import           Data.Text                              (Text) -import qualified Network.MessagePack.Client             as Client import qualified Network.MessagePack.Interface.Internal as I-import qualified Network.MessagePack.Server             as Server+import qualified Network.MessagePack.Types.Client       as Client+import qualified Network.MessagePack.Types.Server       as Server +-- Import orphan instances for RpcType and IsReturnType.+-- TODO(SX91): Avoid orphan instances. See issue #7.+import           Network.MessagePack.Client.Basic       ()+import           Network.MessagePack.Server.Basic       () + class RpcService rpc where   type ClientMonad rpc :: * -> *   type ServerMonad rpc :: * -> *   type F rpc   rpc    :: rpc -> I.ClientType (ClientMonad rpc) (F rpc)   method :: rpc -> Server.Method (ServerMonad rpc)-  docs   :: rpc -> (String, I.Doc (F rpc))+  docs   :: rpc -> (Text, I.Doc (F rpc))   --------------------------------------------------------------------------------@@ -36,10 +43,10 @@ type Rpc f = RpcT IO IO f  data RpcT mc ms f = RpcT-  { rpcPure    :: I.ClientType mc f-  , local      :: I.HaskellType f-  , methodPure :: Server.Method ms-  , intfPure   :: I.Interface f+  { rpcPure    :: !(I.ClientType mc f)+  , local      :: !(I.HaskellType f)+  , methodPure :: !(Server.Method ms)+  , intfPure   :: !(I.Interface f)   }  instance RpcService (RpcT mc ms f) where@@ -47,8 +54,11 @@   type ServerMonad (RpcT mc ms f) = ms   type F (RpcT mc ms f) = f   rpc    = rpcPure+  {-# INLINE rpc #-}   method = methodPure+  {-# INLINE method #-}   docs r = (Server.methodName $ method r, I.docs $ intfPure r)+  {-# INLINE docs #-}   stubs@@ -58,7 +68,7 @@      , I.IsDocType f      , MonadThrow ms      )-  => String -> I.Doc f -> I.HaskellType f -> RpcT mc ms f+  => Text -> I.Doc f -> I.HaskellType f -> RpcT mc ms f stubs n doc f = RpcT c f m i   where     c = Client.call n@@ -75,10 +85,10 @@ type RpcIO f = RpcIOT IO IO f  data RpcIOT mc ms f = RpcIOT-  { rpcIO    :: I.ClientType mc f-  , localIO  :: I.HaskellTypeIO f-  , methodIO :: Server.Method ms-  , intfIO   :: I.Interface f+  { rpcIO    :: !(I.ClientType mc f)+  , localIO  :: !(I.HaskellTypeIO f)+  , methodIO :: !(Server.Method ms)+  , intfIO   :: !(I.Interface f)   }  instance RpcService (RpcIOT mc ms f) where@@ -86,8 +96,11 @@   type ServerMonad (RpcIOT mc ms f) = ms   type F (RpcIOT mc ms f) = f   rpc    = rpcIO+  {-# INLINE rpc #-}   method = methodIO+  {-# INLINE method #-}   docs r = (Server.methodName $ method r, I.docs $ intfIO r)+  {-# INLINE docs #-}   stubsIO@@ -97,7 +110,7 @@      , I.IsDocType f      , MonadThrow ms      )-  => String -> I.Doc f -> I.HaskellTypeIO f -> RpcIOT mc ms f+  => Text -> I.Doc f -> I.HaskellTypeIO f -> RpcIOT mc ms f stubsIO n doc f = RpcIOT c f m i   where     c = Client.call n

@@ -5,6 +5,8 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE Trustworthy                #-}+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  ------------------------------------------------------------------- -- |@@ -51,91 +53,78 @@   , 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           Control.Applicative                    (Applicative, pure,+                                                         (<$>), (<|>))+import           Control.Monad.Catch                    (MonadCatch, MonadThrow,+                                                         catch, throwM)+import           Control.Monad.Trans                    (MonadIO, MonadTrans,+                                                         lift, liftIO)+import           Control.Monad.Trans.Control            (MonadBaseControl)+import qualified 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.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.Types.Result          as R+import           Data.Monoid                            ((<>))+import           Data.Text                              (Text)+import qualified Data.Text                              as T+import           Data.Traversable                       (sequenceA)+import           Network.Socket                         (SocketOption (ReuseAddr),+                                                         setSocketOption) +import           Network.MessagePack.Interface.Internal (IsReturnType (..),+                                                         IsReturnTypeIO (..),+                                                         Returns) import           Network.MessagePack.Types -data MethodVal = MethodVal-  { valName :: String-  , valType :: String-  }-  deriving (Show) -data MethodDocs = MethodDocs-  { methodArgs :: [MethodVal]-  , methodRetv :: MethodVal-  }-  deriving (Show)---- ^ MessagePack RPC method-data Method m = Method-  { methodName :: String-  , methodDocs :: MethodDocs-  , methodBody :: [Object] -> m Object-  }-- newtype ServerT m a = ServerT { runServerT :: m a }   deriving (Functor, Applicative, Monad, MonadIO)   instance MonadTrans ServerT where   lift = ServerT+  {-# INLINE lift #-}   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 (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"  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+      "invalid arguments for method '" <> n <> "': " <> T.pack (show ls) +-- Pure server+instance Monad m => IsReturnType m (Returns r) where+  type HaskellType (Returns r) = r+  type ServerType m (Returns r) = ServerT m r -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"+  implement _ = return +-- IO Server+instance MonadIO m => IsReturnTypeIO m (Returns r) where+  type HaskellTypeIO (Returns r) = IO r+  type ServerTypeIO m (Returns r) = ServerT m r --- | Build a method-method-  :: MethodType m f-  => String   -- ^ Method name-  -> MethodDocs-  -> f        -- ^ Method body-  -> Method m-method name docs body = Method name docs $ toBody name body+  implementIO _ = liftIO   processRequests@@ -171,7 +160,7 @@     process (R.Success ok ) = (1, msgid, toObject (), ok)  getResponse _ (rtype, msgid, _, _) =-  pure (1, msgid, toObject ["request type is not 0, got " ++ show rtype], toObject ())+  pure (1, msgid, toObject ["request type is not 0, got " <> T.pack (show rtype)], toObject ())   callMethod@@ -188,12 +177,12 @@   where     stringCall name =       case List.find ((== name) . methodName) methods of-        Nothing -> R.Failure $ "method '" ++ name ++ "' not found"+        Nothing -> R.Failure $ "method '" <> T.unpack name <> "' not found"         Just m  -> R.Success $ methodBody m args      intCall ix =       case drop ix methods of-        []  -> R.Failure $ "method #" ++ show ix ++ " not found"+        []  -> R.Failure $ "method #" <> show ix <> " not found"         m:_ -> R.Success $ methodBody m args  

@@ -1,45 +1,8 @@-{-# 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)+module Network.MessagePack.Types+  ( module X+  ) where -instance Exception ServerError+import           Network.MessagePack.Types.Client as X+import           Network.MessagePack.Types.Error  as X+import           Network.MessagePack.Types.Server as X+import           Network.MessagePack.Types.Spec   as X

@@ -0,0 +1,22 @@+module Network.MessagePack.Types.Client+  ( RpcType (..)+  , call+  ) where++import           Data.MessagePack (MessagePack (toObject), Object)+import           Data.Text        (Text)+++class RpcType r where+  rpcc :: Text -> [Object] -> r+++instance (MessagePack o, RpcType r) => RpcType (o -> r) where+  rpcc name args arg = rpcc name (toObject arg : args)+  {-# INLINE rpcc #-}+++-- | Call an RPC Method+call :: RpcType a => Text -> a+call name = rpcc name []+{-# INLINE call #-}

@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Network.MessagePack.Types.Error+  ( RpcError (..)+  , ServerError (..)+  ) where++import           Control.Exception (Exception)+import           Data.MessagePack  (Object)+import           Data.Text         (Text)+import           Data.Typeable     (Typeable)+++-- | RPC error type+data RpcError+  = RemoteError !Object           -- ^ Server error+  | ResultTypeError !Text !Object -- ^ Result type mismatch+  | ProtocolError !Text           -- ^ Protocol error+  deriving (Show, Eq, Ord, Typeable)++instance Exception RpcError+++newtype ServerError = ServerError Text+  deriving (Show, Typeable)++instance Exception ServerError

@@ -0,0 +1,48 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe                  #-}+module Network.MessagePack.Types.Server+  ( MethodVal (..)+  , MethodDocs (..)+  , MethodType (..)+  , Method (..)+  , method+  ) where++import           Control.Monad    (Monad)+import           Data.MessagePack (Object)+import           Data.Text        (Text)+++data MethodVal = MethodVal+  { valName :: !Text+  , valType :: !Text+  }+  deriving (Show)++data MethodDocs = MethodDocs+  { methodArgs :: ![MethodVal]+  , methodRetv :: !MethodVal+  }+  deriving (Show)++-- ^ MessagePack RPC method+data Method m = Method+  { methodName :: !Text+  , methodDocs :: !MethodDocs+  , methodBody :: [Object] -> m Object+  }+++class Monad m => MethodType m f where+  -- | Create a RPC method from a Haskell function+  toBody :: Text -> f -> [Object] -> m Object+++-- | Build a method+method+  :: MethodType m f+  => Text     -- ^ Method name+  -> MethodDocs+  -> f        -- ^ Method body+  -> Method m+method name docs body = Method name docs $ toBody name body

@@ -0,0 +1,32 @@+module Network.MessagePack.Types.Spec+  ( Request+  , Response+  , packRequest+  , packResponse+  , unpackRequest+  , unpackResponse+  ) where++import qualified Data.ByteString.Lazy as L+import qualified Data.List            as List+import           Data.MessagePack     (MessagePack, Object, fromObject, pack)++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

@@ -0,0 +1,138 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.MessagePack.ServerSpec (spec) where++import           Test.Hspec++import           Control.Concurrent            (threadDelay)+import           Control.Concurrent.Async      (race_)+import           Control.Monad.Trans           (liftIO)+import qualified Data.ByteString               as S+import           Network                       (withSocketsDo)++import           Network.MessagePack.Client    (Client)+import qualified Network.MessagePack.Client    as Client+import           Network.MessagePack.Interface (Doc (..), Interface, Returns,+                                                call, concrete, interface,+                                                method, methodIO)+import qualified Network.MessagePack.Rpc       as Rpc+import qualified Network.MessagePack.Server    as Server+++add :: Int -> Int -> Int+add = (+)++addI :: Interface (Int -> Int -> Returns Int)+addC :: Int -> Int -> Client Int+(addI, addC) = (interface "add" (Arg "a" $ Arg "b" $ Ret "sum"), call . concrete $ addI)++addR :: Rpc.Rpc (Int -> Int -> Returns Int)+addR = Rpc.stubs "add" (Arg "a" $ Arg "b" $ Ret "sum")+  add+++echo :: String -> IO String+echo s = return $ "***" ++ s ++ "***"++echoI :: Interface (String -> Returns String)+echoC :: String -> Client String+(echoI, echoC) = (interface "echo" (Arg "input" $ Ret "output"), call . concrete $ echoI)+++helloR :: Rpc.Rpc (String -> Returns String)+helloR = Rpc.stubs "hello" (Arg "name" $ Ret "hello")+  ("Hello, " ++)+++helloIOR :: Rpc.RpcIO (String -> Returns String)+helloIOR = Rpc.stubsIO "helloIO" (Arg "name" $ Ret "hello") $+  return . ("Hello, " ++)+++port :: Int+port = 5000+++runTest+  :: (S.ByteString -> Int -> Client (Int, String) -> IO (Int, String))+  -> (Int -> [Server.Method IO] -> IO ())+  -> IO ()+runTest runC runS = withSocketsDo $+  server runS `race_` do+    threadDelay 1000+    res <- client runC+    res `shouldBe` (123 + 456, "***hello***")+++spec :: Spec+spec = do+  describe "simple client" $ do+    it "can communicate with simple server" $+      runTest Client.execClient Server.serve++    it "can communicate with advanced server" $+      runTest Client.execClient Server.runServer++  describe "advanced client" $ do+    it "can communicate with simple server" $+      runTest Client.runClient Server.serve++    it "can communicate with advanced server" $+      runTest Client.runClient Server.runServer++  describe "documentation" $ do+    it "is type-safe" $+      Rpc.docs helloR `shouldBe` ("hello", Arg "name" $ Ret "hello")++    it "works for IO and non-IO" $ do+      Rpc.docs helloR   `shouldBe` ("hello"  , Arg "name" $ Ret "hello")+      Rpc.docs helloIOR `shouldBe` ("helloIO", Arg "name" $ Ret "hello")++    it "has working read/show implementations" $ do+      let docs = Rpc.docs addR+      read (show docs) `shouldBe` docs+      show docs `shouldBe` "(\"add\",Arg \"a\" (Arg \"b\" (Ret \"sum\")))"++    it "can be retrieved from type-erased methods" $ do+      let docs = map Server.methodDocs methods+      length docs `shouldNotBe` 0+      mapM_ (\mdoc -> do+          let args = Server.methodArgs mdoc+          let retv = Server.methodRetv mdoc+          length args `shouldNotBe` 0+          mapM_ (\arg -> do+              Server.valName arg `shouldNotBe` ""+              Server.valType arg `shouldNotBe` ""+            ) args+          Server.valName retv `shouldNotBe` ""+          Server.valType retv `shouldNotBe` ""+        ) docs+++methods :: [Server.Method IO]+methods =+  [ method addI add+  , methodIO echoI echo+  , Rpc.method helloR+  , Rpc.method helloIOR+  ]+++server :: (Int -> [Server.Method IO] -> IO ()) -> IO ()+server run = run port methods+++client+  :: (S.ByteString -> Int -> Client (Int, String) -> IO (Int, String))+  -> IO (Int, String)+client run =+  run "127.0.0.1" port $ do+    r1 <- addC 123 456+    liftIO $ r1 `shouldBe` 123 + 456+    r2 <- echoC "hello"+    liftIO $ r2 `shouldBe` "***hello***"+    r3 <- Rpc.rpc helloR "iphy"+    liftIO $ r3 `shouldBe` "Hello, iphy"+    r4 <- Rpc.rpc helloIOR "iphy"+    liftIO $ r4 `shouldBe` "Hello, iphy"+    return (r1, r2)