packages feed

msgpack-rpc 0.6.1.2 → 0.7.0

raw patch · 6 files changed

+283/−301 lines, 6 filesdep +attoparsec-conduitdep +conduitdep +textdep −attoparsec-enumeratordep −enumeratordep ~deepseqdep ~msgpack

Dependencies added: attoparsec-conduit, conduit, text

Dependencies removed: attoparsec-enumerator, enumerator

Dependency ranges changed: deepseq, msgpack

Files

+ Network/MessagePackRpc/Client.hs view
@@ -0,0 +1,139 @@+{-# 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
+ Network/MessagePackRpc/Server.hs view
@@ -0,0 +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
msgpack-rpc.cabal view
@@ -1,42 +1,38 @@ Name:                msgpack-rpc-Version:             0.6.1.2+Version:             0.7.0 Synopsis:            A MessagePack-RPC Implementation-Description:-  A MessagePack-RPC Implementation <http://msgpack.org/>-+Description:         A MessagePack-RPC Implementation <http://msgpack.org/>+Homepage:            http://msgpack.org/ License:             BSD3 License-file:        LICENSE-Copyright:           Copyright (c) 2010, Hideyuki Tanaka-Category:            Network Author:              Hideyuki Tanaka Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>-Homepage:            http://github.com/msgpack/msgpack-rpc-Stability:	      Experimental-Cabal-version:       >=1.6+Copyright:           Copyright (c) 2010-2011, Hideyuki Tanaka+Category:            Network+Stability:	     Experimental+Cabal-version:       >=1.8 Build-type:          Simple -Extra-source-files:-  test/Serv.hs-  test/Cli.hs+Extra-source-files:  test/Serv.hs+                     test/Cli.hs  Library-  Build-depends:     base >= 4 && < 5,-                     bytestring >= 0.9 && < 0.10,-                     network >= 2.2 && < 2.4,-                     random >= 1.0 && < 1.1,-                     enumerator >= 0.4 && < 0.5,-                     attoparsec-enumerator >= 0.2 && < 0.3,-                     msgpack >= 0.6 && < 0.7,-                     mtl >= 2.0 && < 2.1,-                     deepseq >= 1.1 && < 1.3+  Build-depends:     base         == 4.*+                   , bytestring   == 0.9.*+                   , text         == 0.11.*+                   , network      >= 2.2 && < 2.4+                   , random       == 1.0.*+                   , mtl          == 2.0.*+                   , conduit      == 0.2.*+                   , attoparsec-conduit == 0.2.*+                   , deepseq      >= 1.1 && < 1.4+                   , msgpack      == 0.7.*    Ghc-options:       -Wall-  Hs-source-dirs:    src -  Exposed-modules:-    Network.MessagePackRpc.Server-    Network.MessagePackRpc.Client+  Exposed-modules:   Network.MessagePackRpc.Server+                     Network.MessagePackRpc.Client  Source-repository head-  Type:     git-  Location: git://github.com/msgpack/msgpack-rpc.git+  Type:              git+  Location:          git://github.com/msgpack/msgpack-haskell.git
− src/Network/MessagePackRpc/Client.hs 
@@ -1,144 +0,0 @@-{-# 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 Data.Attoparsec.Enumerator-import qualified Data.ByteString.Lazy as BL-import Data.Enumerator-import Data.Enumerator.Binary-import Data.Functor-import Data.MessagePack-import Data.Typeable-import Network-import System.IO-import System.Random--bufferSize :: Integer-bufferSize = 4096---- | 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-  run_ $ enumHandle bufferSize h $$ do-    (rtype, rmsgid, rerror, rresult) <- iterParser 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
− src/Network/MessagePackRpc/Server.hs 
@@ -1,123 +0,0 @@----------------------------------------------------------------------- |--- 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 Data.Enumerator-import Data.Enumerator.Binary-import Control.Monad-import Control.Monad.Trans-import Data.Attoparsec.Enumerator-import qualified Data.ByteString.Lazy as BL-import Data.Maybe-import Data.MessagePack-import Network-import System.IO--import Prelude hiding (catch)--bufferSize :: Integer-bufferSize = 4096--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-           ParseError ["demandInput"] _ -> return ()-           _ -> hPutStrLn stderr $ host ++ ":" ++ show hostport ++ ": " ++ show e-      , Handler $ \e ->-         hPutStrLn stderr $ host ++ ":" ++ show hostport ++ ": " ++ show (e :: SomeException)]--  where-    processRequests h =-      run_ $ enumHandle bufferSize h $$ forever $ processRequest h-    -    processRequest h = do-      (rtype, msgid, method, args) <- iterParser 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
test/Cli.hs view
@@ -1,8 +1,5 @@ import Network.MessagePackRpc.Client -import Control.Concurrent-import Control.Monad- add :: RpcMethod (Int -> Int -> IO Int) add  = method "add" @@ -11,7 +8,6 @@  main :: IO () main = do-  conn <- connect "127.0.0.1" 8081-  forM_ [0..10000] $ \i -> do-    print =<< add conn i (i*2)-    print =<< add conn (i*2) (i*3)+  conn <- connect "localhost" 8081+  print =<< add conn 123 456+  print =<< echo conn "hoge"