diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ -# Revision history for Z-Redis +# Revision history for Z-MessagePack ## 0.3.0.1 -- 2021-02-25 diff --git a/Z-MessagePack.cabal b/Z-MessagePack.cabal --- a/Z-MessagePack.cabal +++ b/Z-MessagePack.cabal @@ -1,107 +1,104 @@ -cabal-version: >=1.10 -name: Z-MessagePack -version: 0.3.0.1 -synopsis: MessagePack -description: MessagePack binary serialization format. -license: BSD3 -license-file: LICENSE -author: Dong Han -maintainer: winterland1989@gmail.com -copyright: (c) Hideyuki Tanaka, 2009-2015, (c) Dong Han, 2020 -category: Data -build-type: Simple -homepage: https://github.com/ZHaskell/z-messagepack -bug-reports: https://github.com/ZHaskell/z-messagepack/issues - -extra-source-files: CHANGELOG.md +cabal-version: >=1.10 +name: Z-MessagePack +version: 0.4.0.0 +synopsis: MessagePack +description: MessagePack binary serialization format. +license: BSD3 +license-file: LICENSE +author: Dong Han +maintainer: winterland1989@gmail.com +copyright: (c) Hideyuki Tanaka, 2009-2015, (c) Dong Han, 2020 +category: Data +build-type: Simple +homepage: https://github.com/ZHaskell/z-messagepack +bug-reports: https://github.com/ZHaskell/z-messagepack/issues +extra-source-files: CHANGELOG.md library - exposed-modules: Z.Data.MessagePack - Z.Data.MessagePack.Base - Z.Data.MessagePack.Builder - Z.Data.MessagePack.Value - Z.IO.RPC.MessagePack - - -- other-modules: - -- other-extensions: - build-depends: base >= 4.12 && <5 - , deepseq >= 1.4 && < 1.5 - , primitive >= 0.7.1 && < 0.7.2 - , QuickCheck >= 2.10 - , scientific == 0.3.* - , hashable == 1.3.* - , unordered-containers == 0.2.* - , containers == 0.6.* - , integer-gmp == 1.* - , tagged == 0.8.* - , time >= 1.9 && < 2.0 - , Z-Data == 0.6.* - , Z-IO == 0.6.* + exposed-modules: + Z.Data.MessagePack + Z.Data.MessagePack.Base + Z.Data.MessagePack.Builder + Z.Data.MessagePack.Value + Z.IO.RPC.MessagePack - -- hs-source-dirs: - default-language: Haskell2010 - default-extensions: BangPatterns - BinaryLiterals - CApiFFI - ConstraintKinds - CPP - DerivingStrategies - DeriveGeneric - DeriveAnyClass - DefaultSignatures - DataKinds - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - KindSignatures - MagicHash - MultiParamTypeClasses - MultiWayIf - PartialTypeSignatures - PatternSynonyms - PolyKinds - QuantifiedConstraints - QuasiQuotes - OverloadedStrings - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TypeApplications - TypeFamilyDependencies - TypeFamilies - TypeOperators - TupleSections - UnboxedTuples - UnliftedFFITypes - ViewPatterns + build-depends: + base >=4.12 && <5 + , containers >=0.6 && <0.7 + , deepseq >=1.4 && <1.5 + , hashable >=1.3 && <1.4 + , integer-gmp >=1 && <2 + , primitive >=0.7.1 && <0.7.2 + , QuickCheck >=2.10 + , scientific >=0.3 && <0.4 + , tagged >=0.8 && <0.9 + , time >=1.9 && <2.0 + , unordered-containers >=0.2 && <0.3 + , Z-Data >=0.6 && <1.0 + , Z-IO >=0.6 && <1.0 + default-language: Haskell2010 + default-extensions: + BangPatterns + BinaryLiterals + CApiFFI + CPP + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + PartialTypeSignatures + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UnboxedTuples + UnliftedFFITypes + ViewPatterns test-suite Z-MessagePack-Test - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test/ - build-depends: base - , Z-IO - , Z-Data - , Z-MessagePack - , hspec >= 2.5.4 - , hashable - , unordered-containers - , containers - , HUnit - , QuickCheck >= 2.10 - , quickcheck-instances - , scientific - , primitive - , time - - other-modules: Z.Data.MessagePack.BaseSpec - - ghc-options: -threaded - default-language: Haskell2010 - build-tool-depends: hspec-discover:hspec-discover == 2.* + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test/ + build-depends: + base + , containers + , hashable + , hspec >=2.5.4 + , HUnit + , primitive + , QuickCheck >=2.10 + , quickcheck-instances + , scientific + , time + , unordered-containers + , Z-Data + , Z-IO + , Z-MessagePack + other-modules: Z.Data.MessagePack.BaseSpec + ghc-options: -threaded + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover ==2.* diff --git a/Z/IO/RPC/MessagePack.hs b/Z/IO/RPC/MessagePack.hs --- a/Z/IO/RPC/MessagePack.hs +++ b/Z/IO/RPC/MessagePack.hs @@ -11,17 +11,21 @@ @ -- server +import Data.IORef import Z.IO.RPC.MessagePack import Z.IO.Network import Z.IO import qualified Z.Data.Text as T -serveRPC (startTCPServer defaultTCPServerConfig) . simpleRouter $ - [ ("foo", CallHandler $ \\ (req :: Int) -> do +newtype ServerCtx = ServerCtx { counter :: Int } + +serveRPC (startTCPServer defaultTCPServerConfig) (ServerCtx 0) $ simpleRouter + [ ("foo", CallHandler $ \\ ctx (req :: Int) -> do + modifyIORef ctx (ServerCtx . (+ 1) . counter) return (req + 1)) - , ("bar", NotifyHandler $ \\ (req :: T.Text) -> do + , ("bar", NotifyHandler $ \\ ctx (req :: T.Text) -> do printStd (req <> "world")) - , ("qux", StreamHandler $ \\ (_ :: ()) -> do + , ("qux", StreamHandler $ \\ ctx (_ :: ()) -> do withMVar stdinBuf (pure . sourceFromBuffered)) ] @@ -53,25 +57,25 @@ import Control.Concurrent import Control.Monad import Data.Bits -import Data.Int import Data.IORef -import Z.Data.PrimRef.PrimIORef -import qualified Z.Data.MessagePack.Builder as MB -import qualified Z.Data.MessagePack.Value as MV +import Data.Int import Z.Data.MessagePack (MessagePack) import qualified Z.Data.MessagePack as MP +import qualified Z.Data.MessagePack.Builder as MB +import qualified Z.Data.MessagePack.Value as MV import qualified Z.Data.Parser as P +import Z.Data.PrimRef.PrimIORef import qualified Z.Data.Text as T +import qualified Z.Data.Vector as V import qualified Z.Data.Vector.FlatIntMap as FIM import qualified Z.Data.Vector.FlatMap as FM -import qualified Z.Data.Vector as V import Z.IO import Z.IO.Network data Client = Client - { _clientSeqRef :: Counter + { _clientSeqRef :: Counter , _clientPipelineReqNum :: Counter - , _clientBufferedInput :: BufferedInput + , _clientBufferedInput :: BufferedInput , _clientBufferedOutput :: BufferedOutput } @@ -168,14 +172,14 @@ tag <- P.anyWord8 when (tag /= 0x94) (P.fail' $ "wrong response tag: " <> T.toText tag) !typ <- MV.value - !seq <- MV.value + !seq_ <- MV.value !err <- MV.value !v <- MV.value case typ of - MV.Int 1 -> case seq of + MV.Int 1 -> case seq_ of MV.Int msgid | msgid >= 0 && msgid <= 0xFFFFFFFF -> return (msgid, err, v) - _ -> P.fail' $ "wrong msgid: " <> T.toText seq + _ -> P.fail' $ "wrong msgid: " <> T.toText seq_ _ -> P.fail' $ "wrong response type: " <> T.toText typ ) bi when (err /= MV.Nil) $ throwIO (RPCException err callStack) @@ -242,7 +246,7 @@ ) bi) -- we take tcp disconnect as eof too - case (join res) of + case join res of Just (err, v) -> do when (err /= MV.Nil) $ throwIO (RPCException err callStack) unwrap "EPARSE" (MP.convertValue v) @@ -260,11 +264,15 @@ -------------------------------------------------------------------------------- type ServerLoop = (UVStream -> IO ()) -> IO () -type ServerService = T.Text -> Maybe ServerHandler -data ServerHandler where - CallHandler :: (MessagePack req, MessagePack res) => (req -> IO res) -> ServerHandler - NotifyHandler :: MessagePack req => (req -> IO ()) -> ServerHandler - StreamHandler :: (MessagePack req, MessagePack res) => (req -> IO (Source res)) -> ServerHandler +type ServerService a = T.Text -> Maybe (ServerHandler a) +type ServerCtx a = IORef a +data ServerHandler a where + CallHandler :: (MessagePack req, MessagePack res) + => (ServerCtx a -> req -> IO res) -> ServerHandler a + NotifyHandler :: MessagePack req + => (ServerCtx a -> req -> IO ()) -> ServerHandler a + StreamHandler :: (MessagePack req, MessagePack res) + => (ServerCtx a -> req -> IO (Source res)) -> ServerHandler a -- | Simple router using `FlatMap`, lookup name in /O(log(N))/. -- @@ -274,21 +282,23 @@ -- import Z.IO -- -- serveRPC (startTCPServer defaultTCPServerConfig) . simpleRouter $ --- [ ("foo", CallHandler $ \\ req -> do +-- [ ("foo", CallHandler $ \\ ctx req -> do -- ... ) --- , ("bar", CallHandler $ \\ req -> do +-- , ("bar", CallHandler $ \\ ctx req -> do -- ... ) -- ] -- -- @ -simpleRouter :: [(T.Text, ServerHandler)] -> ServerService +simpleRouter :: [(T.Text, ServerHandler a)] -> ServerService a simpleRouter handles name = FM.lookup name handleMap where handleMap = FM.packR handles -- | Serve a RPC service. -serveRPC :: ServerLoop -> ServerService -> IO () -serveRPC serve = serveRPC' serve V.defaultChunkSize V.defaultChunkSize +serveRPC :: ServerLoop -> a -> ServerService a -> IO () +serveRPC serve ctxData service = do + ctxRef <- newIORef ctxData + serveRPC' serve V.defaultChunkSize V.defaultChunkSize ctxRef service data Request a = Notify (T.Text, a) @@ -300,8 +310,9 @@ serveRPC' :: ServerLoop -> Int -- ^ recv buffer size -> Int -- ^ send buffer size - -> ServerService -> IO () -serveRPC' serve recvBufSiz sendBufSiz handle = serve $ \ uvs -> do + -> ServerCtx a + -> ServerService a -> IO () +serveRPC' serve recvBufSiz sendBufSiz ctx handle = serve $ \ uvs -> do bi <- newBufferedInput' recvBufSiz uvs bo <- newBufferedOutput' sendBufSiz uvs loop bi bo @@ -326,30 +337,29 @@ -- call 0x94 -> do !typ <- MV.value - !seq <- MV.value + !seq_ <- MV.value !name <- MV.value !v <- MV.value case typ of - MV.Int 0 -> case seq of + MV.Int 0 -> case seq_ of MV.Int msgid | msgid >= 0 && msgid <= 0xFFFFFFFF -> case name of MV.Str name' -> return (Call (msgid, name', v)) _ -> P.fail' $ "wrong RPC name: " <> T.toText name - _ -> P.fail' $ "wrong msgid: " <> T.toText seq + _ -> P.fail' $ "wrong msgid: " <> T.toText seq_ _ -> P.fail' $ "wrong request type: " <> T.toText typ _ -> P.fail' $ "wrong request tag: " <> T.toText tag ) bi) - print req case req of Just (Notify (name, v)) -> do case handle name of Just (NotifyHandler f) -> do - f =<< unwrap "EPARSE" (MP.convertValue v) + f ctx =<< unwrap "EPARSE" (MP.convertValue v) _ -> throwOtherError "ENOTFOUND" "notification method not found" loop bi bo Just (Call (msgid, name, v)) -> do case handle name of Just (CallHandler f) -> do - res <- try (f =<< unwrap "EPARSE" (MP.convertValue v)) + res <- try (f ctx =<< unwrap "EPARSE" (MP.convertValue v)) writeBuilder bo $ do MB.arrayHeader 4 MB.int 1 -- type response @@ -388,7 +398,7 @@ case handle name of Just (StreamHandler f) -> do - src <- f =<< unwrap "EPARSE" (MP.convertValue v) + src <- f ctx =<< unwrap "EPARSE" (MP.convertValue v) loopSend eofRef src bo _ -> do writeBuilder bo $ do