Z-MessagePack 0.1.0.0 → 0.3.0.0

raw patch · 7 files changed

+611/−294 lines, 7 filesdep ~Z-Datadep ~Z-IOdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Z-Data, Z-IO, base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−2
• Z-MessagePack.cabal +6/−4
• Z/Data/MessagePack.hs +255/−10
• Z/Data/MessagePack/Base.hs +40/−244
• Z/Data/MessagePack/Builder.hs +32/−32
• Z/Data/MessagePack/Value.hs +1/−2
• Z/IO/RPC/MessagePack.hs +272/−0

@@ -1,5 +1,8 @@ # Revision history for Z-Redis -## 0.1.0.0 -- YYYY-mm-dd+## 0.3.0.0 -- 2021-02-25 -* First version. Released on an unsuspecting world.+* Add `Z.IO.RPC.MessagePack` module.+* Move some instances to `Z.Data.MessagePack` to make package buildable under constrained memory.+* Remove `decodeChunks'`.+* Change `Data.Version.Version`'s instance to use array.

@@ -1,6 +1,6 @@ cabal-version:              >=1.10 name:                       Z-MessagePack-version:                    0.1.0.0+version:                    0.3.0.0 synopsis:                   MessagePack description:                MessagePack binary serialization format. license:                    BSD3@@ -20,10 +20,11 @@                             Z.Data.MessagePack.Base                             Z.Data.MessagePack.Builder                             Z.Data.MessagePack.Value+                            Z.IO.RPC.MessagePack      -- other-modules:     -- other-extensions:-    build-depends:            base                      >=4.14 && <4.15+    build-depends:            base                      >= 4.12 && <5                             , deepseq                   >= 1.4 && < 1.5                             , primitive                 >= 0.7.1 && < 0.7.2                             , QuickCheck                >= 2.10@@ -34,8 +35,8 @@                             , integer-gmp               == 1.*                             , tagged                    == 0.8.*                             , time                      >= 1.9 && < 2.0-                            , Z-Data                    == 0.4.*-                            , Z-IO                      == 0.4.*+                            , Z-Data                    == 0.6.*+                            , Z-IO                      == 0.6.*      -- hs-source-dirs:     default-language:    Haskell2010@@ -52,6 +53,7 @@                             ExistentialQuantification                             FlexibleContexts                             FlexibleInstances+                            GADTs                             GeneralizedNewtypeDeriving                              KindSignatures                             MagicHash

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+ {-| Module      : Z.Data.MessagePack Description : Fast MessagePack serialization/deserialization@@ -7,7 +9,7 @@ Stability   : experimental Portability : non-portable -This module provides an interface similar to 'Z.Data.JSON', to work with MessagePack binary format.+This module provides an interface similar to "Z.Data.JSON", to work with MessagePack binary format.    * @Maybe a@ convert to 'Nil' in 'Nothing' case, and @a@ in 'Just' case.   * Use 'Int64'(signed) or 'Word64'(unsigned) type to marshall int type format, smaller types will sliently truncate when overflow.@@ -43,7 +45,7 @@     deriving (Show, Generic)     deriving anyclass (MessagePack.MessagePack) -> MessagePack.encode Person{ name="Alice", age=16 }+> MessagePack.encode Person{ name=\"Alice\", age=16 } > [130,164,110,97,109,101,165,65,108,105,99,101,163,97,103,101,16] @ @@ -56,8 +58,7 @@ >  2kvs   4bytes                            5bytes                                  3bytes  -This property makes it suitable for passing data across language boundary, e.g. from a static typed language to a dynamic one,-at the cost of a lower space efficiency(i.e. type tag and field label).+This property makes it suitable for passing data across language boundary, e.g. from a static typed language to a dynamic one, at the cost of a lower space efficiency(i.e. type tag and field label).  -} @@ -66,7 +67,7 @@     MessagePack(..), Value(..), defaultSettings, Settings(..), JSON.snakeCase, JSON.trainCase     -- * Encode & Decode   , readMessagePackFile, writeMessagePackFile-  , decode, decode', decodeChunks, decodeChunks', encode, encodeChunks+  , decode, decode', decodeChunks, encode, encodeChunks   , DecodeError, ParseError     -- * parse into MessagePack Value   , parseValue, parseValue', parseValueChunks, parseValueChunks'@@ -82,16 +83,260 @@   , (.=), object, (.!), object', KVItem   ) where -import Z.Data.MessagePack.Base-import qualified Z.Data.JSON    as JSON-import Z.Data.CBytes            (CBytes)-import Z.IO+import           Data.Char+import           Data.Functor.Compose+import           Data.Functor.Const+import           Data.Functor.Identity+import           Data.Functor.Product+import           Data.Functor.Sum+import qualified Data.Monoid                    as Monoid+import           Data.Proxy                     (Proxy (..))+import           Data.Scientific                (Scientific, toBoundedInteger)+import qualified Data.Semigroup                 as Semigroup+import           Data.Tagged                    (Tagged (..))+import           Data.Time                      (Day, DiffTime, LocalTime, NominalDiffTime,+                                                TimeOfDay, UTCTime, ZonedTime)+import           Data.Time.Calendar             (CalendarDiffDays (..), DayOfWeek (..))+import           Data.Time.LocalTime            (CalendarDiffTime (..))+import           Data.Time.Clock.System         (SystemTime (..), utcToSystemTime, systemToUTCTime)+import           Data.Version                   (Version(versionBranch), makeVersion)+import           Foreign.C.Types+import           System.Exit                    (ExitCode(..))+import qualified Z.Data.Builder                 as B+import           Z.Data.MessagePack.Base+import qualified Z.Data.MessagePack.Builder     as MB+import qualified Z.Data.JSON                    as JSON+import qualified Z.Data.Parser                  as P+import qualified Z.Data.Text                    as T+import           Z.Data.CBytes            (CBytes)+import           Z.IO import qualified Z.IO.FileSystem as FS  -- | Decode a 'MessagePack' instance from file. readMessagePackFile :: (HasCallStack, MessagePack a) => CBytes -> IO a-readMessagePackFile p = unwrap . decode' =<< FS.readFile p+readMessagePackFile p = unwrap "EPARSE" . decode' =<< FS.readFile p  -- | Encode a 'MessagePack' instance to file. writeMessagePackFile :: (HasCallStack, MessagePack a) => CBytes -> a -> IO () writeMessagePackFile p x = FS.writeFile p (encode x)++--------------------------------------------------------------------------------++instance MessagePack ExitCode where+    {-# INLINE fromValue #-}+    fromValue (Str "ExitSuccess") = return ExitSuccess+    fromValue (Int x) = return (ExitFailure (fromIntegral x))+    fromValue _ =  fail' "converting ExitCode failed, expected a string or number"++    {-# INLINE toValue #-}+    toValue ExitSuccess     = Str "ExitSuccess"+    toValue (ExitFailure n) = Int (fromIntegral n)++    {-# INLINE encodeMessagePack #-}+    encodeMessagePack ExitSuccess     = MB.str "ExitSuccess"+    encodeMessagePack (ExitFailure n) = B.int n++-- | Only round trip 'versionBranch' as MessagePack array.+instance MessagePack Version where+    {-# INLINE fromValue #-}+    fromValue v = makeVersion <$> fromValue v+    {-# INLINE toValue #-}+    toValue = toValue . versionBranch+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack = encodeMessagePack . versionBranch++--------------------------------------------------------------------------------++-- | MessagePack extension type @Ext 0xFF@+instance MessagePack UTCTime where+    {-# INLINE fromValue #-}+    fromValue = withSystemTime "UTCTime" $ pure . systemToUTCTime+    {-# INLINE toValue #-}+    toValue t = let (MkSystemTime s ns) = utcToSystemTime t in MB.timestampValue s (fromIntegral ns)+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack t = let (MkSystemTime s ns) = utcToSystemTime t in MB.timestamp s (fromIntegral ns)++-- | MessagePack extension type @Ext 0xFF@+instance MessagePack SystemTime where+    {-# INLINE fromValue #-}+    fromValue = withSystemTime "UTCTime" $ pure+    {-# INLINE toValue #-}+    toValue (MkSystemTime s ns) = MB.timestampValue s (fromIntegral ns)+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack (MkSystemTime s ns) = MB.timestamp s (fromIntegral ns)++-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@+instance MessagePack ZonedTime where+    {-# INLINE fromValue #-}+    fromValue = withStr "ZonedTime" $ \ t ->+        case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of+            Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err+            Right r  -> return r+    {-# INLINE toValue #-}+    toValue t = Str (B.unsafeBuildText (B.zonedTime t))+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack t = MB.str (B.unsafeBuildText (B.zonedTime t))++-- | @YYYY-MM-DD@+instance MessagePack Day where+    {-# INLINE fromValue #-}+    fromValue = withStr "Day" $ \ t ->+        case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of+            Left err -> fail' $ "could not parse date as Day: " <> T.toText err+            Right r  -> return r+    {-# INLINE toValue #-}+    toValue t = Str (B.unsafeBuildText (B.day t))+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack t = MB.str (B.unsafeBuildText (B.day t))++-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@+instance MessagePack LocalTime where+    {-# INLINE fromValue #-}+    fromValue = withStr "LocalTime" $ \ t ->+        case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of+            Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err+            Right r  -> return r+    {-# INLINE toValue #-}+    toValue t = Str (B.unsafeBuildText (B.localTime t))+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack t = MB.str (B.unsafeBuildText (B.localTime t))++-- | @HH:MM:SS.SSS@+instance MessagePack TimeOfDay where+    {-# INLINE fromValue #-}+    fromValue = withStr "TimeOfDay" $ \ t ->+        case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of+            Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err+            Right r  -> return r+    {-# INLINE toValue #-}+    toValue t = Str (B.unsafeBuildText (B.timeOfDay t))+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack t = MB.str (B.unsafeBuildText (B.timeOfDay t))++-- | This instance includes a bounds check to prevent maliciously+-- large inputs to fill up the memory of the target system. You can+-- newtype 'NominalDiffTime' and provide your own instance using+-- 'withScientific' if you want to allow larger inputs.+instance MessagePack NominalDiffTime where+    {-# INLINE fromValue #-}+    fromValue = withBoundedScientific "NominalDiffTime" $ pure . realToFrac+    {-# INLINE toValue #-}+    toValue = toValue @Scientific . realToFrac+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack = encodeMessagePack @Scientific . realToFrac++-- | This instance includes a bounds check to prevent maliciously+-- large inputs to fill up the memory of the target system. You can+-- newtype 'DiffTime' and provide your own instance using+-- 'withScientific' if you want to allow larger inputs.+instance MessagePack DiffTime where+    {-# INLINE fromValue #-}+    fromValue = withBoundedScientific "DiffTime" $ pure . realToFrac+    {-# INLINE toValue #-}+    toValue = toValue @Scientific . realToFrac+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack = encodeMessagePack @Scientific . realToFrac++instance MessagePack CalendarDiffTime where+    {-# INLINE fromValue #-}+    fromValue = withFlatMapR "CalendarDiffTime" $ \ v ->+        CalendarDiffTime <$> v .: "months" <*> v .: "time"+    {-# INLINE toValue #-}+    toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ]+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack (CalendarDiffTime m nt) = object' ("months" .! m <> "time" .! nt)++instance MessagePack CalendarDiffDays where+    {-# INLINE fromValue #-}+    fromValue = withFlatMapR "CalendarDiffDays" $ \ v ->+        CalendarDiffDays <$> v .: "months" <*> v .: "days"+    {-# INLINE toValue #-}+    toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d]+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack (CalendarDiffDays m d) = object' ("months" .! m <> "days" .! d)++instance MessagePack DayOfWeek where+    {-# INLINE fromValue #-}+    fromValue (Str "monday"   ) = pure Monday+    fromValue (Str "tuesday"  ) = pure Tuesday+    fromValue (Str "wednesday") = pure Wednesday+    fromValue (Str "thursday" ) = pure Thursday+    fromValue (Str "friday"   ) = pure Friday+    fromValue (Str "saturday" ) = pure Saturday+    fromValue (Str "sunday"   ) = pure Sunday+    fromValue (Str _   )        = fail' "converting DayOfWeek failed, value should be one of weekdays"+    fromValue v                 = typeMismatch "DayOfWeek" "String" v+    {-# INLINE toValue #-}+    toValue Monday    = Str "monday"+    toValue Tuesday   = Str "tuesday"+    toValue Wednesday = Str "wednesday"+    toValue Thursday  = Str "thursday"+    toValue Friday    = Str "friday"+    toValue Saturday  = Str "saturday"+    toValue Sunday    = Str "sunday"+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack Monday    = MB.str "monday"+    encodeMessagePack Tuesday   = MB.str "tuesday"+    encodeMessagePack Wednesday = MB.str "wednesday"+    encodeMessagePack Thursday  = MB.str "thursday"+    encodeMessagePack Friday    = MB.str "friday"+    encodeMessagePack Saturday  = MB.str "saturday"+    encodeMessagePack Sunday    = MB.str "sunday"+++--------------------------------------------------------------------------------++deriving newtype instance MessagePack (f (g a)) => MessagePack (Compose f g a)+deriving newtype instance MessagePack a => MessagePack (Semigroup.Min a)+deriving newtype instance MessagePack a => MessagePack (Semigroup.Max a)+deriving newtype instance MessagePack a => MessagePack (Semigroup.First a)+deriving newtype instance MessagePack a => MessagePack (Semigroup.Last a)+deriving newtype instance MessagePack a => MessagePack (Semigroup.WrappedMonoid a)+deriving newtype instance MessagePack a => MessagePack (Semigroup.Dual a)+deriving newtype instance MessagePack a => MessagePack (Monoid.First a)+deriving newtype instance MessagePack a => MessagePack (Monoid.Last a)+deriving newtype instance MessagePack a => MessagePack (Identity a)+deriving newtype instance MessagePack a => MessagePack (Const a b)+deriving newtype instance MessagePack b => MessagePack (Tagged a b)++--------------------------------------------------------------------------------++deriving newtype instance MessagePack CChar+deriving newtype instance MessagePack CSChar+deriving newtype instance MessagePack CUChar+deriving newtype instance MessagePack CShort+deriving newtype instance MessagePack CUShort+deriving newtype instance MessagePack CInt+deriving newtype instance MessagePack CUInt+deriving newtype instance MessagePack CLong+deriving newtype instance MessagePack CULong+deriving newtype instance MessagePack CPtrdiff+deriving newtype instance MessagePack CSize+deriving newtype instance MessagePack CWchar+deriving newtype instance MessagePack CSigAtomic+deriving newtype instance MessagePack CLLong+deriving newtype instance MessagePack CULLong+deriving newtype instance MessagePack CBool+deriving newtype instance MessagePack CIntPtr+deriving newtype instance MessagePack CUIntPtr+deriving newtype instance MessagePack CIntMax+deriving newtype instance MessagePack CUIntMax+deriving newtype instance MessagePack CClock+deriving newtype instance MessagePack CTime+deriving newtype instance MessagePack CUSeconds+deriving newtype instance MessagePack CSUSeconds+deriving newtype instance MessagePack CFloat+deriving newtype instance MessagePack CDouble++--------------------------------------------------------------------------------++deriving anyclass instance (MessagePack (f a), MessagePack (g a), MessagePack a) => MessagePack (Sum f g a)+deriving anyclass instance (MessagePack a, MessagePack b) => MessagePack (Either a b)+deriving anyclass instance (MessagePack (f a), MessagePack (g a)) => MessagePack (Product f g a)++deriving anyclass instance (MessagePack a, MessagePack b) => MessagePack (a, b)+deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c) => MessagePack (a, b, c)+deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d) => MessagePack (a, b, c, d)+deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d, MessagePack e) => MessagePack (a, b, c, d, e)+deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d, MessagePack e, MessagePack f) => MessagePack (a, b, c, d, e, f)+deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d, MessagePack e, MessagePack f, MessagePack g) => MessagePack (a, b, c, d, e, f, g)

@@ -7,7 +7,7 @@ Stability   : experimental Portability : non-portable -This module provides 'Converter' to convert 'Value' to haskell data types, and various tools to help user define 'MessagePack' instance.+This module provides various tools to help user define 'MessagePack' instance, please import `Z.Data.MessagePack` to get more instances.  -} @@ -15,8 +15,8 @@   ( -- * MessagePack Class     MessagePack(..), Value(..), defaultSettings, Settings(..)     -- * Encode & Decode-  , decode, decode', decodeChunks, decodeChunks', encode, encodeChunks-  , DecodeError, P.ParseError+  , decode, decode', decodeChunks, encode, encodeChunks+  , DecodeError, P.ParseError, P.ParseChunks     -- * parse into MessagePack Value   , MV.parseValue, MV.parseValue', MV.parseValueChunks, MV.parseValueChunks'   -- * Generic FromValue, ToValue & EncodeMessagePack@@ -26,6 +26,7 @@   , PathElement(..), ConvertError(..)   , typeMismatch, fromNil, withBool   , withStr, withBin, withArray, withKeyValues, withFlatMap, withFlatMapR+  , withBoundedScientific, withSystemTime   , (.:), (.:?), (.:!), convertField, convertFieldMaybe, convertFieldMaybe'   -- * Helper for manually writing instance.   , (.=), object, (.!), object', KVItem@@ -81,6 +82,7 @@ import           Text.ParserCombinators.ReadP   (readP_to_S) import qualified Z.Data.Array                   as A import qualified Z.Data.Builder                 as B+import qualified Z.Data.CBytes                  as CBytes import           Z.Data.Generics.Utils import           Z.Data.JSON.Converter import qualified Z.Data.MessagePack.Builder     as MB@@ -155,18 +157,6 @@                 Left cErr -> pure (bs', Left (Right cErr))                 Right r   -> pure (bs', Right r) --- | Decode MessagePack doc chunks, trailing bytes are not allowed.-decodeChunks' :: (MessagePack a, Monad m) => m V.Bytes -> V.Bytes -> m (Either DecodeError a)-{-# INLINE decodeChunks' #-}-decodeChunks' mb bs = do-    mr <- P.parseChunks (MV.value <* P.endOfInput) mb bs-    case mr of-        (_, Left pErr) -> pure (Left (Left pErr))-        (_, Right v) ->-            case convertValue v of-                Left cErr -> pure (Left (Right cErr))-                Right r   -> pure (Right r)- -- | Directly encode data to MessagePack bytes. encode :: MessagePack a => a -> V.Bytes {-# INLINE encode #-}@@ -996,6 +986,24 @@     {-# INLINE encodeMessagePack #-}     encodeMessagePack = MB.array encodeMessagePack +-- | This is an INCOHERENT instance, write 'Bytes' as Bin.+instance {-# INCOHERENT #-} MessagePack V.Bytes where+    {-# INLINE fromValue #-}+    fromValue = withBin "Z.Data.Vector.Bytes" pure+    {-# INLINE toValue #-}+    toValue = Bin+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack = MB.bin++-- | Write 'CBytes' as Bin not Str.+instance MessagePack CBytes.CBytes where+    {-# INLINE fromValue #-}+    fromValue = withBin "Z.Data.CBytes" (pure . CBytes.fromBytes)+    {-# INLINE toValue #-}+    toValue = Bin . CBytes.toBytes+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack = MB.bin . CBytes.toBytes+ instance MessagePack a => MessagePack (V.Vector a) where     {-# INLINE fromValue #-}     fromValue = withArray "Z.Data.Vector.Vector"@@ -1024,6 +1032,15 @@     {-# INLINE encodeMessagePack #-}     encodeMessagePack = MB.array' encodeMessagePack +-- | This is an INCOHERENT instance, encode 'String' with 'Str'.+instance {-# INCOHERENT #-} MessagePack String where+    {-# INLINE fromValue #-}+    fromValue = withStr "String" (pure . T.unpack)+    {-# INLINE toValue #-}+    toValue = Str . T.pack+    {-# INLINE encodeMessagePack #-}+    encodeMessagePack = MB.str . T.pack+ instance MessagePack a => MessagePack (NonEmpty a) where     {-# INLINE fromValue #-}     fromValue = withArray "NonEmpty" $ \ vs -> do@@ -1071,16 +1088,16 @@     instance MessagePack typ where \         {-# INLINE fromValue #-}; \             fromValue (Int x) = pure $! fromIntegral x; \-            fromValue v = typeMismatch "##typ##" "Int" v; \+            fromValue v = typeMismatch " typ " "Int" v; \         {-# INLINE toValue #-}; toValue = Int . fromIntegral; \         {-# INLINE encodeMessagePack #-}; encodeMessagePack = MB.int . fromIntegral;-INT_MessagePack_INSTANCE(Int   )-INT_MessagePack_INSTANCE(Int8  )-INT_MessagePack_INSTANCE(Int16 )-INT_MessagePack_INSTANCE(Int32 )-INT_MessagePack_INSTANCE(Int64 )-INT_MessagePack_INSTANCE(Word  )-INT_MessagePack_INSTANCE(Word8 )+INT_MessagePack_INSTANCE(Int)+INT_MessagePack_INSTANCE(Int8)+INT_MessagePack_INSTANCE(Int16)+INT_MessagePack_INSTANCE(Int32)+INT_MessagePack_INSTANCE(Int64)+INT_MessagePack_INSTANCE(Word)+INT_MessagePack_INSTANCE(Word8) INT_MessagePack_INSTANCE(Word16) INT_MessagePack_INSTANCE(Word32) INT_MessagePack_INSTANCE(Word64)@@ -1152,32 +1169,6 @@     {-# INLINE encodeMessagePack #-}     encodeMessagePack () = MB.arrayHeader 0 -instance MessagePack ExitCode where-    {-# INLINE fromValue #-}-    fromValue (Str "ExitSuccess") = return ExitSuccess-    fromValue (Int x) = return (ExitFailure (fromIntegral x))-    fromValue _ =  fail' "converting ExitCode failed, expected a string or number"--    {-# INLINE toValue #-}-    toValue ExitSuccess     = Str "ExitSuccess"-    toValue (ExitFailure n) = Int (fromIntegral n)--    {-# INLINE encodeMessagePack #-}-    encodeMessagePack ExitSuccess     = MB.str "ExitSuccess"-    encodeMessagePack (ExitFailure n) = B.int n--instance MessagePack Version where-    {-# INLINE fromValue #-}-    fromValue = withStr "Version" (go . readP_to_S parseVersion . T.unpack)-      where-        go [(v,[])] = pure v-        go (_ : xs) = go xs-        go _        = fail "converting Version failed"-    {-# INLINE toValue #-}-    toValue = Str . T.pack . show-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack = MB.str' . show- instance MessagePack a => MessagePack (Maybe a) where     {-# INLINE fromValue #-}     fromValue Nil = pure Nothing@@ -1213,198 +1204,3 @@     toValue = toValue @Scientific . realToFrac     {-# INLINE encodeMessagePack #-}     encodeMessagePack = encodeMessagePack @Scientific . realToFrac-------------------------------------------------------------------------------------- | MessagePack extension type @Ext 0xFF@-instance MessagePack UTCTime where-    {-# INLINE fromValue #-}-    fromValue = withSystemTime "UTCTime" $ pure . systemToUTCTime-    {-# INLINE toValue #-}-    toValue t = let (MkSystemTime s ns) = utcToSystemTime t in MB.timestampValue s (fromIntegral ns)-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack t = let (MkSystemTime s ns) = utcToSystemTime t in MB.timestamp s (fromIntegral ns)---- | MessagePack extension type @Ext 0xFF@-instance MessagePack SystemTime where-    {-# INLINE fromValue #-}-    fromValue = withSystemTime "UTCTime" $ pure-    {-# INLINE toValue #-}-    toValue (MkSystemTime s ns) = MB.timestampValue s (fromIntegral ns)-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack (MkSystemTime s ns) = MB.timestamp s (fromIntegral ns)---- | @YYYY-MM-DDTHH:MM:SS.SSSZ@-instance MessagePack ZonedTime where-    {-# INLINE fromValue #-}-    fromValue = withStr "ZonedTime" $ \ t ->-        case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of-            Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err-            Right r  -> return r-    {-# INLINE toValue #-}-    toValue t = Str (B.unsafeBuildText (B.zonedTime t))-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack t = MB.str (B.unsafeBuildText (B.zonedTime t))---- | @YYYY-MM-DD@-instance MessagePack Day where-    {-# INLINE fromValue #-}-    fromValue = withStr "Day" $ \ t ->-        case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of-            Left err -> fail' $ "could not parse date as Day: " <> T.toText err-            Right r  -> return r-    {-# INLINE toValue #-}-    toValue t = Str (B.unsafeBuildText (B.day t))-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack t = MB.str (B.unsafeBuildText (B.day t))---- | @YYYY-MM-DDTHH:MM:SS.SSSZ@-instance MessagePack LocalTime where-    {-# INLINE fromValue #-}-    fromValue = withStr "LocalTime" $ \ t ->-        case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of-            Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err-            Right r  -> return r-    {-# INLINE toValue #-}-    toValue t = Str (B.unsafeBuildText (B.localTime t))-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack t = MB.str (B.unsafeBuildText (B.localTime t))---- | @HH:MM:SS.SSS@-instance MessagePack TimeOfDay where-    {-# INLINE fromValue #-}-    fromValue = withStr "TimeOfDay" $ \ t ->-        case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of-            Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err-            Right r  -> return r-    {-# INLINE toValue #-}-    toValue t = Str (B.unsafeBuildText (B.timeOfDay t))-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack t = MB.str (B.unsafeBuildText (B.timeOfDay t))---- | This instance includes a bounds check to prevent maliciously--- large inputs to fill up the memory of the target system. You can--- newtype 'NominalDiffTime' and provide your own instance using--- 'withScientific' if you want to allow larger inputs.-instance MessagePack NominalDiffTime where-    {-# INLINE fromValue #-}-    fromValue = withBoundedScientific "NominalDiffTime" $ pure . realToFrac-    {-# INLINE toValue #-}-    toValue = toValue @Scientific . realToFrac-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack = encodeMessagePack @Scientific . realToFrac---- | This instance includes a bounds check to prevent maliciously--- large inputs to fill up the memory of the target system. You can--- newtype 'DiffTime' and provide your own instance using--- 'withScientific' if you want to allow larger inputs.-instance MessagePack DiffTime where-    {-# INLINE fromValue #-}-    fromValue = withBoundedScientific "DiffTime" $ pure . realToFrac-    {-# INLINE toValue #-}-    toValue = toValue @Scientific . realToFrac-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack = encodeMessagePack @Scientific . realToFrac--instance MessagePack CalendarDiffTime where-    {-# INLINE fromValue #-}-    fromValue = withFlatMapR "CalendarDiffTime" $ \ v ->-        CalendarDiffTime <$> v .: "months" <*> v .: "time"-    {-# INLINE toValue #-}-    toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ]-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack (CalendarDiffTime m nt) = object' ("months" .! m <> "time" .! nt)--instance MessagePack CalendarDiffDays where-    {-# INLINE fromValue #-}-    fromValue = withFlatMapR "CalendarDiffDays" $ \ v ->-        CalendarDiffDays <$> v .: "months" <*> v .: "days"-    {-# INLINE toValue #-}-    toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d]-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack (CalendarDiffDays m d) = object' ("months" .! m <> "days" .! d)--instance MessagePack DayOfWeek where-    {-# INLINE fromValue #-}-    fromValue (Str "monday"   ) = pure Monday-    fromValue (Str "tuesday"  ) = pure Tuesday-    fromValue (Str "wednesday") = pure Wednesday-    fromValue (Str "thursday" ) = pure Thursday-    fromValue (Str "friday"   ) = pure Friday-    fromValue (Str "saturday" ) = pure Saturday-    fromValue (Str "sunday"   ) = pure Sunday-    fromValue (Str _   )        = fail' "converting DayOfWeek failed, value should be one of weekdays"-    fromValue v                 = typeMismatch "DayOfWeek" "String" v-    {-# INLINE toValue #-}-    toValue Monday    = Str "monday"-    toValue Tuesday   = Str "tuesday"-    toValue Wednesday = Str "wednesday"-    toValue Thursday  = Str "thursday"-    toValue Friday    = Str "friday"-    toValue Saturday  = Str "saturday"-    toValue Sunday    = Str "sunday"-    {-# INLINE encodeMessagePack #-}-    encodeMessagePack Monday    = MB.str "monday"-    encodeMessagePack Tuesday   = MB.str "tuesday"-    encodeMessagePack Wednesday = MB.str "wednesday"-    encodeMessagePack Thursday  = MB.str "thursday"-    encodeMessagePack Friday    = MB.str "friday"-    encodeMessagePack Saturday  = MB.str "saturday"-    encodeMessagePack Sunday    = MB.str "sunday"------------------------------------------------------------------------------------deriving newtype instance MessagePack (f (g a)) => MessagePack (Compose f g a)-deriving newtype instance MessagePack a => MessagePack (Semigroup.Min a)-deriving newtype instance MessagePack a => MessagePack (Semigroup.Max a)-deriving newtype instance MessagePack a => MessagePack (Semigroup.First a)-deriving newtype instance MessagePack a => MessagePack (Semigroup.Last a)-deriving newtype instance MessagePack a => MessagePack (Semigroup.WrappedMonoid a)-deriving newtype instance MessagePack a => MessagePack (Semigroup.Dual a)-deriving newtype instance MessagePack a => MessagePack (Monoid.First a)-deriving newtype instance MessagePack a => MessagePack (Monoid.Last a)-deriving newtype instance MessagePack a => MessagePack (Identity a)-deriving newtype instance MessagePack a => MessagePack (Const a b)-deriving newtype instance MessagePack b => MessagePack (Tagged a b)------------------------------------------------------------------------------------deriving newtype instance MessagePack CChar-deriving newtype instance MessagePack CSChar-deriving newtype instance MessagePack CUChar-deriving newtype instance MessagePack CShort-deriving newtype instance MessagePack CUShort-deriving newtype instance MessagePack CInt-deriving newtype instance MessagePack CUInt-deriving newtype instance MessagePack CLong-deriving newtype instance MessagePack CULong-deriving newtype instance MessagePack CPtrdiff-deriving newtype instance MessagePack CSize-deriving newtype instance MessagePack CWchar-deriving newtype instance MessagePack CSigAtomic-deriving newtype instance MessagePack CLLong-deriving newtype instance MessagePack CULLong-deriving newtype instance MessagePack CBool-deriving newtype instance MessagePack CIntPtr-deriving newtype instance MessagePack CUIntPtr-deriving newtype instance MessagePack CIntMax-deriving newtype instance MessagePack CUIntMax-deriving newtype instance MessagePack CClock-deriving newtype instance MessagePack CTime-deriving newtype instance MessagePack CUSeconds-deriving newtype instance MessagePack CSUSeconds-deriving newtype instance MessagePack CFloat-deriving newtype instance MessagePack CDouble------------------------------------------------------------------------------------deriving anyclass instance (MessagePack (f a), MessagePack (g a), MessagePack a) => MessagePack (Sum f g a)-deriving anyclass instance (MessagePack a, MessagePack b) => MessagePack (Either a b)-deriving anyclass instance (MessagePack (f a), MessagePack (g a)) => MessagePack (Product f g a)--deriving anyclass instance (MessagePack a, MessagePack b) => MessagePack (a, b)-deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c) => MessagePack (a, b, c)-deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d) => MessagePack (a, b, c, d)-deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d, MessagePack e) => MessagePack (a, b, c, d, e)-deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d, MessagePack e, MessagePack f) => MessagePack (a, b, c, d, e, f)-deriving anyclass instance (MessagePack a, MessagePack b, MessagePack c, MessagePack d, MessagePack e, MessagePack f, MessagePack g) => MessagePack (a, b, c, d, e, f, g)

@@ -5,7 +5,7 @@           , (c) Dong Han 2020 License   : BSD3 -'Builder's to encode in MessagePack format.+'Builder's to encode Haskell data types in MessagePack format.  -} @@ -51,24 +51,23 @@ int :: Int64 -> B.Builder () {-# INLINE int #-} int n-    | -0x20 <= n && n < 0x80         =  B.word8 (fromIntegral n)-    | 0     <= n && n < 0x100        =  B.word8 0xCC >> B.word8 (fromIntegral n)-    | 0     <= n && n < 0x10000      =  B.word8 0xCD >> B.encodePrimBE @Word16 (fromIntegral n)-    | 0     <= n && n < 0x100000000  =  B.word8 0xCE >> B.encodePrimBE @Word32 (fromIntegral n)-    | 0     <= n                     =  B.word8 0xCF >> B.encodePrimBE @Word64 (fromIntegral n)-    | -0x80 <= n                     =  B.word8 0xD0 >> B.word8 (fromIntegral n)-    | -0x8000 <= n                   =  B.word8 0xD1 >> B.encodePrimBE @Word16 (fromIntegral n)-    | -0x80000000 <= n               =  B.word8 0xD2 >> B.encodePrimBE @Word32 (fromIntegral n)-    | otherwise                      =  B.word8 0xD3 >> B.encodePrimBE @Word64 (fromIntegral n)+    | -0x20 <= n && n < 0x80         =  B.encodePrim (fromIntegral n :: Word8)+    | 0     <= n && n < 0x100        =  B.encodePrim (0xCC :: Word8, fromIntegral n :: Word8)+    | 0     <= n && n < 0x10000      =  B.encodePrim (0xCD :: Word8, BE (fromIntegral n :: Word16))+    | 0     <= n && n < 0x100000000  =  B.encodePrim (0xCE :: Word8, BE (fromIntegral n :: Word32))+    | 0     <= n                     =  B.encodePrim (0xCF :: Word8, BE (fromIntegral n :: Word64))+    | -0x80 <= n                     =  B.encodePrim (0xD0 :: Word8, fromIntegral n :: Word8)+    | -0x8000 <= n                   =  B.encodePrim (0xD1 :: Word8, BE (fromIntegral n :: Word16))+    | -0x80000000 <= n               =  B.encodePrim (0xD2 :: Word8, BE (fromIntegral n :: Word32))+    | otherwise                      =  B.encodePrim (0xD3 :: Word8, BE (fromIntegral n :: Word64))  float :: Float -> B.Builder () {-# INLINE float #-}-float f = B.word8 0xCA >> B.encodePrimBE f+float f = B.encodePrim (0xCA :: Word8, BE f)  double :: Double -> B.Builder () {-# INLINE double #-}-double d = B.word8 0xCB >> B.encodePrimBE d-+double d = B.encodePrim (0xCB :: Word8, BE d)  -- | Construct a scientific value, see 'scientific'. scientificValue :: Integer -> Int64 -> Value@@ -93,7 +92,7 @@ --  +--------+--------+--------+-----------------------------------------+---------------------------------------+ -- scientific :: Integer -> Int64 -> B.Builder ()-{-# INLINE scientific #-}+{-# INLINABLE scientific #-} scientific 0 _ = B.encodePrim @(Word8, Word8, Word8, Word8) (0xD5, 0x00, 0x00, 0x00) scientific c e = do     case (I# (word2Int# siz#)) + intSiz e of@@ -102,9 +101,9 @@         4 -> B.word8 0xD6         8 -> B.word8 0xD7         16 -> B.word8 0xD8-        siz' | siz' < 0x100   -> B.word8 0xC7 >> B.word8 (fromIntegral siz')-             | siz' < 0x10000 -> B.word8 0xC8 >> B.encodePrimBE @Word16 (fromIntegral siz')-             | otherwise      -> B.word8 0xC9 >> B.encodePrimBE @Word32 (fromIntegral siz')+        siz' | siz' < 0x100   -> B.encodePrim (0xC7 :: Word8, fromIntegral siz' :: Word8)+             | siz' < 0x10000 -> B.encodePrim (0xC8 :: Word8, BE (fromIntegral siz' :: Word16))+             | otherwise      -> B.encodePrim (0xC9 :: Word8, BE (fromIntegral siz' :: Word32))     B.word8 (if c > 0 then 0x00 else 0x01)     int e     B.writeN (I# (word2Int# siz#)) $ \ (MutablePrimArray mba#) (I# off#) ->@@ -126,12 +125,13 @@ -- | Construct a timestamp(seconds, nanoseconds) value. timestampValue :: Int64 -> Int32 -> Value {-# INLINE timestampValue #-}-timestampValue s ns = Ext 0xFF (B.build $ B.encodePrimBE ns >> B.encodePrimBE s)+timestampValue s ns = Ext 0xFF (B.build $ B.encodePrim (BE ns, BE s))  -- | Write a timestamp(seconds, nanoseconds) in ext 0xFF format, e.g. timestamp :: Int64 -> Int32 -> B.Builder () {-# INLINE timestamp #-}-timestamp s ns = B.encodePrim @(Word8, Word8, Word8, (BE Int32), (BE Int64)) (0xC7, 0x0C, 0xFF, (BE ns), (BE s))+timestamp s ns = B.encodePrim+    (0xC7 :: Word8, 0x0C :: Word8, 0xFF :: Word8, (BE ns :: BE Int32), (BE s :: BE Int64))  str' :: String -> B.Builder () {-# INLINE str' #-}@@ -143,18 +143,18 @@     let bs = T.getUTF8Bytes t     case V.length bs of         len | len <= 31      ->  B.word8 (0xA0 .|. fromIntegral len)-            | len < 0x100    ->  B.word8 0xD9 >> B.word8 (fromIntegral len)-            | len < 0x10000  ->  B.word8 0xDA >> B.encodePrimBE @Word16 (fromIntegral len)-            | otherwise      ->  B.word8 0xDB >> B.encodePrimBE @Word32 (fromIntegral len)+            | len < 0x100    ->  B.encodePrim (0xD9 :: Word8, fromIntegral len :: Word8)+            | len < 0x10000  ->  B.encodePrim (0xDA :: Word8, BE (fromIntegral len :: Word16))+            | otherwise      ->  B.encodePrim (0xDB :: Word8, BE (fromIntegral len :: Word32))     B.bytes bs  bin :: V.Bytes -> B.Builder () {-# INLINE bin #-} bin bs = do     case V.length bs of-        len | len < 0x100    ->  B.word8 0xC4 >> B.word8 (fromIntegral len)-            | len < 0x10000  ->  B.word8 0xC5 >> B.encodePrimBE @Word16 (fromIntegral len)-            | otherwise      ->  B.word8 0xC6 >> B.encodePrimBE @Word32 (fromIntegral len)+        len | len < 0x100    ->  B.encodePrim (0xC4 :: Word8, fromIntegral len :: Word8)+            | len < 0x10000  ->  B.encodePrim (0xC5 :: Word8, BE (fromIntegral len :: Word16))+            | otherwise      ->  B.encodePrim (0xC6 :: Word8, BE (fromIntegral len :: Word32))     B.bytes bs  array :: V.Vec v a => (a -> B.Builder ()) -> v a -> B.Builder ()@@ -173,8 +173,8 @@ {-# INLINE arrayHeader #-} arrayHeader len     | len <= 15      =  B.word8 (0x90 .|. fromIntegral len)-    | len < 0x10000  =  B.word8 0xDC >> B.encodePrimBE @Word16 (fromIntegral len)-    | otherwise      =  B.word8 0xDD >> B.encodePrimBE @Word32 (fromIntegral len)+    | len < 0x10000  =  B.encodePrim (0xDC :: Word8, BE (fromIntegral len :: Word16))+    | otherwise      =  B.encodePrim (0xDD :: Word8, BE (fromIntegral len :: Word32))  map :: (a -> B.Builder ()) -> (b -> B.Builder ()) -> V.Vector (a, b) -> B.Builder () {-# INLINE map #-}@@ -192,8 +192,8 @@ {-# INLINE mapHeader #-} mapHeader len     | len <= 15      =  B.word8 (0x80 .|. fromIntegral len)-    | len < 0x10000  =  B.word8 0xDE >> B.encodePrimBE @Word16 (fromIntegral len)-    | otherwise      =  B.word8 0xDF >> B.encodePrimBE @Word32 (fromIntegral len)+    | len < 0x10000  =  B.encodePrim (0xDE :: Word8, BE (fromIntegral len :: Word16))+    | otherwise      =  B.encodePrim (0xDF :: Word8, BE (fromIntegral len :: Word32))  ext :: Word8 -> V.Bytes -> B.Builder () {-# INLINABLE ext #-}@@ -204,8 +204,8 @@         4  -> B.word8 0xD6         8  -> B.word8 0xD7         16 -> B.word8 0xD8-        len | len < 0x100   -> B.word8 0xC7 >> B.word8 (fromIntegral len)-            | len < 0x10000 -> B.word8 0xC8 >> B.encodePrimBE @Word16 (fromIntegral len)-            | otherwise     -> B.word8 0xC9 >> B.encodePrimBE @Word32 (fromIntegral len)+        len | len < 0x100   -> B.encodePrim (0xC7 :: Word8, fromIntegral len :: Word8)+            | len < 0x10000 -> B.encodePrim (0xC8 :: Word8, BE (fromIntegral len :: Word16))+            | otherwise     -> B.encodePrim (0xC9 :: Word8, BE (fromIntegral len :: Word32))     B.word8 typ     B.bytes dat

@@ -8,7 +8,7 @@ module Z.Data.MessagePack.Value(   -- * MessagePack Value     Value(..)-    -- * parse into Message Value+    -- * parse into MessagePack Value   , parseValue   , parseValue'   , parseValueChunks@@ -29,7 +29,6 @@ import qualified Z.Data.Text                as T import qualified Z.Data.Parser              as P import qualified Z.Data.Vector              as V-  -- | Representation of MessagePack data. data Value

@@ -0,0 +1,272 @@+{-|+Module      : Z.Data.MessagePack+Description : Fast MessagePack serialization/deserialization+Copyright   : (c) Dong Han, 2019+License     : BSD+Maintainer  : winterland1989@gmail.com+Stability   : experimental+Portability : non-portable++This module provides <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md MessagePack-RPC> implementation.++@+-- server+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+     return (req + 1))+ , ("bar", NotifyHandler $ \\ (req :: T.Text) -> do+     printStd (req <> "world"))+ ]++-- client+import Z.IO.RPC.MessagePack+import Z.IO.Network+import Z.IO+import qualified Z.Data.Text as T++withResource (initTCPClient defaultTCPClientConfig) $ \\ uvs -> do+    c <- rpcClient uvs+    call \@Int \@Int c "foo" 1+    call \@T.Text \@T.Text c "bar" "hello"+@++-}++module Z.IO.RPC.MessagePack where++import           Control.Monad+import           Data.Bits+import           Z.Data.PrimRef.PrimIORef+import qualified Z.Data.MessagePack.Builder as MB+import qualified Z.Data.MessagePack.Value   as MV+import           Z.Data.MessagePack         (MessagePack)+import qualified Z.Data.MessagePack         as MP+import qualified Z.Data.Parser              as P+import qualified Z.Data.Text                as T+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+    , _clientPipelineReqNum :: Counter+    , _clientBufferedInput :: BufferedInput+    , _clientBufferedOutput :: BufferedOutput+    }++-- | Open a RPC client from input/output device.+rpcClient :: (Input dev, Output dev) => dev -> IO Client+rpcClient uvs = rpcClient' uvs uvs V.defaultChunkSize V.defaultChunkSize++-- | Open a RPC client with more control.+rpcClient' :: (Input i, Output o)+              => i+              -> o+              -> Int          -- ^ recv buffer size+              -> Int          -- ^ send buffer size+              -> IO Client+rpcClient' i o recvBufSiz sendBufSiz = do+    seqRef <- newCounter 0+    reqNum <- newCounter 0+    bi <- newBufferedInput' recvBufSiz i+    bo <- newBufferedOutput' sendBufSiz o+    return (Client seqRef reqNum bi bo)++-- | Send a single RPC call and get result.+call:: (MessagePack req, MessagePack res) => Client -> T.Text -> req -> IO res+call cli name req = do+    msgid <- callPipeline cli name req+    fetchPipeline msgid =<< execPipeline cli++-- | Send a single notification RPC call without getting result.+notify :: MessagePack req => Client -> T.Text -> req -> IO ()+notify c@(Client _ _ _ bo) name req = notifyPipeline c name req >> flushBuffer bo++type PipelineId = Int+type PipelineResult = FIM.FlatIntMap MV.Value++-- | Make a call inside a pipeline, which will be sent in batch when `execPipeline`.+--+-- @+--  ...+--  fooId <- callPipeline client "foo" $ ...+--  barId <- callPipeline client "bar" $ ...+--  notifyPipeline client "qux" $ ...+--+--  r <- execPipeline client+--+--  fooResult <- fetchPipeline fooId r+--  barResult <- fetchPipeline barId r+-- @+--+callPipeline :: HasCallStack => MessagePack req => Client -> T.Text -> req -> IO PipelineId+callPipeline (Client seqRef reqNum _ bo) name req = do+    msgid <- readPrimIORef seqRef+    writePrimIORef seqRef (msgid+1)+    modifyPrimIORef reqNum (+1)+    let !msgid' = msgid .&. 0xFFFFFFFF  -- shrink to unsiged 32bits+    writeBuilder bo $ do+        MB.arrayHeader 4+        MB.int 0                        -- type request+        MB.int (fromIntegral msgid')    -- msgid+        MB.str name                     -- method name+        MP.encodeMessagePack req        -- param+    return msgid'++-- | Make a notify inside a pipeline, which will be sent in batch when `execPipeline`.+--+-- Notify calls doesn't affect execution's result.+notifyPipeline :: HasCallStack => MessagePack req => Client -> T.Text -> req -> IO ()+notifyPipeline (Client _ _ _ bo) name req = do+    writeBuilder bo $ do+        MB.arrayHeader 3+        MB.int 2                        -- type notification+        MB.str name                     -- method name+        MP.encodeMessagePack req        -- param++-- | Exception thrown when remote endpoint return errors.+data RPCException = RPCException MV.Value CallStack deriving Show+instance Exception RPCException++-- | Sent request in batch and get result in a map identified by 'PipelineId'.+execPipeline :: HasCallStack => Client -> IO PipelineResult+execPipeline (Client _ reqNum bi bo) = do+    flushBuffer bo+    n <- readPrimIORef reqNum+    writePrimIORef reqNum 0+    FIM.packN n <$> replicateM n (do+        (msgid, err, v) <- readParser (do+            tag <- P.anyWord8+            when (tag /= 0x94) (P.fail' $ "wrong response tag: " <> T.toText tag)+            !typ <- MV.value+            !seq <- MV.value+            !err <- MV.value+            !v <- MV.value+            case typ 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 response type: " <> T.toText typ+            ) bi+        when (err /= MV.Nil) $ throwIO (RPCException err callStack)+        return (V.IPair (fromIntegral msgid) v))++-- | Use the `PipelineId` returned when `callPipeline` to fetch call's result.+fetchPipeline :: HasCallStack => MessagePack res => PipelineId -> PipelineResult -> IO res+fetchPipeline msgid r = do+    unwrap "EPARSE" . MP.convertValue =<<+        unwrap' "ENOMSG" ("missing message in response: " <> T.toText msgid)+            (FIM.lookup msgid r)++--------------------------------------------------------------------------------++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++-- | Simple router using `FlatMap`, lookup name in /O(log(N))/.+--+-- @+-- import Z.IO.PRC.MessagePack+-- import Z.IO.Network+-- import Z.IO+--+-- serveRPC (startTCPServer defaultTCPServerConfig) . simpleRouter $+--  [ ("foo", CallHandler $ \\ req -> do+--      ... )+--  , ("bar", CallHandler $ \\ req -> do+--      ... )+--  ]+--+-- @+simpleRouter :: [(T.Text, ServerHandler)] -> ServerService+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++-- | Serve a RPC service with more control.+serveRPC' :: ServerLoop+          -> Int          -- ^ recv buffer size+          -> Int          -- ^ send buffer size+          -> ServerService -> IO ()+serveRPC' serve recvBufSiz sendBufSiz handle = serve $ \ uvs -> do+    bi <- newBufferedInput' recvBufSiz uvs+    bo <- newBufferedOutput' sendBufSiz uvs+    loop bi bo+  where+    loop bi bo = do+        req <- pull (sourceParserFromBuffered (do+            tag <- P.anyWord8+            case tag of+                -- notify+                0x93 -> do+                    !typ <- MV.value+                    !name <- MV.value+                    !v <- MV.value+                    case typ of+                        MV.Int 2 -> case name of+                            MV.Str name' -> return (Left (name', v))+                            _ -> P.fail' $ "wrong RPC name: " <> T.toText name+                        _ -> P.fail' $ "wrong notification type: " <> T.toText typ+                -- call+                0x94 -> do+                    !typ <- MV.value+                    !seq <- MV.value+                    !name <- MV.value+                    !v <- MV.value+                    case typ of+                        MV.Int 0 -> case seq of+                            MV.Int msgid | msgid >= 0 && msgid <= 0xFFFFFFFF -> case name of+                                MV.Str name' -> return (Right (msgid, name', v))+                                _ -> P.fail' $ "wrong RPC name: " <> T.toText name+                            _ -> P.fail' $ "wrong msgid: " <> T.toText seq+                        _ -> P.fail' $ "wrong request type: " <> T.toText typ+                _ -> P.fail' $ "wrong request tag: " <> T.toText tag+            ) bi)+        case req of+            Just (Left (name, v)) -> do+                case handle name of+                    Just (NotifyHandler f) -> do+                        f =<< unwrap "EPARSE" (MP.convertValue v)+                    _ -> throwOtherError "ENOTFOUND" "notification method not found"+                loop bi bo+            Just (Right (msgid, name, v)) -> do+                case handle name of+                    Just (CallHandler f) -> do+                        res <- try (f =<< unwrap "EPARSE" (MP.convertValue v))+                        writeBuilder bo $ do+                            MB.arrayHeader 4+                            MB.int 1                        -- type response+                            MB.int (fromIntegral msgid)     -- msgid+                            case res of+                                Left e -> do+                                    MB.str (T.pack $ show (e :: SomeException))+                                    MB.nil+                                Right res -> do+                                    MB.nil+                                    MP.encodeMessagePack res+                        flushBuffer bo+                    _ -> do+                        writeBuilder bo $ do+                            MB.arrayHeader 4+                            MB.int 1                        -- type response+                            MB.int (fromIntegral msgid)     -- msgid+                            MB.str $ "request method: " <> name <> " not found"+                            MB.nil+                        flushBuffer bo+                loop bi bo+            _ -> return ()