packages feed

msgpack-rpc-conduit (empty) → 0.0.6

raw patch · 20 files changed

+1227/−0 lines, 20 filesdep +asyncdep +basedep +binarysetup-changed

Dependencies added: async, base, binary, binary-conduit, bytestring, conduit, conduit-extra, data-default-class, data-default-instances-base, exceptions, hspec, monad-control, msgpack-binary, msgpack-rpc-conduit, msgpack-types, mtl, network, text, unliftio-core

Files

+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2017-2018, The TokTok Team+Copyright (c) 2009-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 the Hideyuki Tanaka nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''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 <copyright holder> 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.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ msgpack-rpc-conduit.cabal view
@@ -0,0 +1,83 @@+name:                 msgpack-rpc-conduit+version:              0.0.6+synopsis:             A MessagePack-RPC Implementation+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+description:+  A MessagePack-RPC Implementation <http://msgpack.org/>+  .+  This is a fork of msgpack-haskell <https://github.com/msgpack/msgpack-haskell>,+  since the original author is unreachable. This fork incorporates a number of+  bugfixes and is actively being developed.++source-repository head+  type:             git+  location:         https://github.com/TokTok/hs-msgpack-rpc-conduit.git++library+  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+      Network.MessagePack.Types+  other-modules:+      Network.MessagePack.Capabilities+      Network.MessagePack.Client.Basic+      Network.MessagePack.Client.Internal+      Network.MessagePack.Protocol+      Network.MessagePack.Server.Basic+      Network.MessagePack.Types.Client+      Network.MessagePack.Types.Error+      Network.MessagePack.Types.Result+      Network.MessagePack.Types.Server+      Network.MessagePack.Types.Spec+  build-depends:+      base < 5+    , binary+    , binary-conduit+    , bytestring+    , conduit+    , conduit-extra+    , data-default-class+    , data-default-instances-base+    , exceptions+    , monad-control+    , msgpack-binary                    >= 0.0.11+    , msgpack-types                     >= 0.0.1+    , mtl+    , network                           < 3+    , text+    , unliftio-core++test-suite testsuite+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  ghc-options:+      -Wall+  hs-source-dirs: test+  main-is: testsuite.hs+  other-modules:+      Network.MessagePack.ServerSpec+  build-depends:+      base < 5+    , async+    , bytestring+    , hspec+    , msgpack-rpc-conduit+    , mtl+    , network                           < 3
+ src/Network/MessagePack/Capabilities.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}+module Network.MessagePack.Capabilities+    ( ServerCapability (..)+    , ClientCapability (..)+    ) where++import           Data.MessagePack (MessagePack)+import           GHC.Generics     (Generic)+++data ServerCapability+    = SCapMethodList+      -- ^ Server supports method lists and can handle more efficient method codes+      -- instead of strings for names. It supports the "internal.methodList" call+      -- to return an ordered list of method names. The client can send an index+      -- in this list instead of the name itself when performing an RPC call.+    deriving (Eq, Generic)++instance MessagePack ServerCapability+++data ClientCapability+    = CCapMethodList+      -- ^ Client supports method lists and can send more efficient method codes+      -- instead of strings for names.+    deriving (Eq, Generic)++instance MessagePack ClientCapability
+ src/Network/MessagePack/Client.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy         #-}+module Network.MessagePack.Client (+  -- * MessagePack Client type+    Basic.Client+  , Basic.ClientT+  , Basic.execClient+  , runClient++  -- * Call RPC method+  , Basic.call++  -- * RPC error+  , Basic.RpcError (..)+  , Basic.RpcType+  ) where++import           Control.Applicative                 (Applicative, pure)+import           Control.Monad                       (when)+import           Control.Monad.Catch                 (catch)+import qualified Data.ByteString                     as S+import           Data.Default.Class                  (Default (..))+import           Data.Default.Instances.Base         ()++import           Network.MessagePack.Capabilities    (ClientCapability (..),+                                                      ServerCapability (..))+import qualified Network.MessagePack.Client.Basic    as Basic+import qualified Network.MessagePack.Client.Internal as Internal+import qualified Network.MessagePack.Protocol        as Protocol+++useDefault :: (Applicative m, Default a) => Basic.RpcError -> m a+useDefault _ = pure def+++initClient :: Basic.Client ()+initClient = do+  caps <- Protocol.capabilitiesC [CCapMethodList] `catch` useDefault+  when (SCapMethodList `elem` caps) $ do+    mths <- Protocol.methodListC+    Internal.setMethodList mths+++runClient :: S.ByteString -> Int -> Basic.Client a -> IO a+runClient host port client =+  Basic.execClient host port (initClient >> client)
+ src/Network/MessagePack/Client/Basic.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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.Basic (+  -- * MessagePack Client type+    Client+  , ClientT+  , execClient++  -- * Call RPC method+  , call++  -- * RPC error+  , RpcError (..)+  , RpcType (..)+  ) where++import qualified Control.Monad.State.Strict          as CMS+import qualified Data.ByteString                     as S+import           Data.Conduit                        (($$+))+import           Data.Conduit.Network                (appSink, appSource,+                                                      clientSettings,+                                                      runTCPClient)++import           Network.MessagePack.Client.Internal+import           Network.MessagePack.Types.Client+import           Network.MessagePack.Types.Error+++execClient :: S.ByteString -> Int -> Client a -> IO a+execClient host port client =+  runTCPClient (clientSettings port host) $ \ad -> do+    (rsrc, _) <- appSource ad $$+ return ()+    CMS.evalStateT (runClientT client) Connection+      { connSource = rsrc+      , connSink   = appSink ad+      , connMsgId  = 0+      , connMths   = []+      }
+ src/Network/MessagePack/Client/Internal.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.MessagePack.Client.Internal where++import           Control.Applicative               (Applicative)+import           Control.Monad                     (when)+import           Control.Monad.Catch               (MonadCatch, MonadThrow,+                                                    throwM)+import qualified Control.Monad.State.Strict        as CMS+import qualified Data.Binary                       as Binary+import qualified Data.ByteString                   as S+import           Data.Conduit                      (ConduitT, SealedConduitT,+                                                    Void, runConduit, ($$++),+                                                    (.|))+import qualified Data.Conduit.Binary               as CB+import           Data.Conduit.Serialization.Binary (sinkGet)+import           Data.MessagePack                  (MessagePack (fromObject),+                                                    Object)+import           Data.Monoid                       ((<>))+import           Data.Text                         (Text)+import qualified Data.Text                         as T+import qualified Network.MessagePack.Types.Result  as R++import           Network.MessagePack.Interface     (IsClientType (..), Returns,+                                                    ReturnsM)+import           Network.MessagePack.Types.Client+import           Network.MessagePack.Types.Error+import           Network.MessagePack.Types.Spec+++-- | RPC connection type+data Connection m = Connection+  { connSource :: !(SealedConduitT () S.ByteString m ())+  , connSink   :: !(ConduitT S.ByteString Void m ())+  , connMsgId  :: !Int+  , connMths   :: ![Text]+  }+++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++instance IsClientType m (Returns r) where+  type ClientType m (Returns r) = ClientT m r++instance IsClientType m (ReturnsM io r) where+  type ClientType m (ReturnsM io r) = ClientT m r+++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+      R.Success ok  ->+        return ok+      R.Failure msg ->+        throwM $ ResultTypeError (T.pack msg) res+++rpcCall :: (MonadThrow m, CMS.MonadIO m) => Text -> [Object] -> ClientT m Object+rpcCall methodName args = ClientT $ do+  conn <- CMS.get+  let msgid = connMsgId conn++  (rsrc', res) <- CMS.lift $ do+    let req = packRequest (connMths conn) (0, msgid, methodName, args)+    runConduit $ CB.sourceLbs req .| connSink conn+    connSource conn $$++ sinkGet Binary.get++  CMS.put conn+    { connSource = rsrc'+    , connMsgId  = msgid + 1+    }++  case unpackResponse res of+    Nothing -> throwM $ ProtocolError "invalid response data"+    Just (rtype, rmsgid, rerror, rresult) -> do+      when (rtype /= 1) $+        throwM $ ProtocolError $+          "invalid response type (expect 1, but got " <> T.pack (show rtype) <> "): " <> T.pack (show res)++      when (rmsgid /= msgid) $+        throwM $ ProtocolError $+          "message id mismatch: expect " <> T.pack (show msgid) <> ", but got " <> T.pack (show rmsgid)++      case fromObject rerror of+        Nothing -> throwM $ RemoteError rerror+        Just () -> return rresult+++setMethodList :: Monad m => [Text] -> ClientT m ()+setMethodList mths = ClientT $ do+  conn <- CMS.get+  CMS.put conn { connMths = mths }
+ src/Network/MessagePack/Interface.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE Safe                  #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+module Network.MessagePack.Interface+    ( Interface (..)+    , InterfaceM (..)+    , IsDocType (..)+    , IsClientType (..)+    , IsReturnType (..)+    , Doc (..)+    , Returns+    , ReturnsM+    , call+    , concrete+    , interface+    , method+    ) where++import           Control.Monad.Catch              (MonadThrow)+import           Control.Monad.Trans              (MonadIO)+import           Data.Text                        (Text)+import qualified Data.Text                        as Text+import           Data.Typeable                    (Typeable)+import qualified Data.Typeable                    as Typeable++import qualified Network.MessagePack.Types.Client as Client+import           Network.MessagePack.Types.Server (Method, MethodDocs (..),+                                                   MethodVal (..))+import qualified Network.MessagePack.Types.Server as Server+++data Interface f = Interface+  { name :: !Text+  , docs :: !(Doc f)+  }+++newtype InterfaceM (m :: * -> *) f = InterfaceM+  { nameM :: Text+  }+++interface :: Text -> Doc f -> Interface f+interface = Interface+++concrete :: Interface f -> InterfaceM m f+concrete = InterfaceM . name+++--------------------------------------------------------------------------------+--+-- :: Documentation+--+--------------------------------------------------------------------------------+++class IsDocType f where+  data Doc f+  flatDoc :: Doc f -> MethodDocs++data Returns r++instance Typeable r => IsDocType (Returns r) where+  data Doc (Returns r) = Ret Text+    deriving (Eq, Read, Show)+  flatDoc (Ret retName) =+    MethodDocs [] (MethodVal retName (typeName (undefined :: r)))++data ReturnsM (m :: * -> *) r++instance Typeable r => IsDocType (ReturnsM m r) where+  data Doc (ReturnsM m r) = RetM Text+    deriving (Eq, Read, Show)+  flatDoc (RetM retName) =+    MethodDocs [] (MethodVal retName (typeName (undefined :: r)))++instance (Typeable o, IsDocType r) => IsDocType (o -> r) where+  data Doc (o -> r) = Arg Text (Doc r)+  flatDoc (Arg o r) =+    let doc = flatDoc r in+    let ty = typeName (undefined :: o) in+    doc { methodArgs = MethodVal o ty : 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))+++typeName :: Typeable a => a -> Text+typeName = Text.replace "[Char]" "String" . Text.pack . show . Typeable.typeOf+++--------------------------------------------------------------------------------+--+-- :: Client+--+--------------------------------------------------------------------------------+++class IsClientType (m :: * -> *) f where+  type ClientType m f++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+++--------------------------------------------------------------------------------+--+-- :: Server+--+--------------------------------------------------------------------------------+++class IsReturnType (m :: * -> *) f where+  type HaskellType f+  type ServerType m f++  implement :: InterfaceM m f -> HaskellType f -> ServerType m f+++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++      coerce :: InterfaceM m a -> InterfaceM m b+      coerce = InterfaceM . nameM+++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)
+ src/Network/MessagePack/Protocol.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Network.MessagePack.Protocol+  ( capabilitiesN+  , capabilitiesC+  , capabilitiesS+  , methodListN+  , methodListC+  , methodListS+  , protocolMethods+  ) where++import           Control.Applicative              (Applicative, pure)+import           Control.Monad.Catch              (MonadCatch)+import           Control.Monad.Trans              (MonadIO)+import           Control.Monad.Trans.Control      (MonadBaseControl)+import           Data.Text                        (Text)++import           Network.MessagePack.Capabilities+import           Network.MessagePack.Client.Basic+import           Network.MessagePack.Server.Basic+++capabilitiesN :: Text+capabilitiesN = "rpc.capabilities"++capabilitiesC :: [ClientCapability] -> Client [ServerCapability]+capabilitiesC = call capabilitiesN++capabilitiesS+  :: Applicative m+  => [Method m]+  -> [ClientCapability]+  -> ServerT m [ServerCapability]+capabilitiesS _ _ = pure [SCapMethodList]+++methodListN :: Text+methodListN = "rpc.methodList"++methodListC :: Client [Text]+methodListC = call methodListN++methodListS+  :: Applicative m+  => [Method m]+  -> ServerT m [Text]+methodListS = pure . map methodName+++protocolMethods+  :: (MonadBaseControl IO m, MonadIO m, MonadCatch m)+  => [Method m]+  -> [Method m]+protocolMethods methods = methods +++  [ method capabilitiesN (MethodDocs [MethodVal "clientCaps" "ClientCapability"] (MethodVal "serverCaps" "ServerCapability"))+      (capabilitiesS methods)+  , method methodListN   (MethodDocs [] (MethodVal "names" "[String]"))+      (methodListS   methods)+  ]
+ src/Network/MessagePack/Rpc.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe                  #-}+{-# LANGUAGE TypeFamilies          #-}+module Network.MessagePack.Rpc+  ( I.Doc (..)+  , I.Returns+  , I.ReturnsM+  , method+  , rpc+  , docs+  , stubs, Rpc, RpcT (local)+  ) where++import           Control.Monad.Catch              (MonadThrow)+import           Data.Text                        (Text)++import qualified Network.MessagePack.Interface    as I+import qualified Network.MessagePack.Types.Client as Client+import qualified Network.MessagePack.Types.Server as Server++-- Import orphan instances for RpcType and IsReturnType.+-- TODO(SX91): Avoid orphan instances. See issue #7.+import           Network.MessagePack.Client.Basic ()+import           Network.MessagePack.Server.Basic ()+++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 -> (Text, I.Doc (F rpc))+++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+  {-# INLINE rpc #-}+  method = methodPure+  {-# INLINE method #-}+  docs r = (Server.methodName $ method r, I.docs $ intfPure r)+  {-# INLINE docs #-}+++stubs+  :: ( Client.RpcType (I.ClientType mc f)+     , Server.MethodType ms (I.ServerType ms f)+     , I.IsReturnType ms f+     , I.IsDocType f+     , MonadThrow ms+     )+  => Text -> 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
+ src/Network/MessagePack/Server.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.MessagePack.Server (+  -- * RPC method types+    Method+  , MethodType (..)+  , MethodDocs (..)+  , MethodVal (..)+  , ServerT (..)+  , Server++  -- * Build a method+  , method+  , methodName+  , methodDocs++  -- * Start RPC server+  , serve+  , runServer+  ) where++import           Control.Monad.Catch              (MonadCatch)+import           Control.Monad.IO.Unlift          (MonadUnliftIO)+import           Control.Monad.Trans              (MonadIO)+import           Control.Monad.Trans.Control      (MonadBaseControl)++import           Network.MessagePack.Protocol     (protocolMethods)+import           Network.MessagePack.Server.Basic+++-- | Start RPC server with a set of RPC methods.+runServer+  :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadUnliftIO m)+  => Int        -- ^ Port number+  -> [Method m] -- ^ list of methods+  -> m ()+runServer port methods =+  serve port (protocolMethods methods)
+ src/Network/MessagePack/Server/Basic.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE Trustworthy                #-}+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-------------------------------------------------------------------+-- |+-- 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.Basic (+  -- * RPC method types+    Method+  , MethodVal (..)+  , MethodDocs (..)+  , MethodType (..)+  , ServerT (..)+  , Server++  -- * Build a method+  , method++  -- * Get the method name+  , methodName+  , methodDocs++  -- * Start RPC server+  , serve+  ) where++import           Control.Applicative               (Applicative, pure, (<$>),+                                                    (<|>))+import           Control.Monad.Catch               (MonadCatch, MonadThrow,+                                                    catch, throwM)+import           Control.Monad.IO.Unlift           (MonadUnliftIO)+import           Control.Monad.Trans               (MonadIO, MonadTrans, lift,+                                                    liftIO)+import           Control.Monad.Trans.Control       (MonadBaseControl)+import qualified Data.Binary                       as Binary+import qualified Data.ByteString                   as S+import           Data.Conduit                      (ConduitT, SealedConduitT,+                                                    Void, runConduit, ($$+),+                                                    ($$++), (.|))+import qualified Data.Conduit.Binary               as CB+import           Data.Conduit.Network              (appSink, appSource,+                                                    runGeneralTCPServer,+                                                    serverSettings,+                                                    setAfterBind)+import           Data.Conduit.Serialization.Binary (ParseError, sinkGet)+import qualified Data.List                         as List+import           Data.MessagePack                  (MessagePack, Object,+                                                    fromObject, toObject)+import           Data.Monoid                       ((<>))+import qualified Data.Text                         as T+import           Data.Traversable                  (sequenceA)+import qualified Network.MessagePack.Types.Result  as R+import           Network.Socket                    (SocketOption (ReuseAddr),+                                                    setSocketOption)++import           Network.MessagePack.Interface     (IsReturnType (..), Returns,+                                                    ReturnsM)+import           Network.MessagePack.Types+++newtype ServerT m a = ServerT { runServerT :: m a }+  deriving (Functor, Applicative, Monad, MonadIO)+++instance MonadTrans ServerT where+  lift = ServerT+  {-# INLINE lift #-}+++type Server = ServerT IO+++instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where+  toBody n f (x : xs) =+    case fromObject x of+      Nothing -> throwM $ ServerError "argument type error"+      Just r  -> toBody n (f r) xs+  toBody _ _ [] = error "messagepack-rpc methodtype instance toBody failed"++instance (Functor m, MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where+  toBody _ m [] = toObject <$> runServerT m+  toBody n _ ls =+    throwM $ ServerError $+      "invalid arguments for method '" <> n <> "': " <> T.pack (show ls)++-- Pure server+instance Monad m => IsReturnType m (Returns r) where+  type HaskellType (Returns r) = r+  type ServerType m (Returns r) = ServerT m r++  implement _ = return++-- IO Server+instance MonadIO m => IsReturnType m (ReturnsM IO r) where+  type HaskellType (ReturnsM IO r) = IO r+  type ServerType m (ReturnsM IO r) = ServerT m r++  implement _ = liftIO+++processRequests+  :: (Applicative m, MonadThrow m, MonadCatch m)+  => [Method m]+  -> SealedConduitT () S.ByteString m ()+  -> ConduitT S.ByteString Void m t+  -> m b+processRequests methods rsrc sink = do+  (rsrc', res) <-+    rsrc $$++ do+      obj <- sinkGet Binary.get+      case unpackRequest obj of+        Nothing ->+          throwM $ ServerError "invalid request"+        Just req@(_, msgid, _, _) ->+          lift $ getResponse methods req `catch` \(ServerError err) ->+            return (1, msgid, toObject err, toObject ())++  _ <- runConduit $ CB.sourceLbs (packResponse res) .| sink+  processRequests methods rsrc' sink+++getResponse+  :: Applicative m+  => [Method m]+  -> Request Object+  -> m Response+getResponse methods (0, msgid, mth, args) =+  process <$> callMethod methods mth args+  where+    process (R.Failure err) = (1, msgid, toObject err, toObject ())+    process (R.Success ok ) = (1, msgid, toObject (), ok)++getResponse _ (rtype, msgid, _, _) =+  pure (1, msgid, toObject ["request type is not 0, got " <> T.pack (show rtype)], toObject ())+++callMethod+  :: (Applicative m)+  => [Method m]+  -> Object+  -> [Object]+  -> m (R.Result Object)+callMethod methods mth args = sequenceA $+  (stringCall =<< fromObject mth)+  <|>+  (intCall =<< fromObject mth)++  where+    stringCall name =+      case List.find ((== name) . methodName) methods of+        Nothing -> R.Failure $ "method '" <> T.unpack name <> "' not found"+        Just m  -> R.Success $ methodBody m args++    intCall ix =+      case drop ix methods of+        []  -> R.Failure $ "method #" <> show ix <> " not found"+        m:_ -> R.Success $ methodBody m args+++ignoreParseError :: Applicative m => ParseError -> m ()+ignoreParseError _ = pure ()+++-- | Start RPC server with a set of RPC methods.+serve+  :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadUnliftIO m)+  => Int        -- ^ Port number+  -> [Method m] -- ^ list of methods+  -> m ()+serve port methods =+  runGeneralTCPServer settings $ \ad -> do+    (rsrc, _) <- appSource ad $$+ return ()+    processRequests methods rsrc (appSink ad) `catch` ignoreParseError++  where+    settings =+      setAfterBind+        (\s -> setSocketOption s ReuseAddr 1)+        (serverSettings port "*")
+ src/Network/MessagePack/Types.hs view
@@ -0,0 +1,8 @@+module Network.MessagePack.Types+  ( module X+  ) where++import           Network.MessagePack.Types.Client as X+import           Network.MessagePack.Types.Error  as X+import           Network.MessagePack.Types.Server as X+import           Network.MessagePack.Types.Spec   as X
+ src/Network/MessagePack/Types/Client.hs view
@@ -0,0 +1,22 @@+module Network.MessagePack.Types.Client+  ( RpcType (..)+  , call+  ) where++import           Data.MessagePack (MessagePack (toObject), Object)+import           Data.Text        (Text)+++class RpcType r where+  rpcc :: Text -> [Object] -> r+++instance (MessagePack o, RpcType r) => RpcType (o -> r) where+  rpcc name args arg = rpcc name (toObject arg : args)+  {-# INLINE rpcc #-}+++-- | Call an RPC Method+call :: RpcType a => Text -> a+call name = rpcc name []+{-# INLINE call #-}
+ src/Network/MessagePack/Types/Error.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Network.MessagePack.Types.Error+  ( RpcError (..)+  , ServerError (..)+  ) where++import           Control.Exception (Exception)+import           Data.MessagePack  (Object)+import           Data.Text         (Text)+import           Data.Typeable     (Typeable)+++-- | RPC error type+data RpcError+  = RemoteError !Object           -- ^ Server error+  | ResultTypeError !Text !Object -- ^ Result type mismatch+  | ProtocolError !Text           -- ^ Protocol error+  deriving (Show, Eq, Ord, Typeable)++instance Exception RpcError+++newtype ServerError = ServerError Text+  deriving (Show, Typeable)++instance Exception ServerError
+ src/Network/MessagePack/Types/Result.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE Safe              #-}+module Network.MessagePack.Types.Result+    ( Result (..)+    ) where++import           Control.Applicative (Alternative (..), Applicative (..), (<$>),+                                      (<*>))+import           Data.Foldable       (Foldable)+import           Data.Traversable    (Traversable)++data Result a+    = Success a+    | Failure String+    deriving (Read, Show, Eq, Functor, Foldable, Traversable)++instance Applicative Result where+    pure = Success++    Success f   <*> x = fmap f x+    Failure msg <*> _ = Failure msg++instance Alternative Result where+    empty = Failure "empty alternative"++    s@Success {} <|> _ = s+    _            <|> r = r++instance Monad Result where+    return = Success+    fail = Failure++    Success x   >>= f = f x+    Failure msg >>= _ = Failure msg++#if (MIN_VERSION_base(4,13,0))+instance MonadFail Result where+    fail = Failure+#endif
+ src/Network/MessagePack/Types/Server.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Safe                  #-}+module Network.MessagePack.Types.Server+  ( MethodVal (..)+  , MethodDocs (..)+  , MethodType (..)+  , Method (..)+  , method+  ) where++import           Control.Monad    (Monad)+import           Data.MessagePack (Object)+import           Data.Text        (Text)+++data MethodVal = MethodVal+  { valName :: !Text+  , valType :: !Text+  }+  deriving (Show, Read, Eq)++data MethodDocs = MethodDocs+  { methodArgs :: ![MethodVal]+  , methodRetv :: !MethodVal+  }+  deriving (Show, Read, Eq)++-- ^ MessagePack RPC method+data Method m = Method+  { methodName :: !Text+  , methodDocs :: !MethodDocs+  , methodBody :: [Object] -> m Object+  }+++class Monad m => MethodType m f where+  -- | Create a RPC method from a Haskell function+  toBody :: Text -> f -> [Object] -> m Object+++-- | Build a method+method+  :: MethodType m f+  => Text     -- ^ Method name+  -> MethodDocs+  -> f        -- ^ Method body+  -> Method m+method name docs body = Method name docs $ toBody name body
+ src/Network/MessagePack/Types/Spec.hs view
@@ -0,0 +1,32 @@+module Network.MessagePack.Types.Spec+  ( Request+  , Response+  , packRequest+  , packResponse+  , unpackRequest+  , unpackResponse+  ) where++import qualified Data.ByteString.Lazy as L+import qualified Data.List            as List+import           Data.MessagePack     (MessagePack, Object, fromObject, pack)++type Request ix = (Int, Int, ix, [Object])+type Response   = (Int, Int, Object, Object)++packRequest :: (Eq mth, MessagePack mth) => [mth] -> Request mth -> L.ByteString+packRequest [] req = pack req+packRequest mths req@(rtype, msgid, mth, obj) =+  case List.elemIndex mth mths of+    Nothing -> pack req+    Just ix -> pack (rtype, msgid, ix, obj)+++packResponse :: Response -> L.ByteString+packResponse = pack++unpackResponse :: Object -> Maybe Response+unpackResponse = fromObject++unpackRequest :: MessagePack ix => Object -> Maybe (Request ix)+unpackRequest = fromObject
+ test/Network/MessagePack/ServerSpec.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.MessagePack.ServerSpec (spec) where++import           Test.Hspec++import           Control.Concurrent            (threadDelay)+import           Control.Concurrent.Async      (race_)+import           Control.Monad.Trans           (liftIO)+import qualified Data.ByteString               as S+import           Network.Socket                (withSocketsDo)++import           Network.MessagePack.Client    (Client)+import qualified Network.MessagePack.Client    as Client+import           Network.MessagePack.Interface (Doc (..), Interface, Returns,+                                                ReturnsM, call, concrete,+                                                interface, method)+import qualified Network.MessagePack.Rpc       as Rpc+import           Network.MessagePack.Server    (MethodDocs (..), MethodVal (..))+import qualified Network.MessagePack.Server    as Server+++add :: Int -> Int -> Int+add = (+)++addI :: Interface (Int -> Int -> Returns Int)+addC :: Int -> Int -> Client Int+(addI, addC) = (interface "add" (Arg "a" $ Arg "b" $ Ret "sum"), call . concrete $ addI)++addR :: Rpc.Rpc (Int -> Int -> Returns Int)+addR = Rpc.stubs "add" (Arg "a" $ Arg "b" $ Ret "sum")+  add+++echo :: String -> IO String+echo s = return $ "***" ++ s ++ "***"++echoI :: Interface (String -> ReturnsM IO String)+echoC :: String -> Client String+(echoI, echoC) = (interface "echo" (Arg "input" $ RetM "output"), call . concrete $ echoI)+++helloR :: Rpc.Rpc (String -> Returns String)+helloR = Rpc.stubs "hello" (Arg "name" $ Ret "hello")+  ("Hello, " ++)+++helloIOR :: Rpc.Rpc (Int -> String -> ReturnsM IO String)+helloIOR = Rpc.stubs "helloIO" (Arg "num" $ Arg "name" $ RetM "hello") $+  \num name -> return $ "Hello, " ++ name ++ " " ++ show num+++port :: Int+port = 5000+++runTest+  :: (S.ByteString -> Int -> Client (Int, String) -> IO (Int, String))+  -> (Int -> [Server.Method IO] -> IO ())+  -> IO ()+runTest runC runS = withSocketsDo $+  server runS `race_` do+    threadDelay 1000+    res <- client runC+    res `shouldBe` (333, "***hello***")+++spec :: Spec+spec = do+  describe "simple client" $ do+    it "can communicate with simple server" $+      runTest Client.execClient Server.serve++    it "can communicate with advanced server" $+      runTest Client.execClient Server.runServer++  describe "advanced client" $ do+    it "can communicate with simple server" $+      runTest Client.runClient Server.serve++    it "can communicate with advanced server" $+      runTest Client.runClient Server.runServer++  describe "documentation" $ do+    it "is type-safe" $+      Rpc.docs helloR `shouldBe` ("hello", Arg "name" $ Ret "hello")++    it "works for IO and non-IO" $ do+      Rpc.docs helloR   `shouldBe` ("hello"  , Arg "name" $ Ret "hello")+      Rpc.docs helloIOR `shouldBe` ("helloIO", Arg "num" $ Arg "name" $ RetM "hello")++    it "has working read/show implementations" $ do+      let docs = Rpc.docs addR+      read (show docs) `shouldBe` docs+      show docs `shouldBe` "(\"add\",Arg \"a\" (Arg \"b\" (Ret \"sum\")))"++    it "has type information" $ do+      let meth = Rpc.method helloIOR+      let docs = Server.methodDocs meth+      read (show docs) `shouldBe` docs+      docs `shouldBe` MethodDocs+        { methodArgs =+            [ MethodVal {valName = "num", valType = "Int"}+            , MethodVal {valName = "name", valType = "String"}+            ]+        , methodRetv = MethodVal {valName = "hello", valType = "String"}+        }+      Server.methodName meth `shouldBe` "helloIO"++    it "can be retrieved from type-erased methods" $ do+      let docs = map Server.methodDocs methods+      length docs `shouldNotBe` 0+      mapM_ (\mdoc -> do+          let args = Server.methodArgs mdoc+          let retv = Server.methodRetv mdoc+          length args `shouldNotBe` 0+          mapM_ (\arg -> do+              Server.valName arg `shouldNotBe` ""+              Server.valType arg `shouldNotBe` ""+            ) args+          Server.valName retv `shouldNotBe` ""+          Server.valType retv `shouldNotBe` ""+        ) docs++  describe "methods" $+    it "can be executed locally" $+      Rpc.local helloR "world" `shouldBe` "Hello, world"+++methods :: [Server.Method IO]+methods =+  [ method addI add+  , method echoI echo+  , Rpc.method helloR+  , Rpc.method helloIOR+  ]+++server :: (Int -> [Server.Method IO] -> IO ()) -> IO ()+server run = run port methods+++client+  :: (S.ByteString -> Int -> Client (Int, String) -> IO (Int, String))+  -> IO (Int, String)+client run =+  run "127.0.0.1" port $ do+    r1 <- addC 111 222+    liftIO $ r1 `shouldBe` 333+    r2 <- echoC "hello"+    liftIO $ r2 `shouldBe` "***hello***"+    r3 <- Rpc.rpc helloR "iphy"+    liftIO $ r3 `shouldBe` "Hello, iphy"+    r4 <- Rpc.rpc helloIOR 911 "iphy"+    liftIO $ r4 `shouldBe` "Hello, iphy 911"+    return (r1, r2)
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}