msgpack-rpc 0.7.1.2 → 0.8.0

raw patch · 6 files changed

+336/−319 lines, 6 filesdep +asyncdep +hspecdep +monad-controldep −deepseqdep ~attoparsec-conduitdep ~basedep ~conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: async, hspec, monad-control, msgpack-rpc, network-conduit

Dependencies removed: deepseq

Dependency ranges changed: attoparsec-conduit, base, conduit, mtl, network

API changes (from Hackage documentation)

Files

• Network/MessagePackRpc/Client.hs +128/−139
• Network/MessagePackRpc/Server.hs +118/−118
• msgpack-rpc.cabal +46/−38
• test.hs +44/−0
• test/Cli.hs +0/−13
• test/Serv.hs +0/−11

@@ -1,139 +1,128 @@-{-# Language DeriveDataTypeable #-}------------------------------------------------------------------------ |--- Module    : Network.MessagePackRpc.Client--- Copyright : (c) Hideyuki Tanaka, 2010--- License   : BSD3------ Maintainer:  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 :: RpcMethod (Int -> Int -> IO Int)--- >add = method "add"--- >--- >main = do--- >  conn <- connect "127.0.0.1" 1234--- >  print =<< add conn 123 456--------------------------------------------------------------------------module Network.MessagePackRpc.Client (-  -- * RPC connection-  Connection,-  connect,-  disconnect,-  -  -- * RPC error-  RpcError(..),-  -  -- * Call RPC method-  RpcMethod,-  call,-  method,-  ) where--import Control.Concurrent.MVar-import Control.Exception-import Control.Monad-import qualified Data.ByteString.Lazy as BL-import qualified Data.Conduit as C-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Attoparsec as CA-import Data.Functor-import Data.MessagePack-import Data.Typeable-import Network-import System.IO-import System.Random---- | RPC connection type-data Connection-  = Connection-    { connHandle :: MVar Handle }---- | Connect to RPC server-connect :: String -- ^ Host name-           -> Int -- ^ Port number-           -> IO Connection -- ^ Connection-connect addr port = withSocketsDo $ do-  h <- connectTo addr (PortNumber $ fromIntegral port)-  mh <- newMVar h-  return $ Connection-    { connHandle = mh-    }---- | Disconnect a connection-disconnect :: Connection -> IO ()-disconnect Connection { connHandle = mh } =-  hClose =<< takeMVar mh---- | RPC error type-data RpcError-  = ServerError Object -- ^ Server error-  | ResultTypeError String -- ^ Result type mismatch-  | ProtocolError String -- ^ Protocol error-  deriving (Eq, Ord, Typeable)--instance Exception RpcError--instance Show RpcError where-  show (ServerError err) =-    "server error: " ++ show err-  show (ResultTypeError err) =-    "result type error: " ++ err-  show (ProtocolError err) =-    "protocol error: " ++ err--class RpcType r where-  rpcc :: Connection -> String -> [Object] -> r--fromObject' :: OBJECT o => Object -> o-fromObject' o =-  case tryFromObject o of-    Left err -> throw $ ResultTypeError err-    Right r -> r--instance OBJECT o => RpcType (IO o) where-  rpcc c m args = return . fromObject' =<< rpcCall c m (reverse args)--instance (OBJECT o, RpcType r) => RpcType (o -> r) where-  rpcc c m args arg = rpcc c m (toObject arg:args)--rpcCall :: Connection -> String -> [Object] -> IO Object-rpcCall Connection{ connHandle = mh } m args = withMVar mh $ \h -> do-  msgid <- (`mod`2^(30::Int)) <$> randomIO :: IO Int-  BL.hPutStr h $ pack (0 ::Int, msgid, m, args)-  hFlush h-  C.runResourceT $ CB.sourceHandle h C.$$ do-    (rtype, rmsgid, rerror, rresult) <- CA.sinkParser get-    when (rtype /= (1 :: Int)) $-      throw $ ProtocolError $ "response type is not 1 (got " ++ show rtype ++ ")"-    when (rmsgid /= msgid) $-      throw $ ProtocolError $ "message id mismatch: expect " ++ show msgid ++ ", but got " ++ show rmsgid-    case tryFromObject rerror of-      Left _ ->-        throw $ ServerError rerror-      Right () ->-        return rresult---- | Call an RPC Method-call :: RpcType a =>-        Connection -- ^ Connection-        -> String -- ^ Method name-        -> a-call c m = rpcc c m []---- | Create an RPC Method (call c m == method m c)-method :: RpcType a => String -> RpcMethod a-method c m = call m c--type RpcMethod a = Connection -> a+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
+{-# LANGUAGE GADTs, FlexibleContexts #-}
+
+-------------------------------------------------------------------
+-- |
+-- Module    : Network.MessagePackRpc.Client
+-- Copyright : (c) Hideyuki Tanaka, 2010-2012
+-- 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 = runClient "localhost" 5000 $ do
+-- >   ret <- add 123 456
+-- >   liftIO $ print ret
+--
+--------------------------------------------------------------------
+
+module Network.MessagePackRpc.Client (
+  -- * MessagePack Client type
+  ClientT, Client,
+  runClient,
+
+  -- * Call RPC method
+  call,
+
+  -- * RPC error
+  RpcError(..),
+  ) where
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans.Control
+import Control.Monad.State.Strict as CMS
+import qualified Data.ByteString as S
+import Data.Conduit
+import qualified Data.Conduit.Attoparsec as CA
+import qualified Data.Conduit.Binary as CB
+import Data.Conduit.Network
+import Data.MessagePack as M
+import Data.Typeable
+
+type Client = ClientT IO
+
+newtype ClientT m a
+  = ClientT { unClientT :: StateT (Connection m) m a }
+  deriving (Monad, MonadIO, MonadThrow)
+
+-- It can't derive by newtype deriving...
+instance MonadTrans ClientT where
+  lift = ClientT . lift
+
+-- | RPC connection type
+data Connection m where
+  Connection ::
+    !(ResumableSource m S.ByteString)
+    -> !(Sink S.ByteString m ())
+    -> !Int
+    -> Connection m
+
+runClient :: (MonadIO m, MonadBaseControl IO m)
+             => String -> Int -> ClientT m a -> m ()
+runClient host port m = do
+  runTCPClient (ClientSettings port host) $ \src sink -> do
+    (rsrc, _) <- src $$+ return ()
+    void $ evalStateT (unClientT m) (Connection rsrc sink 0)
+
+-- | RPC error type
+data RpcError
+  = ServerError Object     -- ^ Server error
+  | ResultTypeError String -- ^ Result type mismatch
+  | ProtocolError String   -- ^ Protocol error
+  deriving (Show, Eq, Ord, Typeable)
+
+instance Exception RpcError
+
+class RpcType r where
+  rpcc :: String -> [Object] -> r
+
+instance (MonadIO m, MonadThrow m, OBJECT o) => RpcType (ClientT m o) where
+  rpcc m args = do
+    res <- rpcCall m (reverse args)
+    case tryFromObject res of
+      Left err -> monadThrow $ ResultTypeError err
+      Right r  -> return r
+
+instance (OBJECT o, RpcType r) => RpcType (o -> r) where
+  rpcc m args arg = rpcc m (toObject arg:args)
+
+rpcCall :: (MonadIO m, MonadThrow m) => String -> [Object] -> ClientT m Object
+rpcCall methodName args = ClientT $ do
+  Connection rsrc sink msgid <- CMS.get
+  (rsrc', (rtype, rmsgid, rerror, rresult)) <- lift $ do
+    CB.sourceLbs (pack (0 :: Int, msgid, methodName, args)) $$ sink
+    rsrc $$++ CA.sinkParser M.get
+  CMS.put $ Connection rsrc' sink (msgid + 1)
+
+  when (rtype /= (1 :: Int)) $
+    monadThrow $ ProtocolError $
+      "invalid response type (expect 1, but got " ++ show rtype ++ ")"
+  when (rmsgid /= msgid) $
+    monadThrow $ ProtocolError $
+      "message id mismatch: expect "
+      ++ show msgid ++ ", but got "
+      ++ show rmsgid
+  case tryFromObject rerror of
+    Left _ ->
+      monadThrow $ ServerError rerror
+    Right () ->
+      return rresult
+
+-- | Call an RPC Method
+call :: RpcType a
+        => String -- ^ Method name
+        -> a
+call m = rpcc m []

@@ -1,118 +1,118 @@----------------------------------------------------------------------- |--- Module    : Network.MessagePackRpc.Server--- Copyright : (c) Hideyuki Tanaka, 2010--- 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 -> IO Int--- >add x y = return $ x + y--- >--- >main =--- >  serve 1234 [("add", fun add)]--------------------------------------------------------------------------module Network.MessagePackRpc.Server (-  -- * RPC method types-  RpcMethod,-  RpcMethodType(..),-  -- * Create RPC method-  fun,-  -- * Start RPC server-  serve,-  ) where--import Control.Applicative-import Control.Concurrent-import Control.DeepSeq-import Control.Exception as E-import Control.Monad-import Control.Monad.Trans-import qualified Data.ByteString.Lazy as BL-import qualified Data.Conduit as C-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Attoparsec as CA-import Data.Maybe-import Data.MessagePack-import Network-import System.IO--import Prelude hiding (catch)--type RpcMethod = [Object] -> IO Object--class RpcMethodType f where-  toRpcMethod :: f -> RpcMethod--instance OBJECT o => RpcMethodType (IO o) where-  toRpcMethod m = \[] -> toObject <$> m--instance (OBJECT o, RpcMethodType r) => RpcMethodType (o -> r) where-  toRpcMethod f = \(x:xs) -> toRpcMethod (f $! fromObject' x) xs--fromObject' :: OBJECT o => Object -> o-fromObject' o =-  case tryFromObject o of-    Left err -> error $ "argument type error: " ++ err-    Right r -> r---- | Create a RPC method from a Haskell function.-fun :: RpcMethodType f => f -> RpcMethod-fun = toRpcMethod---- | Start RPC server with a set of RPC methods.-serve :: Int -- ^ Port number-         -> [(String, RpcMethod)] -- ^ list of (method name, RPC method)-         -> IO ()-serve port methods = withSocketsDo $ do-  sock <- listenOn (PortNumber $ fromIntegral port)-  forever $ do-    (h, host, hostport) <- accept sock-    forkIO $-      (processRequests h `finally` hClose h) `catches`-      [ Handler $ \e ->-         case e of-           CA.ParseError ["demandInput"] _ -> return ()-           _ -> hPutStrLn stderr $ host ++ ":" ++ show hostport ++ ": " ++ show e-      , Handler $ \e ->-         hPutStrLn stderr $ host ++ ":" ++ show hostport ++ ": " ++ show (e :: SomeException)]--  where-    processRequests h =-      C.runResourceT $ CB.sourceHandle h C.$$ forever $ processRequest h-    -    processRequest h = do-      (rtype, msgid, method, args) <- CA.sinkParser get-      liftIO $ do-        resp <- try $ getResponse rtype method args-        case resp of-          Left err ->-            BL.hPutStr h $ pack (1 :: Int, msgid :: Int, show (err :: SomeException), ())-          Right ret ->-            BL.hPutStr h $ pack (1 :: Int, msgid :: Int, (), ret)-        hFlush h--    getResponse rtype method args = do-      when (rtype /= (0 :: Int)) $-        fail "request type is not 0"-      -      r <- callMethod (method :: String) (args :: [Object])-      r `deepseq` return r-    -    callMethod methodName args =-      case lookup methodName methods of-        Nothing ->-          fail $ "method '" ++ methodName ++ "' not found"-        Just method ->-          method args+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-------------------------------------------------------------------
+-- |
+-- Module    : Network.MessagePackRpc.Server
+-- Copyright : (c) Hideyuki Tanaka, 2010-2012
+-- License   : BSD3
+--
+-- Maintainer:  tanaka.hideyuki@gmail.com
+-- Stability :  experimental
+-- Portability: portable
+--
+-- This module is server library of MessagePack-RPC.
+-- The specification of MessagePack-RPC is at
+-- <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>.
+--
+-- A simple example:
+--
+-- > import Network.MessagePackRpc.Server
+-- >
+-- > add :: Int -> Int -> Method Int
+-- > add x y = return $ x + y
+-- >
+-- > main = serve 1234 [("add", toMethod add)]
+--
+--------------------------------------------------------------------
+
+module Network.MessagePackRpc.Server (
+  -- * RPC method types
+  RpcMethod, MethodType(..),
+  MethodT(..), Method,
+  -- * Start RPC server
+  serve,
+  ) where
+
+import Control.Applicative
+import Control.Exception as E
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Trans.Control
+import Data.Conduit
+import Data.Conduit.Network
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.Attoparsec as CA
+import Data.Data
+import Data.MessagePack
+
+type RpcMethod m = [Object] -> m Object
+
+type Request  = (Int, Int, String, [Object])
+type Response = (Int, Int, Object, Object)
+
+data ServerError = ServerError String
+  deriving (Show, Typeable)
+
+instance Exception ServerError
+
+type Method = MethodT IO
+
+newtype MethodT m a = MethodT { unMethodT :: m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadTrans MethodT where
+  lift = MethodT
+
+class MethodType f m | f -> m where
+  -- | Create a RPC method from a Hakell function
+  toMethod :: f -> RpcMethod m
+
+instance (MonadThrow m, MonadBaseControl IO m, OBJECT o)
+         => MethodType (MethodT m o) m where
+  toMethod m ls = case ls of
+    [] -> toObject <$> unMethodT m
+    _ -> monadThrow $ ServerError "argument error"
+
+instance (OBJECT o, MethodType r m) => MethodType (o -> r) m where
+  toMethod f = \(x:xs) -> toMethod (f $! fromObject' x) xs
+
+fromObject' :: OBJECT o => Object -> o
+fromObject' o =
+  case tryFromObject o of
+    Left err -> error $ "argument type error: " ++ err
+    Right r -> r
+
+-- | Start RPC server with a set of RPC methods.
+serve :: forall m . (MonadIO m, MonadThrow m, MonadBaseControl IO m)
+         => Int                     -- ^ Port number
+         -> [(String, RpcMethod m)] -- ^ list of (method name, RPC method)
+         -> m ()
+serve port methods = runTCPServer (ServerSettings port "*") $ \src sink -> do
+  (rsrc, _) <- src $$+ return ()
+  processRequests rsrc sink
+  where
+    processRequests rsrc sink = do
+      (rsrc', res) <- rsrc $$++ do
+        req <- CA.sinkParser get
+        lift $ getResponse req
+      _ <- CB.sourceLbs (pack res) $$ sink
+      processRequests rsrc' sink
+
+    getResponse :: Request -> m Response
+    getResponse (rtype, msgid, methodName, args) = do
+      when (rtype /= 0) $
+        monadThrow $ ServerError $ "request type is not 0, got " ++ show rtype
+      ret <- callMethod methodName args
+      return (1, msgid, toObject (), ret)
+
+    callMethod :: String -> [Object] -> m Object
+    callMethod methodName args =
+      case lookup methodName methods of
+        Nothing ->
+          monadThrow $ ServerError $ "method '" ++ methodName ++ "' not found"
+        Just method ->
+          method args

@@ -1,38 +1,46 @@-Name:                msgpack-rpc-Version:             0.7.1.2-Synopsis:            A MessagePack-RPC Implementation-Description:         A MessagePack-RPC Implementation <http://msgpack.org/>-Homepage:            http://msgpack.org/-License:             BSD3-License-file:        LICENSE-Author:              Hideyuki Tanaka-Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Copyright:           Copyright (c) 2010-2012, Hideyuki Tanaka-Category:            Network-Stability:	     Experimental-Cabal-version:       >=1.8-Build-type:          Simple--Extra-source-files:  test/Serv.hs-                     test/Cli.hs--Library-  Build-depends:     base         == 4.*-                   , bytestring   == 0.9.*-                   , text         == 0.11.*-                   , network      >= 2.2 && < 2.4-                   , random       == 1.0.*-                   , mtl          >= 2.0-                   , conduit      >= 0.2 && < 0.5-                   , attoparsec-conduit-                   , deepseq      >= 1.1 && < 1.4-                   , msgpack      == 0.7.*--  Ghc-options:       -Wall--  Exposed-modules:   Network.MessagePackRpc.Server-                     Network.MessagePackRpc.Client--Source-repository head-  Type:              git-  Location:          git://github.com/msgpack/msgpack-haskell.git+name:                msgpack-rpc
+version:             0.8.0
+synopsis:            A MessagePack-RPC Implementation
+description:         A MessagePack-RPC Implementation <http://msgpack.org/>
+homepage:            http://msgpack.org/
+license:             BSD3
+license-file:        LICENSE
+author:              Hideyuki Tanaka
+maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
+copyright:           (c) 2010-2012, Hideyuki Tanaka
+category:            Network
+stability:	     Experimental
+cabal-version:       >=1.8
+build-type:          Simple
+
+source-repository head
+  type:              git
+  location:          git://github.com/msgpack/msgpack-haskell.git
+
+library
+  build-depends:     base               == 4.*
+                   , bytestring         == 0.9.*
+                   , text               == 0.11.*
+                   , network            >= 2.2 && < 2.4
+                   , random             == 1.0.*
+                   , mtl                >= 2.0
+                   , monad-control      >= 0.3
+                   , conduit            >= 0.5
+                   , network-conduit    >= 0.5
+                   , attoparsec-conduit >= 0.5
+                   , msgpack            == 0.7.*
+
+  exposed-modules:   Network.MessagePackRpc.Server
+                     Network.MessagePackRpc.Client
+
+test-suite msgpack-rpc-test
+  type:              exitcode-stdio-1.0
+  hs-source-dirs:    dist
+  main-is:           ../test.hs
+
+  build-depends:     base
+                   , mtl
+                   , network
+                   , async >= 2.0
+                   , hspec >= 1.3
+                   , msgpack-rpc

@@ -0,0 +1,44 @@+import Control.Applicative+import Control.Concurrent.Async+import Control.Monad.Trans++import Test.Hspec++import Network (withSocketsDo)+import Network.MessagePackRpc.Server+import Network.MessagePackRpc.Client++port :: Int+port = 5000++main :: IO ()+main = withSocketsDo $ hspec $ do+  describe "add service" $ do+    it "correct" $ do+      server `race_` client++server :: IO ()+server =+  serve port+    [ ("add", toMethod add)+    , ("echo", toMethod echo)+    ]+  where+    add :: Int -> Int -> Method Int+    add x y = return $ x + y++    echo :: String -> Method String+    echo s = return $ "***" ++ s ++ "***"++client :: IO ()+client = runClient "localhost" port $ do+  r1 <- add 123 456+  liftIO $ r1 `shouldBe` 123 + 456+  r2 <- echo "hello"+  liftIO $ r2 `shouldBe` "***hello***"+  where+    add :: Int -> Int -> Client Int+    add = call "add"++    echo :: String -> Client String+    echo = call "echo"

@@ -1,13 +0,0 @@-import Network.MessagePackRpc.Client--add :: RpcMethod (Int -> Int -> IO Int)-add  = method "add"--echo :: RpcMethod (String -> IO String)-echo = method "echo"--main :: IO ()-main = do-  conn <- connect "localhost" 8081-  print =<< add conn 123 456-  print =<< echo conn "hoge"

@@ -1,11 +0,0 @@-import Network.MessagePackRpc.Server--add :: Int -> Int -> IO Int-add x y = return $ x+y--echo :: String -> IO String-echo s = return s--main :: IO ()-main = do-  serve 8081 [ ("add", fun add), ("echo", fun echo) ]