Z-MessagePack 0.3.0.1 → 0.4.0.0
raw patch · 3 files changed
+142/−135 lines, 3 filesdep ~Z-Datadep ~Z-IOnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Z-Data, Z-IO
API changes (from Hackage documentation)
+ Z.IO.RPC.MessagePack: type ServerCtx a = IORef a
- Z.IO.RPC.MessagePack: [CallHandler] :: (MessagePack req, MessagePack res) => (req -> IO res) -> ServerHandler
+ Z.IO.RPC.MessagePack: [CallHandler] :: (MessagePack req, MessagePack res) => (ServerCtx a -> req -> IO res) -> ServerHandler a
- Z.IO.RPC.MessagePack: [NotifyHandler] :: MessagePack req => (req -> IO ()) -> ServerHandler
+ Z.IO.RPC.MessagePack: [NotifyHandler] :: MessagePack req => (ServerCtx a -> req -> IO ()) -> ServerHandler a
- Z.IO.RPC.MessagePack: [StreamHandler] :: (MessagePack req, MessagePack res) => (req -> IO (Source res)) -> ServerHandler
+ Z.IO.RPC.MessagePack: [StreamHandler] :: (MessagePack req, MessagePack res) => (ServerCtx a -> req -> IO (Source res)) -> ServerHandler a
- Z.IO.RPC.MessagePack: data ServerHandler
+ Z.IO.RPC.MessagePack: data ServerHandler a
- Z.IO.RPC.MessagePack: serveRPC :: ServerLoop -> ServerService -> IO ()
+ Z.IO.RPC.MessagePack: serveRPC :: ServerLoop -> a -> ServerService a -> IO ()
- Z.IO.RPC.MessagePack: serveRPC' :: ServerLoop -> Int -> Int -> ServerService -> IO ()
+ Z.IO.RPC.MessagePack: serveRPC' :: ServerLoop -> Int -> Int -> ServerCtx a -> ServerService a -> IO ()
- Z.IO.RPC.MessagePack: simpleRouter :: [(Text, ServerHandler)] -> ServerService
+ Z.IO.RPC.MessagePack: simpleRouter :: [(Text, ServerHandler a)] -> ServerService a
- Z.IO.RPC.MessagePack: type ServerService = Text -> Maybe ServerHandler
+ Z.IO.RPC.MessagePack: type ServerService a = Text -> Maybe (ServerHandler a)
Files
- CHANGELOG.md +1/−1
- Z-MessagePack.cabal +97/−100
- Z/IO/RPC/MessagePack.hs +44/−34
CHANGELOG.md view
@@ -1,4 +1,4 @@-# Revision history for Z-Redis+# Revision history for Z-MessagePack ## 0.3.0.1 -- 2021-02-25
Z-MessagePack.cabal view
@@ -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.*
Z/IO/RPC/MessagePack.hs view
@@ -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