From 422c34407d0897dd36964364adbf5ef818e35038 Mon Sep 17 00:00:00 2001 From: Greg V Date: Fri, 20 May 2016 17:12:36 +0300 Subject: [PATCH 1/5] add serveUnix --- msgpack-rpc/src/Network/MessagePack/Server.hs | 35 +++++++++++++------ 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs index f525e4d..b34c3b7 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -39,6 +39,7 @@ module Network.MessagePack.Server ( method, -- * Start RPC server serve, + serveUnix, ) where import Control.Applicative @@ -50,6 +51,7 @@ import Data.Binary import Data.Conduit import qualified Data.Conduit.Binary as CB import Data.Conduit.Network +import qualified Data.Conduit.Network.Unix as U import Data.Conduit.Serialization.Binary import Data.List import Data.MessagePack @@ -100,25 +102,36 @@ method :: MethodType m f -> Method m method name body = Method name $ toBody body --- | Start RPC server with a set of RPC methods. +-- | Start an RPC server with a set of RPC methods on a TCP socket. serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) => Int -- ^ Port number -> [Method m] -- ^ list of methods -> m () serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do (rsrc, _) <- appSource ad $$+ return () - (_ :: Either ParseError ()) <- try $ processRequests rsrc (appSink ad) + (_ :: Either ParseError ()) <- try $ processRequests methods rsrc (appSink ad) return () - where - processRequests rsrc sink = do - (rsrc', res) <- rsrc $$++ do - obj <- sinkGet get - case fromObject obj of - Error e -> throwM $ ServerError e - Success req -> lift $ getResponse (req :: Request) - _ <- CB.sourceLbs (pack res) $$ sink - processRequests rsrc' sink +-- | Start an RPC server with a set of RPC methods on a Unix domain socket. +serveUnix :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) + => FilePath -- ^ Socket path + -> [Method m] -- ^ list of methods + -> m () +serveUnix path methods = liftBaseWith $ \run -> + U.runUnixServer (U.serverSettings path) $ \ad -> void . run $ do + (rsrc, _) <- appSource ad $$+ return () + (_ :: Either ParseError ()) <- try $ processRequests methods rsrc (appSink ad) + return () + +processRequests methods 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 methods rsrc' sink + where getResponse (rtype, msgid, methodName, args) = do when (rtype /= 0) $ throwM $ ServerError $ "request type is not 0, got " ++ show rtype From 58fad1691b8d8105238b2febdd86f15377385fcc Mon Sep 17 00:00:00 2001 From: Julien Marquet Date: Sun, 19 Dec 2021 21:04:06 +0100 Subject: [PATCH 2/5] chore: update dependencies --- msgpack-aeson/msgpack-aeson.cabal | 19 +++++------ msgpack-rpc/msgpack-rpc.cabal | 25 +++++++------- msgpack-rpc/src/Network/MessagePack/Client.hs | 6 ++-- msgpack-rpc/src/Network/MessagePack/Server.hs | 10 +++--- msgpack/msgpack.cabal | 33 +++++++++---------- msgpack/test/DataCases.hs | 20 +++++------ 6 files changed, 55 insertions(+), 58 deletions(-) diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index 063ebd4..faa0eea 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -23,16 +23,15 @@ library hs-source-dirs: src exposed-modules: Data.MessagePack.Aeson - build-depends: base >= 4.7 && < 4.14 - , aeson >= 0.8.0.2 && < 0.12 - || >= 1.0 && < 1.5 - , bytestring >= 0.10.4 && < 0.11 - , msgpack >= 1.1.0 && < 1.2 - , scientific >= 0.3.2 && < 0.4 - , text >= 1.2.3 && < 1.3 - , unordered-containers >= 0.2.5 && < 0.3 - , vector >= 0.10.11 && < 0.13 - , deepseq >= 1.3 && < 1.5 + build-depends: base == 4.14.* + , aeson == 1.5.* + , bytestring == 0.10.* + , msgpack == 1.2.* + , scientific == 0.3.* + , text == 1.2.* + , unordered-containers == 0.2.* + , vector == 0.12.* + , deepseq == 1.4.* default-language: Haskell2010 diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index 0acf909..bafd2dd 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -26,19 +26,18 @@ library exposed-modules: Network.MessagePack.Server Network.MessagePack.Client - build-depends: base >= 4.5 && < 4.13 - , bytestring >= 0.10.4 && < 0.11 - , text >= 1.2.3 && < 1.3 - , network >= 2.6 && < 2.9 - || >= 3.0 && < 3.1 - , mtl >= 2.2.1 && < 2.3 - , monad-control >= 1.0.0.0 && < 1.1 - , conduit >= 1.2.3.1 && < 1.3 - , conduit-extra >= 1.1.3.4 && < 1.3 - , binary-conduit >= 1.2.3 && < 1.3 - , exceptions >= 0.8 && < 0.11 - , binary >= 0.7.1 && < 0.9 - , msgpack >= 1.1.0 && < 1.2 + build-depends: base == 4.14.* + , bytestring == 0.10.* + , text == 1.2.* + , network == 3.1.* + , mtl == 2.2.* + , monad-control == 1.0.* + , conduit == 1.3.* + , conduit-extra == 1.3.* + , binary-conduit == 1.3.* + , exceptions == 0.10.* + , binary == 0.8.* + , msgpack == 1.2.* test-suite msgpack-rpc-test default-language: Haskell2010 diff --git a/msgpack-rpc/src/Network/MessagePack/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs index e7a8edb..fe3862f 100644 --- a/msgpack-rpc/src/Network/MessagePack/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -61,8 +61,8 @@ newtype Client a -- | RPC connection type data Connection = Connection - !(ResumableSource IO S.ByteString) - !(Sink S.ByteString IO ()) + !(SealedConduitT () S.ByteString IO ()) + !(ConduitT S.ByteString Void IO ()) !Int execClient :: S.ByteString -> Int -> Client a -> IO () @@ -97,7 +97,7 @@ 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 + runConduit $ CB.sourceLbs (pack (0 :: Int, msgid, methodName, args)) .| sink rsrc $$++ sinkGet Binary.get CMS.put $ Connection rsrc' sink (msgid + 1) diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs index b34c3b7..b391150 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -42,6 +42,7 @@ module Network.MessagePack.Server ( serveUnix, ) where +import Conduit (MonadUnliftIO) import Control.Applicative import Control.Monad import Control.Monad.Catch @@ -55,6 +56,7 @@ import qualified Data.Conduit.Network.Unix as U import Data.Conduit.Serialization.Binary import Data.List import Data.MessagePack +import Data.MessagePack.Result import Data.Typeable -- ^ MessagePack RPC method @@ -103,7 +105,7 @@ method :: MethodType m f method name body = Method name $ toBody body -- | Start an RPC server with a set of RPC methods on a TCP socket. -serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) +serve :: (MonadBaseControl IO m, MonadUnliftIO m, MonadIO m, MonadCatch m, MonadThrow m) => Int -- ^ Port number -> [Method m] -- ^ list of methods -> m () @@ -127,9 +129,9 @@ processRequests methods 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 + Error err -> throwM $ ServerError $ "invalid request: " ++ err + Success req -> lift $ getResponse (req :: Request) + _ <- runConduit $ CB.sourceLbs (pack res) .| sink processRequests methods rsrc' sink where getResponse (rtype, msgid, methodName, args) = do diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 9283e9e..c669354 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: msgpack -version: 1.1.0.0 +version: 1.2.0.0 synopsis: A Haskell implementation of MessagePack description: @@ -64,27 +64,26 @@ library Data.MessagePack.Object Data.MessagePack.Get Data.MessagePack.Put + Data.MessagePack.Result other-modules: Data.MessagePack.Tags - Data.MessagePack.Result Data.MessagePack.Get.Internal Compat.Binary Compat.Prelude - build-depends: base >= 4.7 && < 4.14 - , mtl >= 2.2.1 && < 2.3 - , bytestring >= 0.10.4 && < 0.11 - , text >= 1.2.3 && < 1.3 - , containers >= 0.5.5 && < 0.7 - , unordered-containers >= 0.2.5 && < 0.3 - , hashable >= 1.1.2.4 && < 1.4 - , vector >= 0.10.11 && < 0.13 - , deepseq >= 1.3 && < 1.5 - , binary >= 0.7.1 && < 0.9 - , semigroups >= 0.5.0 && < 0.20 - , time >= 1.4.2 && < 1.10 - , int-cast >= 0.1.1 && < 0.3 - , array >= 0.5.0 && < 0.6 + build-depends: base == 4.14.* + , mtl == 2.2.* + , bytestring == 0.10.* + , text == 1.2.* + , containers == 0.6.* + , unordered-containers == 0.2.* + , hashable == 1.3.* + , vector == 0.12.* + , deepseq == 1.4.* + , binary == 0.8.* + , time == 1.9.* + , int-cast == 0.2.* + , array == 0.5.* if !impl(ghc > 8.0) build-depends: fail == 4.9.* @@ -117,7 +116,7 @@ test-suite msgpack-tests -- test-specific dependencies , async == 2.2.* , filepath == 1.3.* || == 1.4.* - , HsYAML >= 0.1.1 && < 0.2 + , HsYAML >= 0.1.1 , tasty == 1.2.* , tasty-quickcheck == 0.10.* , tasty-hunit == 0.10.* diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs index f41db7c..19649d1 100644 --- a/msgpack/test/DataCases.hs +++ b/msgpack/test/DataCases.hs @@ -40,7 +40,7 @@ genDataCases fns = testGroup "Reference Tests" <$> forM fns doFile forM_ (zip [0..] (dcMsgPack tc)) $ \(j,b) -> do let Right decoded = unpack (L.fromStrict b) - packLbl = "pack #" ++ (show (j::Int)) + packLbl = "pack #" ++ show (j::Int) unpackLbl = "un" ++ packLbl -- the `number` test-cases conflate integers and floats @@ -62,8 +62,6 @@ genDataCases fns = testGroup "Reference Tests" <$> forM fns doFile _ -> assertEqual unpackLbl obj decoded - pure () - pure (testGroup fn tcs) @@ -76,26 +74,26 @@ instance FromYAML DataCase where parseYAML = Y.withMap "DataCase" $ \m -> do msgpack <- m .: "msgpack" - obj <- do { Just (Y.Scalar Y.SNull) <- m .:! "nil" ; pure ObjectNil } + obj <- do { Just (Y.Scalar _ Y.SNull) <- m .:! "nil" ; pure ObjectNil } <|> do { Just b <- m .:! "bool" ; pure (ObjectBool b) } <|> do { Just i <- m .:! "number" ; pure (ObjectInt (fromInteger i)) } <|> do { Just s <- m .:! "bignum" ; pure (ObjectInt (read . T.unpack $ s)) } <|> do { Just d <- m .:! "number" ; pure (ObjectDouble d) } <|> do { Just t <- m .:! "string" ; pure (ObjectStr t) } <|> do { Just t <- m .:! "binary" ; pure (ObjectBin (hex2bin t)) } - <|> do { Just v@(Y.Sequence _ _) <- m .:! "array" ; pure (nodeToObj v) } - <|> do { Just m'@(Y.Mapping _ _) <- m .:! "map" ; pure (nodeToObj m') } + <|> do { Just v@(Y.Sequence _ _ _) <- m .:! "array" ; pure (nodeToObj v) } + <|> do { Just m'@(Y.Mapping _ _ _) <- m .:! "map" ; pure (nodeToObj m') } <|> do { Just (n,t) <- m .:! "ext" ; pure (ObjectExt n (hex2bin t)) } <|> do { Just (s,ns) <- m .:! "timestamp"; pure (toObject $ mptsFromPosixSeconds2 s ns) } pure (DataCase { dcMsgPack = map hex2bin msgpack, dcObject = obj }) -nodeToObj :: Y.Node -> Object -nodeToObj (Y.Scalar sca) = scalarToObj sca -nodeToObj (Y.Sequence _ ns) = ObjectArray (Lst.fromList (map nodeToObj ns)) -nodeToObj (Y.Mapping _ ns) = ObjectMap (Lst.fromList $ map (\(k,v) -> (nodeToObj k, nodeToObj v)) $ Map.toList ns) -nodeToObj (Y.Anchor _ n) = nodeToObj n +nodeToObj :: Y.Node loc -> Object +nodeToObj (Y.Scalar _ sca) = scalarToObj sca +nodeToObj (Y.Sequence _ _ ns) = ObjectArray (Lst.fromList (map nodeToObj ns)) +nodeToObj (Y.Mapping _ _ ns) = ObjectMap (Lst.fromList $ map (\(k,v) -> (nodeToObj k, nodeToObj v)) $ Map.toList ns) +nodeToObj (Y.Anchor _ _ n) = nodeToObj n scalarToObj :: Y.Scalar -> Object scalarToObj Y.SNull = ObjectNil From 17ea483bb5642f8918ebe1c9fd7ac9fdd73f2944 Mon Sep 17 00:00:00 2001 From: Julien Marquet Date: Mon, 20 Dec 2021 16:43:31 +0100 Subject: [PATCH 3/5] Added test case for Unix --- msgpack-rpc/src/Network/MessagePack/Client.hs | 9 +++- msgpack-rpc/test/test.hs | 45 ++++++++++++++++--- 2 files changed, 48 insertions(+), 6 deletions(-) diff --git a/msgpack-rpc/src/Network/MessagePack/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs index fe3862f..f7b75d7 100644 --- a/msgpack-rpc/src/Network/MessagePack/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -30,7 +30,7 @@ module Network.MessagePack.Client ( -- * MessagePack Client type - Client, execClient, + Client, execClient, execClientUnix, -- * Call RPC method call, @@ -49,6 +49,7 @@ import qualified Data.ByteString as S import Data.Conduit import qualified Data.Conduit.Binary as CB import Data.Conduit.Network +import qualified Data.Conduit.Network.Unix as U import Data.Conduit.Serialization.Binary import Data.MessagePack import Data.Typeable @@ -71,6 +72,12 @@ execClient host port m = (rsrc, _) <- appSource ad $$+ return () void $ evalStateT (runClient m) (Connection rsrc (appSink ad) 0) +execClientUnix :: FilePath -> Client a -> IO () +execClientUnix path m = + U.runUnixClient (U.clientSettings path) $ \ad -> do + (rsrc, _) <- appSource ad $$+ return () + void $ evalStateT (runClient m) (Connection rsrc (appSink ad) 0) + -- | RPC error type data RpcError = ServerError Object -- ^ Server error diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/test.hs index be4f51b..3c5dfdd 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -10,16 +10,24 @@ import Network.MessagePack.Client import Network.MessagePack.Server import Network.Socket (withSocketsDo) +import System.IO (openTempFile) + port :: Int port = 5000 main :: IO () main = withSocketsDo $ defaultMain $ testGroup "simple service" - [ testCase "test" $ server `race_` (threadDelay 1000 >> client) ] + [ testCase "test TCP" $ serverTCP `race_` (threadDelay 1000 >> clientTCP) + , testCase "test Unix" unixCase] + +unixCase :: IO () +unixCase = do + (f, _) <- openTempFile "/tmp" "socket.sock" + serverUnix f `race_` (threadDelay 1000 >> clientUnix f) -server :: IO () -server = +serverTCP :: IO () +serverTCP = serve port [ method "add" add , method "echo" echo @@ -31,8 +39,34 @@ server = echo :: String -> Server String echo s = return $ "***" ++ s ++ "***" -client :: IO () -client = execClient "localhost" port $ do +clientTCP :: IO () +clientTCP = execClient "localhost" port $ do + r1 <- add 123 456 + liftIO $ r1 @?= 123 + 456 + r2 <- echo "hello" + liftIO $ r2 @?= "***hello***" + where + add :: Int -> Int -> Client Int + add = call "add" + + echo :: String -> Client String + echo = call "echo" + +serverUnix :: FilePath -> IO () +serverUnix path = + serveUnix path + [ method "add" add + , method "echo" echo + ] + where + add :: Int -> Int -> Server Int + add x y = return $ x + y + + echo :: String -> Server String + echo s = return $ "***" ++ s ++ "***" + +clientUnix :: FilePath -> IO () +clientUnix path = execClientUnix path $ do r1 <- add 123 456 liftIO $ r1 @?= 123 + 456 r2 <- echo "hello" @@ -43,3 +77,4 @@ client = execClient "localhost" port $ do echo :: String -> Client String echo = call "echo" + From 5c8d3d93122c345fc9a61e0b8a56c91551ded485 Mon Sep 17 00:00:00 2001 From: Julien Marquet Date: Mon, 20 Dec 2021 18:02:58 +0100 Subject: [PATCH 4/5] test: reformulate client-server test suite * Don't rely on delays * Test Unix pair --- msgpack-rpc/msgpack-rpc.cabal | 28 ++++++------ msgpack-rpc/src/Network/MessagePack/Client.hs | 31 ++++++++++--- msgpack-rpc/src/Network/MessagePack/Server.hs | 33 +++++++++++--- msgpack-rpc/test/test.hs | 44 +++++++++++-------- 4 files changed, 92 insertions(+), 44 deletions(-) diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index bafd2dd..481e47a 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: msgpack-rpc -version: 1.0.0 +version: 1.1.0 synopsis: A MessagePack-RPC Implementation description: A MessagePack-RPC Implementation @@ -26,18 +26,19 @@ library exposed-modules: Network.MessagePack.Server Network.MessagePack.Client - build-depends: base == 4.14.* - , bytestring == 0.10.* - , text == 1.2.* - , network == 3.1.* - , mtl == 2.2.* - , monad-control == 1.0.* - , conduit == 1.3.* - , conduit-extra == 1.3.* - , binary-conduit == 1.3.* - , exceptions == 0.10.* - , binary == 0.8.* - , msgpack == 1.2.* + build-depends: base == 4.14.* + , binary == 0.8.* + , bytestring == 0.10.* + , binary-conduit == 1.3.* + , conduit == 1.3.* + , conduit-extra == 1.3.* + , exceptions == 0.10.* + , msgpack == 1.2.* + , mtl == 2.2.* + , monad-control == 1.0.* + , network == 3.1.* + , streaming-commons == 0.2.* + , text == 1.2.* test-suite msgpack-rpc-test default-language: Haskell2010 @@ -48,6 +49,7 @@ test-suite msgpack-rpc-test build-depends: msgpack-rpc -- inherited constraints via `msgpack-rpc` , base + , conduit-extra == 1.3.* , mtl , network -- test-specific dependencies diff --git a/msgpack-rpc/src/Network/MessagePack/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs index f7b75d7..8f0e28c 100644 --- a/msgpack-rpc/src/Network/MessagePack/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -37,6 +37,21 @@ module Network.MessagePack.Client ( -- * RPC error RpcError(..), + + -- * Settings + ClientSettings, + clientSettings, + U.ClientSettingsUnix, + SN.clientSettingsUnix, + + -- * Getters & setters + SN.serverSettingsUnix, + SN.getReadBufferSize, + SN.setReadBufferSize, + getAfterBind, + setAfterBind, + getPort, + setPort, ) where import Control.Applicative @@ -52,9 +67,13 @@ import Data.Conduit.Network import qualified Data.Conduit.Network.Unix as U import Data.Conduit.Serialization.Binary import Data.MessagePack +import qualified Data.Streaming.Network as SN import Data.Typeable import System.IO +clientSettingsUnix :: FilePath -> U.ClientSettingsUnix +clientSettingsUnix = U.clientSettings + newtype Client a = ClientT { runClient :: StateT Connection IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) @@ -66,15 +85,15 @@ data Connection !(ConduitT S.ByteString Void IO ()) !Int -execClient :: S.ByteString -> Int -> Client a -> IO () -execClient host port m = - runTCPClient (clientSettings port host) $ \ad -> do +execClient :: ClientSettings -> Client a -> IO () +execClient settings m = + runTCPClient settings $ \ad -> do (rsrc, _) <- appSource ad $$+ return () void $ evalStateT (runClient m) (Connection rsrc (appSink ad) 0) -execClientUnix :: FilePath -> Client a -> IO () -execClientUnix path m = - U.runUnixClient (U.clientSettings path) $ \ad -> do +execClientUnix :: U.ClientSettingsUnix -> Client a -> IO () +execClientUnix settings m = + U.runUnixClient settings $ \ad -> do (rsrc, _) <- appSource ad $$+ return () void $ evalStateT (runClient m) (Connection rsrc (appSink ad) 0) diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs index b391150..4908457 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -40,6 +40,20 @@ module Network.MessagePack.Server ( -- * Start RPC server serve, serveUnix, + + -- * RPC server settings + ServerSettings, + serverSettings, + U.ServerSettingsUnix, + + -- * Getters & setters + SN.serverSettingsUnix, + SN.getReadBufferSize, + SN.setReadBufferSize, + getAfterBind, + setAfterBind, + getPort, + setPort, ) where import Conduit (MonadUnliftIO) @@ -49,6 +63,7 @@ import Control.Monad.Catch import Control.Monad.Trans import Control.Monad.Trans.Control import Data.Binary +import Data.ByteString (ByteString) import Data.Conduit import qualified Data.Conduit.Binary as CB import Data.Conduit.Network @@ -57,6 +72,7 @@ import Data.Conduit.Serialization.Binary import Data.List import Data.MessagePack import Data.MessagePack.Result +import qualified Data.Streaming.Network as SN import Data.Typeable -- ^ MessagePack RPC method @@ -106,25 +122,30 @@ method name body = Method name $ toBody body -- | Start an RPC server with a set of RPC methods on a TCP socket. serve :: (MonadBaseControl IO m, MonadUnliftIO m, MonadIO m, MonadCatch m, MonadThrow m) - => Int -- ^ Port number - -> [Method m] -- ^ list of methods + => ServerSettings -- ^ settings + -> [Method m] -- ^ list of methods -> m () -serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do +serve settings methods = runGeneralTCPServer settings $ \ad -> do (rsrc, _) <- appSource ad $$+ return () (_ :: Either ParseError ()) <- try $ processRequests methods rsrc (appSink ad) return () -- | Start an RPC server with a set of RPC methods on a Unix domain socket. serveUnix :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) - => FilePath -- ^ Socket path + => U.ServerSettingsUnix -> [Method m] -- ^ list of methods -> m () -serveUnix path methods = liftBaseWith $ \run -> - U.runUnixServer (U.serverSettings path) $ \ad -> void . run $ do +serveUnix settings methods = liftBaseWith $ \run -> + U.runUnixServer settings $ \ad -> void . run $ do (rsrc, _) <- appSource ad $$+ return () (_ :: Either ParseError ()) <- try $ processRequests methods rsrc (appSink ad) return () +processRequests :: (MonadThrow m) + => [Method m] -- ^ list of methods + -> SealedConduitT () ByteString m () + -> ConduitT ByteString Void m a + -> m b processRequests methods rsrc sink = do (rsrc', res) <- rsrc $$++ do obj <- sinkGet get diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/test.hs index 3c5dfdd..5c298b6 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} import Control.Concurrent import Control.Concurrent.Async +import Control.Concurrent.Chan import Control.Monad.Trans import Test.Tasty import Test.Tasty.HUnit import Network.MessagePack.Client import Network.MessagePack.Server -import Network.Socket (withSocketsDo) +import Network.Socket (Socket, withSocketsDo) import System.IO (openTempFile) @@ -16,19 +18,23 @@ port :: Int port = 5000 main :: IO () -main = withSocketsDo $ defaultMain $ - testGroup "simple service" - [ testCase "test TCP" $ serverTCP `race_` (threadDelay 1000 >> clientTCP) - , testCase "test Unix" unixCase] - -unixCase :: IO () -unixCase = do +main = do (f, _) <- openTempFile "/tmp" "socket.sock" - serverUnix f `race_` (threadDelay 1000 >> clientUnix f) + withSocketsDo $ defaultMain $ + testGroup "simple service" + [ testCase "test TCP" $ testClientServer (clientTCP port) (serverTCP port) + , testCase "test Unix" $ testClientServer (clientUnix f) (serverUnix f) ] + +testClientServer :: IO () -> ((Socket -> IO ()) -> IO ()) -> IO () +testClientServer client server = do + (okChan :: Chan ()) <- newChan + forkIO $ server (const $ writeChan okChan ()) + readChan okChan + client -serverTCP :: IO () -serverTCP = - serve port +serverTCP :: Int -> (Socket -> IO ()) -> IO () +serverTCP port afterBind = + serve (setAfterBind afterBind $ serverSettings port "*") [ method "add" add , method "echo" echo ] @@ -39,8 +45,8 @@ serverTCP = echo :: String -> Server String echo s = return $ "***" ++ s ++ "***" -clientTCP :: IO () -clientTCP = execClient "localhost" port $ do +clientTCP :: Int -> IO () +clientTCP port = execClient (clientSettings port "localhost") $ do r1 <- add 123 456 liftIO $ r1 @?= 123 + 456 r2 <- echo "hello" @@ -52,9 +58,9 @@ clientTCP = execClient "localhost" port $ do echo :: String -> Client String echo = call "echo" -serverUnix :: FilePath -> IO () -serverUnix path = - serveUnix path +serverUnix :: FilePath -> (Socket -> IO ()) -> IO () +serverUnix path afterBind = + serveUnix (setAfterBind afterBind $ serverSettingsUnix path) [ method "add" add , method "echo" echo ] @@ -66,7 +72,7 @@ serverUnix path = echo s = return $ "***" ++ s ++ "***" clientUnix :: FilePath -> IO () -clientUnix path = execClientUnix path $ do +clientUnix path = execClientUnix (clientSettingsUnix path) $ do r1 <- add 123 456 liftIO $ r1 @?= 123 + 456 r2 <- echo "hello" From c329242a96a2ac1386ff7ebc27ef6061bf1c3fb3 Mon Sep 17 00:00:00 2001 From: Julien Marquet Date: Mon, 20 Dec 2021 21:57:22 +0100 Subject: [PATCH 5/5] fix: fix Nix build By loosening test dependency requirements --- msgpack-aeson/msgpack-aeson.cabal | 4 ++-- msgpack-rpc/msgpack-rpc.cabal | 6 +++--- msgpack/msgpack.cabal | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index faa0eea..fba8dd0 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -47,7 +47,7 @@ test-suite msgpack-aeson-test , aeson , msgpack -- test-specific dependencies - , tasty == 1.2.* - , tasty-hunit == 0.10.* + , tasty + , tasty-hunit default-language: Haskell2010 diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index 481e47a..c6a2f05 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -53,6 +53,6 @@ test-suite msgpack-rpc-test , mtl , network -- test-specific dependencies - , async == 2.2.* - , tasty == 1.2.* - , tasty-hunit == 0.10.* + , async + , tasty + , tasty-hunit diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index c669354..44b8462 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -117,7 +117,7 @@ test-suite msgpack-tests , async == 2.2.* , filepath == 1.3.* || == 1.4.* , HsYAML >= 0.1.1 - , tasty == 1.2.* - , tasty-quickcheck == 0.10.* - , tasty-hunit == 0.10.* - , QuickCheck == 2.13.* + , tasty + , tasty-quickcheck + , tasty-hunit + , QuickCheck