packages feed

msgpack-rpc-conduit 0.0.6 → 0.0.7

raw patch · 12 files changed

+67/−53 lines, 12 filesdep +monad-validatedep −data-default-instances-basedep ~msgpack-typesdep ~network

Dependencies added: monad-validate

Dependencies removed: data-default-instances-base

Dependency ranges changed: msgpack-types, network

Files

msgpack-rpc-conduit.cabal view
@@ -1,5 +1,5 @@ name:                 msgpack-rpc-conduit-version:              0.0.6+version:              0.0.7 synopsis:             A MessagePack-RPC Implementation homepage:             http://msgpack.org/ license:              BSD3@@ -54,13 +54,13 @@     , conduit     , conduit-extra     , data-default-class-    , data-default-instances-base     , exceptions     , monad-control-    , msgpack-binary                    >= 0.0.11-    , msgpack-types                     >= 0.0.1+    , monad-validate+    , msgpack-binary            >= 0.0.11+    , msgpack-types             >= 0.2 && < 0.3     , mtl-    , network                           < 3+    , network                   < 4     , text     , unliftio-core @@ -80,4 +80,4 @@     , hspec     , msgpack-rpc-conduit     , mtl-    , network                           < 3+    , network
src/Network/MessagePack/Capabilities.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData    #-} module Network.MessagePack.Capabilities     ( ServerCapability (..)     , ClientCapability (..)
src/Network/MessagePack/Client.hs view
@@ -20,7 +20,6 @@ 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 (..))
src/Network/MessagePack/Client/Internal.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE StrictData                 #-} {-# LANGUAGE TypeFamilies               #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.MessagePack.Client.Internal where@@ -11,6 +12,7 @@ import           Control.Monad.Catch               (MonadCatch, MonadThrow,                                                     throwM) import qualified Control.Monad.State.Strict        as CMS+import           Control.Monad.Validate            (runValidate) import qualified Data.Binary                       as Binary import qualified Data.ByteString                   as S import           Data.Conduit                      (ConduitT, SealedConduitT,@@ -18,8 +20,9 @@                                                     (.|)) import qualified Data.Conduit.Binary               as CB import           Data.Conduit.Serialization.Binary (sinkGet)-import           Data.MessagePack                  (MessagePack (fromObject),-                                                    Object)+import           Data.MessagePack                  (MessagePack, Object,+                                                    defaultConfig, fromObject,+                                                    fromObjectWith) import           Data.Monoid                       ((<>)) import           Data.Text                         (Text) import qualified Data.Text                         as T@@ -58,11 +61,11 @@     => RpcType (ClientT m o) where   rpcc name args = do     res <- rpcCall name (reverse args)-    case fromObject res of-      R.Success ok  ->+    case runValidate $ fromObjectWith defaultConfig res of+      Right ok  ->         return ok-      R.Failure msg ->-        throwM $ ResultTypeError (T.pack msg) res+      Left err ->+        throwM $ ResultTypeError (T.pack $ show err) res   rpcCall :: (MonadThrow m, CMS.MonadIO m) => Text -> [Object] -> ClientT m Object@@ -81,8 +84,8 @@     }    case unpackResponse res of-    Nothing -> throwM $ ProtocolError "invalid response data"-    Just (rtype, rmsgid, rerror, rresult) -> do+    Left err -> throwM $ ProtocolError $ "invalid response data: " <> T.pack (show err)+    Right (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)
src/Network/MessagePack/Interface.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE Safe                  #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE StrictData            #-} {-# LANGUAGE TypeFamilies          #-} module Network.MessagePack.Interface     ( Interface (..)@@ -36,8 +37,8 @@   data Interface f = Interface-  { name :: !Text-  , docs :: !(Doc f)+  { name :: Text+  , docs :: Doc f   }
src/Network/MessagePack/Rpc.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe                  #-}+{-# LANGUAGE StrictData            #-} {-# LANGUAGE TypeFamilies          #-} module Network.MessagePack.Rpc   ( I.Doc (..)
src/Network/MessagePack/Server/Basic.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StrictData                 #-} {-# LANGUAGE Trustworthy                #-} {-# LANGUAGE TypeFamilies               #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -61,6 +62,7 @@ import           Control.Monad.Trans               (MonadIO, MonadTrans, lift,                                                     liftIO) import           Control.Monad.Trans.Control       (MonadBaseControl)+import           Control.Monad.Validate            (runValidate) import qualified Data.Binary                       as Binary import qualified Data.ByteString                   as S import           Data.Conduit                      (ConduitT, SealedConduitT,@@ -74,7 +76,8 @@ import           Data.Conduit.Serialization.Binary (ParseError, sinkGet) import qualified Data.List                         as List import           Data.MessagePack                  (MessagePack, Object,-                                                    fromObject, toObject)+                                                    defaultConfig, fromObject,+                                                    fromObjectWith, toObject) import           Data.Monoid                       ((<>)) import qualified Data.Text                         as T import           Data.Traversable                  (sequenceA)@@ -88,7 +91,7 @@   newtype ServerT m a = ServerT { runServerT :: m a }-  deriving (Functor, Applicative, Monad, MonadIO)+  deriving (Functor, Applicative, Monad, MonadIO, MonadFail)   instance MonadTrans ServerT where@@ -101,13 +104,13 @@  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+    case runValidate . fromObjectWith defaultConfig $ x of+      Left err -> throwM $ ServerError $ "argument type error: " <> T.pack (show err)+      Right ok -> toBody n (f ok) 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 _ m [] = toObject defaultConfig <$> runServerT m   toBody n _ ls =     throwM $ ServerError $       "invalid arguments for method '" <> n <> "': " <> T.pack (show ls)@@ -138,11 +141,11 @@     rsrc $$++ do       obj <- sinkGet Binary.get       case unpackRequest obj of-        Nothing ->-          throwM $ ServerError "invalid request"-        Just req@(_, msgid, _, _) ->+        Left err ->+          throwM . ServerError . T.pack . show $ err+        Right req@(_, msgid, _, _) ->           lift $ getResponse methods req `catch` \(ServerError err) ->-            return (1, msgid, toObject err, toObject ())+            return (1, msgid, toObject defaultConfig err, toObject defaultConfig ())    _ <- runConduit $ CB.sourceLbs (packResponse res) .| sink   processRequests methods rsrc' sink@@ -156,11 +159,11 @@ 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)+    process (R.Failure err) = (1, msgid, toObject defaultConfig err, toObject defaultConfig ())+    process (R.Success ok ) = (1, msgid, toObject defaultConfig (), ok)  getResponse _ (rtype, msgid, _, _) =-  pure (1, msgid, toObject ["request type is not 0, got " <> T.pack (show rtype)], toObject ())+  pure (1, msgid, toObject defaultConfig ["request type is not 0, got " <> T.pack (show rtype)], toObject defaultConfig ())   callMethod
src/Network/MessagePack/Types/Client.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE Safe #-} module Network.MessagePack.Types.Client   ( RpcType (..)   , call   ) where -import           Data.MessagePack (MessagePack (toObject), Object)-import           Data.Text        (Text)+import           Data.MessagePack.Types (MessagePack, Object, defaultConfig,+                                         toObject)+import           Data.Text              (Text)   class RpcType r where@@ -12,7 +14,7 @@   instance (MessagePack o, RpcType r) => RpcType (o -> r) where-  rpcc name args arg = rpcc name (toObject arg : args)+  rpcc name args arg = rpcc name (toObject defaultConfig arg : args)   {-# INLINE rpcc #-}
src/Network/MessagePack/Types/Error.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StrictData         #-} module Network.MessagePack.Types.Error   ( RpcError (..)   , ServerError (..)@@ -12,9 +13,9 @@  -- | RPC error type data RpcError-  = RemoteError !Object           -- ^ Server error-  | ResultTypeError !Text !Object -- ^ Result type mismatch-  | ProtocolError !Text           -- ^ Protocol error+  = RemoteError Object          -- ^ Server error+  | ResultTypeError Text Object -- ^ Result type mismatch+  | ProtocolError Text          -- ^ Protocol error   deriving (Show, Eq, Ord, Typeable)  instance Exception RpcError
src/Network/MessagePack/Types/Result.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE Safe              #-}+{-# LANGUAGE StrictData        #-} module Network.MessagePack.Types.Result     ( Result (..)     ) where@@ -30,13 +31,12 @@     _            <|> r = r  instance Monad Result where-    return = Success-    fail = Failure-     Success x   >>= f = f x     Failure msg >>= _ = Failure msg +    return = Success+ #if (MIN_VERSION_base(4,13,0)) instance MonadFail Result where-    fail = Failure #endif+    fail = Failure
src/Network/MessagePack/Types/Server.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe                  #-}+{-# LANGUAGE StrictData            #-} module Network.MessagePack.Types.Server   ( MethodVal (..)   , MethodDocs (..)@@ -14,21 +15,21 @@   data MethodVal = MethodVal-  { valName :: !Text-  , valType :: !Text+  { valName :: Text+  , valType :: Text   }   deriving (Show, Read, Eq)  data MethodDocs = MethodDocs-  { methodArgs :: ![MethodVal]-  , methodRetv :: !MethodVal+  { methodArgs :: [MethodVal]+  , methodRetv :: MethodVal   }   deriving (Show, Read, Eq)  -- ^ MessagePack RPC method data Method m = Method-  { methodName :: !Text-  , methodDocs :: !MethodDocs+  { methodName :: Text+  , methodDocs :: MethodDocs   , methodBody :: [Object] -> m Object   }
src/Network/MessagePack/Types/Spec.hs view
@@ -7,9 +7,11 @@   , unpackResponse   ) where -import qualified Data.ByteString.Lazy as L-import qualified Data.List            as List-import           Data.MessagePack     (MessagePack, Object, fromObject, pack)+import           Control.Monad.Validate (runValidate)+import qualified Data.ByteString.Lazy   as L+import qualified Data.List              as List+import           Data.MessagePack       (DecodeError, MessagePack, Object,+                                         defaultConfig, fromObjectWith, pack)  type Request ix = (Int, Int, ix, [Object]) type Response   = (Int, Int, Object, Object)@@ -25,8 +27,8 @@ packResponse :: Response -> L.ByteString packResponse = pack -unpackResponse :: Object -> Maybe Response-unpackResponse = fromObject+unpackResponse :: Object -> Either DecodeError Response+unpackResponse = runValidate . fromObjectWith defaultConfig -unpackRequest :: MessagePack ix => Object -> Maybe (Request ix)-unpackRequest = fromObject+unpackRequest :: MessagePack ix => Object -> Either DecodeError (Request ix)+unpackRequest = runValidate . fromObjectWith defaultConfig