diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/network-msgpack-rpc.cabal b/network-msgpack-rpc.cabal new file mode 100644 --- /dev/null +++ b/network-msgpack-rpc.cabal @@ -0,0 +1,51 @@ +name: network-msgpack-rpc +version: 0.0.1 +synopsis: A MessagePack-RPC Implementation +description: A MessagePack-RPC Implementation +homepage: http://msgpack.org/ +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Iphigenia Df +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 diff --git a/src/Network/MessagePack/Client.hs b/src/Network/MessagePack/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/MessagePack/Client.hs @@ -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 +-- Stability : experimental +-- Portability: portable +-- +-- This module is client library of MessagePack-RPC. +-- The specification of MessagePack-RPC is at +-- . +-- +-- 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 [] diff --git a/src/Network/MessagePack/Server.hs b/src/Network/MessagePack/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/MessagePack/Server.hs @@ -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 +-- . +-- +-- 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 diff --git a/test/testsuite.hs b/test/testsuite.hs new file mode 100644 --- /dev/null +++ b/test/testsuite.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}