network-msgpack-rpc (empty) → 0.0.1
raw patch · 6 files changed
+361/−0 lines, 6 filesdep +asyncdep +basedep +binarysetup-changed
Dependencies added: async, base, binary, binary-conduit, bytestring, conduit, conduit-extra, data-msgpack, exceptions, hspec, monad-control, mtl, network, network-msgpack-rpc
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- network-msgpack-rpc.cabal +51/−0
- src/Network/MessagePack/Client.hs +130/−0
- src/Network/MessagePack/Server.hs +147/−0
- test/testsuite.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Hideyuki Tanaka++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Hideyuki Tanaka nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ network-msgpack-rpc.cabal view
@@ -0,0 +1,51 @@+name: network-msgpack-rpc+version: 0.0.1+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: Iphigenia Df <iphydf@gmail.com>+copyright: Copyright (c) 2009-2016, Hideyuki Tanaka+category: Data+stability: Experimental+cabal-version: >= 1.10+build-type: Simple++source-repository head+ type: git+ location: https://github.com/TokTok/msgpack-haskell.git++library+ default-language: Haskell2010+ hs-source-dirs:+ src+ exposed-modules:+ Network.MessagePack.Client+ Network.MessagePack.Server+ build-depends:+ base < 5+ , binary+ , binary-conduit+ , bytestring+ , conduit+ , conduit-extra+ , data-msgpack+ , exceptions+ , monad-control+ , mtl+ , network++test-suite testsuite+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: testsuite.hs+ build-depends:+ base < 5+ , async+ , hspec+ , mtl+ , network+ , network-msgpack-rpc
+ src/Network/MessagePack/Client.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Trustworthy #-}++-------------------------------------------------------------------+-- |+-- Module : Network.MessagePackRpc.Client+-- Copyright : (c) Hideyuki Tanaka, 2010-2015+-- 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 = execClient "localhost" 5000 $ do+-- > ret <- add 123 456+-- > liftIO $ print ret+--+--------------------------------------------------------------------++module Network.MessagePack.Client+ -- * MessagePack Client type+ ( Client+ , execClient++ -- * Call RPC method+ , call++ -- * RPC error+ , RpcError (..)+ ) 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)++newtype Client a+ = ClientT { runClient :: StateT Connection IO a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow)++-- | 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)++-- | 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++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 []
+ src/Network/MessagePack/Server.hs view
@@ -0,0 +1,147 @@+{-# 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+-- <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>.+--+-- 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+ -- * RPC method types+ ( Method+ , MethodType (..)+ , ServerT (..)+ , Server++ -- * Build a method+ , method++ -- * Start RPC server+ , serve+ ) 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)++-- ^ MessagePack RPC method+data Method m+ = Method+ { methodName :: String+ , methodBody :: [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++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
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}