diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Z-MessagePack.cabal b/Z-MessagePack.cabal --- a/Z-MessagePack.cabal +++ b/Z-MessagePack.cabal @@ -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 diff --git a/Z/Data/MessagePack.hs b/Z/Data/MessagePack.hs --- a/Z/Data/MessagePack.hs +++ b/Z/Data/MessagePack.hs @@ -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) diff --git a/Z/Data/MessagePack/Base.hs b/Z/Data/MessagePack/Base.hs --- a/Z/Data/MessagePack/Base.hs +++ b/Z/Data/MessagePack/Base.hs @@ -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) diff --git a/Z/Data/MessagePack/Builder.hs b/Z/Data/MessagePack/Builder.hs --- a/Z/Data/MessagePack/Builder.hs +++ b/Z/Data/MessagePack/Builder.hs @@ -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 diff --git a/Z/Data/MessagePack/Value.hs b/Z/Data/MessagePack/Value.hs --- a/Z/Data/MessagePack/Value.hs +++ b/Z/Data/MessagePack/Value.hs @@ -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 diff --git a/Z/IO/RPC/MessagePack.hs b/Z/IO/RPC/MessagePack.hs new file mode 100644 --- /dev/null +++ b/Z/IO/RPC/MessagePack.hs @@ -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 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 ()