network-msgpack-rpc 0.0.2 → 0.0.3

raw patch · 11 files changed

+370/−19 lines, 11 filesdep +MissingHPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: MissingH

API changes (from Hackage documentation)

Files

• network-msgpack-rpc.cabal +7/−1
• src/Network/MessagePack/Client.hs +2/−1
• src/Network/MessagePack/Client/Basic.hs +5/−3
• src/Network/MessagePack/Client/Internal.hs +14/−11
• src/Network/MessagePack/Interface.hs +12/−0
• src/Network/MessagePack/Interface/Internal.hs +190/−0
• src/Network/MessagePack/Internal/TypeUtil.hs +9/−0
• src/Network/MessagePack/Protocol.hs +4/−2
• src/Network/MessagePack/Rpc.hs +105/−0
• src/Network/MessagePack/Server.hs +4/−0
• src/Network/MessagePack/Server/Basic.hs +18/−1

@@ -1,5 +1,5 @@ name:                 network-msgpack-rpc-version:              0.0.2+version:              0.0.3 synopsis:             A MessagePack-RPC Implementation homepage:             http://msgpack.org/ license:              BSD3@@ -26,20 +26,26 @@   default-language: Haskell2010   ghc-options:       -Wall+      -fno-warn-unused-imports   hs-source-dirs:       src   exposed-modules:       Network.MessagePack.Client+      Network.MessagePack.Interface+      Network.MessagePack.Rpc       Network.MessagePack.Server   other-modules:       Network.MessagePack.Capabilities       Network.MessagePack.Client.Basic       Network.MessagePack.Client.Internal+      Network.MessagePack.Interface.Internal+      Network.MessagePack.Internal.TypeUtil       Network.MessagePack.Protocol       Network.MessagePack.Server.Basic       Network.MessagePack.Types   build-depends:       base < 5+    , MissingH     , binary     , binary-conduit     , bytestring

@@ -3,6 +3,7 @@ module Network.MessagePack.Client (   -- * MessagePack Client type     Client+  , ClientT   , execClient   , runClient @@ -11,7 +12,7 @@    -- * RPC error   , RpcError (..)-  , RpcType (..)+  , RpcType   ) where  import           Control.Applicative                 (Applicative, pure)

@@ -31,6 +31,7 @@ module Network.MessagePack.Client.Basic (   -- * MessagePack Client type     Client+  , ClientT   , execClient    -- * Call RPC method@@ -42,7 +43,7 @@   ) where  import           Control.Monad.Catch                 (MonadThrow, throwM)-import           Control.Monad.State.Strict          as CMS+import qualified Control.Monad.State.Strict          as CMS import qualified Data.ByteString                     as S import           Data.Conduit                        (($$+)) import           Data.Conduit.Network                (appSink, appSource,@@ -60,7 +61,7 @@ execClient host port client =   runTCPClient (clientSettings port host) $ \ad -> do     (rsrc, _) <- appSource ad $$+ return ()-    evalStateT (runClient client) Connection+    CMS.evalStateT (runClientT client) Connection       { connSource = rsrc       , connSink   = appSink ad       , connMsgId  = 0@@ -72,7 +73,8 @@   rpcc :: String -> [Object] -> r  -instance MessagePack o => RpcType (Client o) where+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

@@ -2,10 +2,11 @@ module Network.MessagePack.Client.Internal where  import           Control.Applicative               (Applicative)+import           Control.Monad                     (when) import           Control.Monad.Catch               (MonadCatch, MonadThrow,                                                     throwM)-import           Control.Monad.State.Strict        as CMS-import           Data.Binary                       as Binary+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, ($$),                                                     ($$++))@@ -17,25 +18,27 @@   -- | RPC connection type-data Connection = Connection-  { connSource :: ResumableSource IO S.ByteString-  , connSink   :: Sink S.ByteString IO ()+data Connection m = Connection+  { connSource :: ResumableSource m S.ByteString+  , connSink   :: Sink S.ByteString m ()   , connMsgId  :: Int   , connMths   :: [String]   }  -newtype Client a-  = ClientT { runClient :: StateT Connection IO a }-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch)+newtype ClientT m a+  = ClientT { runClientT :: CMS.StateT (Connection m) m a }+  deriving (Functor, Applicative, Monad, CMS.MonadIO, MonadThrow, MonadCatch) +type Client a = ClientT IO a -rpcCall :: String -> [Object] -> Client Object++rpcCall :: (MonadThrow m, CMS.MonadIO m) => String -> [Object] -> ClientT m Object rpcCall methodName args = ClientT $ do   conn <- CMS.get   let msgid = connMsgId conn -  (rsrc', res) <- lift $ do+  (rsrc', res) <- CMS.lift $ do     let req = packRequest (connMths conn) (0, msgid, methodName, args)     CB.sourceLbs req $$ connSink conn     connSource conn $$++ sinkGet Binary.get@@ -61,7 +64,7 @@         Just () -> return rresult  -setMethodList :: [String] -> Client ()+setMethodList :: Monad m => [String] -> ClientT m () setMethodList mths = ClientT $ do   conn <- CMS.get   CMS.put conn { connMths = mths }

@@ -0,0 +1,12 @@+module Network.MessagePack.Interface+  ( Returns+  , Interface+  , interface+  , call+  , concrete+  , method+  , methodIO+  , Doc (Arg, Ret)+  ) where++import           Network.MessagePack.Interface.Internal

@@ -0,0 +1,190 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+module Network.MessagePack.Interface.Internal where++import           Control.Monad.Catch                   (MonadThrow)+import           Control.Monad.Trans                   (MonadIO, liftIO)+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+++data Returns r+++data Interface f = Interface+  { name :: String+  , docs :: Doc f+  }+++data InterfaceM (m :: * -> *) f = InterfaceM+  { nameM :: String+  }+++interface :: String -> Doc f -> Interface f+interface = Interface+++concrete :: Interface f -> InterfaceM m f+concrete = InterfaceM . name+++coerce :: InterfaceM m a -> InterfaceM m b+coerce = InterfaceM . nameM+++--------------------------------------------------------------------------------+--+-- :: Documentation+--+--------------------------------------------------------------------------------+++class IsDocType f where+  data Doc f+  flatDoc :: Doc f -> MethodDocs++instance Typeable r => IsDocType (Returns r) where+  data Doc (Returns r) = Ret String+    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)+  flatDoc (Arg o r) =+    let doc = flatDoc r in+    let typeName = TypeUtil.typeName (undefined :: o) in+    doc { methodArgs = MethodVal o typeName : methodArgs doc }++deriving instance Eq   (Doc r) => Eq   (Doc (o -> r))+deriving instance Read (Doc r) => Read (Doc (o -> r))+deriving instance Show (Doc r) => Show (Doc (o -> r))+++--------------------------------------------------------------------------------+--+-- :: Client+--+--------------------------------------------------------------------------------+++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+++call :: Client.RpcType (ClientType m f) => InterfaceM m f -> ClientType m f+call = Client.call . nameM+++--------------------------------------------------------------------------------+--+-- :: Non-IO server+--+--------------------------------------------------------------------------------+++class IsReturnType (m :: * -> *) f where+  type HaskellType f+  type ServerType m f++  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++  implement i f a = next (coerce i) (f a)+    where+      next :: InterfaceM m r -> HaskellType r -> ServerType m r+      next = implement+++methodM+  :: ( Server.MethodType m (ServerType m f)+     , IsDocType f+     , IsReturnType m f+     , MonadThrow m+     )+  => InterfaceM m f -> Doc f -> HaskellType f -> Method m+methodM i doc f = Server.method (nameM i) (flatDoc doc) (implement i f)+++method+  :: ( MonadThrow m+     , Server.MethodType m (ServerType m f)+     , IsDocType f+     , IsReturnType m f)+  => Interface f -> HaskellType f -> Method m+method i = methodM (concrete i) (docs i)+++--------------------------------------------------------------------------------+--+-- :: IO server+--+--------------------------------------------------------------------------------+++class IsReturnTypeIO (m :: * -> *) f where+  type HaskellTypeIO f+  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+  type ServerTypeIO m (o -> r) = o -> ServerTypeIO m r++  implementIO i f a = next (coerce i) (f a)+    where+      next :: InterfaceM m r -> HaskellTypeIO r -> ServerTypeIO m r+      next = implementIO+++methodIOM+  :: ( Server.MethodType m (ServerTypeIO m f)+     , IsDocType f+     , IsReturnTypeIO m f+     )+  => InterfaceM m f -> Doc f -> HaskellTypeIO f -> Method m+methodIOM i doc f = Server.method (nameM i) (flatDoc doc) (implementIO i f)+++methodIO+  :: ( Server.MethodType m (ServerTypeIO m f)+     , IsDocType f+     , IsReturnTypeIO m f)+  => Interface f -> HaskellTypeIO f -> Method m+methodIO i = methodIOM (concrete i) (docs i)

@@ -0,0 +1,9 @@+module Network.MessagePack.Internal.TypeUtil where++import qualified Data.List.Utils as List+import           Data.Typeable   (Typeable)+import qualified Data.Typeable   as Typeable+++typeName :: Typeable a => a -> String+typeName = List.replace "[Char]" "String" . show . Typeable.typeOf

@@ -44,6 +44,8 @@   => [Method m]   -> [Method m] protocolMethods methods = methods ++-  [ method capabilitiesN (capabilitiesS methods)-  , method methodListN   (methodListS   methods)+  [ method capabilitiesN (MethodDocs [MethodVal "clientCaps" "ClientCapability"] (MethodVal "serverCaps" "ServerCapability"))+      (capabilitiesS methods)+  , method methodListN   (MethodDocs [] (MethodVal "names" "[String]"))+      (methodListS   methods)   ]

@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module Network.MessagePack.Rpc+  ( I.Returns+  , I.Doc (..)+  , method+  , rpc+  , docs+  , stubs, Rpc, RpcT (local)+  , stubsIO, RpcIO, RpcIOT (localIO)+  ) where++import           Control.Monad.Catch                    (MonadThrow)++import qualified Network.MessagePack.Client             as Client+import qualified Network.MessagePack.Interface.Internal as I+import qualified Network.MessagePack.Server             as Server+++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))+++--------------------------------------------------------------------------------+--+-- :: Non-IO RPCs+--+--------------------------------------------------------------------------------++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+  }++instance RpcService (RpcT mc ms f) where+  type ClientMonad (RpcT mc ms f) = mc+  type ServerMonad (RpcT mc ms f) = ms+  type F (RpcT mc ms f) = f+  rpc    = rpcPure+  method = methodPure+  docs r = (Server.methodName $ method r, I.docs $ intfPure r)+++stubs+  :: ( Client.RpcType (I.ClientType mc f)+     , Server.MethodType ms (I.ServerType ms f)+     , I.IsReturnType ms f+     , I.IsDocType f+     , MonadThrow ms+     )+  => String -> I.Doc f -> I.HaskellType f -> RpcT mc ms f+stubs n doc f = RpcT c f m i+  where+    c = Client.call n+    m = I.method i f+    i = I.interface n doc+++--------------------------------------------------------------------------------+--+-- :: IO RPCs+--+--------------------------------------------------------------------------------++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+  }++instance RpcService (RpcIOT mc ms f) where+  type ClientMonad (RpcIOT mc ms f) = mc+  type ServerMonad (RpcIOT mc ms f) = ms+  type F (RpcIOT mc ms f) = f+  rpc    = rpcIO+  method = methodIO+  docs r = (Server.methodName $ method r, I.docs $ intfIO r)+++stubsIO+  :: ( Client.RpcType (I.ClientType mc f)+     , Server.MethodType ms (I.ServerTypeIO ms f)+     , I.IsReturnTypeIO ms f+     , I.IsDocType f+     , MonadThrow ms+     )+  => String -> I.Doc f -> I.HaskellTypeIO f -> RpcIOT mc ms f+stubsIO n doc f = RpcIOT c f m i+  where+    c = Client.call n+    m = I.methodIO i f+    i = I.interface n doc

@@ -4,11 +4,15 @@   -- * RPC method types     Method   , MethodType (..)+  , MethodDocs (..)+  , MethodVal (..)   , ServerT (..)   , Server    -- * Build a method   , method+  , methodName+  , methodDocs    -- * Start RPC server   , serve

@@ -34,6 +34,8 @@ module Network.MessagePack.Server.Basic (   -- * RPC method types     Method+  , MethodVal (..)+  , MethodDocs (..)   , MethodType (..)   , ServerT (..)   , Server@@ -43,6 +45,7 @@    -- * Get the method name   , methodName+  , methodDocs    -- * Start RPC server   , serve@@ -74,9 +77,22 @@  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   } @@ -116,9 +132,10 @@ method   :: MethodType m f   => String   -- ^ Method name+  -> MethodDocs   -> f        -- ^ Method body   -> Method m-method name body = Method name $ toBody name body+method name docs body = Method name docs $ toBody name body   processRequests