Hello community, here is the log from the commit of package ghc-pinch for openSUSE:Factory checked in at 2016-11-02 12:46:58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-pinch (Old) and /work/SRC/openSUSE:Factory/.ghc-pinch.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-pinch" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-pinch/ghc-pinch.changes 2016-10-22 13:16:04.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-pinch.new/ghc-pinch.changes 2016-11-02 12:46:58.000000000 +0100 @@ -1,0 +2,5 @@ +Thu Sep 15 06:41:03 UTC 2016 - [email protected] + +- Update to version 0.3.0.1 revision 0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- pinch-0.2.0.2.tar.gz New: ---- pinch-0.3.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-pinch.spec ++++++ --- /var/tmp/diff_new_pack.jvV1cH/_old 2016-11-02 12:47:00.000000000 +0100 +++ /var/tmp/diff_new_pack.jvV1cH/_new 2016-11-02 12:47:00.000000000 +0100 @@ -19,11 +19,11 @@ %global pkg_name pinch %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.0.2 +Version: 0.3.0.1 Release: 0 Summary: An alternative implementation of Thrift for Haskell License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel @@ -71,19 +71,15 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %check %cabal_test - %post devel %ghc_pkg_recache ++++++ pinch-0.2.0.2.tar.gz -> pinch-0.3.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/CHANGES.md new/pinch-0.3.0.1/CHANGES.md --- old/pinch-0.2.0.2/CHANGES.md 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/CHANGES.md 2016-07-13 06:11:26.000000000 +0200 @@ -1,15 +1,27 @@ -0.2.0.2 -======= +0.3.0.1 (2016-07-12) +==================== - Compile on 32-bit systems. -0.2.0.1 -======= +0.3.0.0 (2016-06-02) +==================== + +- Add support for the Thrift Compact Protocol (#2). +- Add support for returning the leftover ByteString when parsing Thrift + payloads (#3). + +0.2.0.2 (2016-07-12) +==================== + +- Compile on 32-bit systems. + +0.2.0.1 (2016-05-23) +==================== - Build with GHC 8. -0.2.0.0 -======= +0.2.0.0 (2015-12-27) +==================== Breaking changes: @@ -27,19 +39,19 @@ - Improve serialization and deserialization performance further by changing the intermediate representation of lists, sets, and maps. -0.1.0.2 -======= +0.1.0.2 (2015-12-27) +==================== - Loosen `vector` version constraint. -0.1.0.1 -======= +0.1.0.1 (2015-11-15) +==================== - Fixed recursion in C pre-processor expansion. This can break the build on some systems. -0.1.0.0 -======= +0.1.0.0 (2015-11-15) +==================== - Initial release. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/README.md new/pinch-0.3.0.1/README.md --- old/pinch-0.2.0.2/README.md 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/README.md 2016-07-13 06:08:03.000000000 +0200 @@ -69,11 +69,17 @@ For more information, check the documentation and the examples. +Supported Protocols +------------------- + +The following Thrift protocols are supported: + +- Binary +- Compact + Caveats ------- -- Only the Thrift Binary Protocol is supported right now. (Pull - requests welcome.) - There is no code generation or template haskell support yet so types from the Thrift file will have to be translated by hand. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/bench/pinch-bench/Bench.hs new/pinch-0.3.0.1/bench/pinch-bench/Bench.hs --- old/pinch-0.2.0.2/bench/pinch-bench/Bench.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/bench/pinch-bench/Bench.hs 2016-07-13 06:08:03.000000000 +0200 @@ -152,38 +152,57 @@ main :: IO () main = defaultMain [ bgroup "A" - [ env (generate :: IO A) $ \a -> bench "encode" $ whnf encode a - , env generateEncodedA $ \bs -> bench "decode" $ - nf (P.decode P.binaryProtocol :: ByteString -> Either String A) bs + [ env (generate :: IO A) $ \a -> bgroup "encode" + [ bench "binary" $ whnf (P.encode P.binaryProtocol) a + , bench "compact" $ whnf (P.encode P.compactProtocol) a + ] + , bgroup "decode" + [ env (generateEncodedA P.binaryProtocol) $ \bs -> bench "binary" $ + nf (P.decode P.binaryProtocol :: ByteString -> Either String A) bs + , env (generateEncodedA P.compactProtocol) $ \bs -> bench "compact" $ + nf (P.decode P.compactProtocol :: ByteString -> Either String A) bs + ] ] , bgroup "NestedMixed" - [ env generateNestedMixedFields $ \ ~(f1, f2, f3) -> bench "encode" $ - whnf encode (NestedMixed f1 f2 f3) - , env generateEncodedNestedMixed $ \bs -> bench "decode" $ - nf (P.decode P.binaryProtocol :: ByteString -> Either String NestedMixed) bs + [ env generateNestedMixedFields $ \ ~(f1, f2, f3) -> bgroup "encode" + [ bench "binary" $ + whnf (P.encode P.binaryProtocol) (NestedMixed f1 f2 f3) + , bench "compact" $ + whnf (P.encode P.compactProtocol) (NestedMixed f1 f2 f3) + ] + , bgroup "decode" + [ env (generateEncodedNestedMixed P.binaryProtocol) $ \bs -> bench "binary" $ + nf (P.decode P.binaryProtocol :: ByteString -> Either String NestedMixed) bs + , env (generateEncodedNestedMixed P.compactProtocol) $ \bs -> bench "compact" $ + nf (P.decode P.compactProtocol :: ByteString -> Either String NestedMixed) bs + ] + ] , bgroup "Struct" - [ env structFields $ \ ~(f1, f2, f3) -> bench "encode" $ - whnf encode (Struct f1 f2 f3) - , env generateEncodedStruct $ \bs -> bench "deode" $ - nf (P.decode P.binaryProtocol :: ByteString -> Either String Struct) bs + [ env structFields $ \ ~(f1, f2, f3) -> bgroup "encode" + [ bench "binary" $ whnf (P.encode P.binaryProtocol) (Struct f1 f2 f3) + , bench "compact" $ whnf (P.encode P.compactProtocol) (Struct f1 f2 f3) + ] + , bgroup "decode" + [ env (generateEncodedStruct P.binaryProtocol) $ \bs -> bench "binary" $ + nf (P.decode P.binaryProtocol :: ByteString -> Either String Struct) bs + , env (generateEncodedStruct P.compactProtocol) $ \bs -> bench "compact" $ + nf (P.decode P.compactProtocol :: ByteString -> Either String Struct) bs + ] ] ] where - generateEncodedNestedMixed = bracket_ stopProfTimer startProfTimer $ do + generateEncodedNestedMixed proto = bracket_ stopProfTimer startProfTimer $ do (f1, f2, f3) <- generateNestedMixedFields - return $ P.encode P.binaryProtocol (NestedMixed f1 f2 f3) + return $ P.encode proto (NestedMixed f1 f2 f3) - generateEncodedA = bracket_ stopProfTimer startProfTimer $ do + generateEncodedA proto = bracket_ stopProfTimer startProfTimer $ do a <- generate :: IO A - return $ P.encode P.binaryProtocol a + return $ P.encode proto a - generateEncodedStruct = bracket_ stopProfTimer startProfTimer $ do + generateEncodedStruct proto = bracket_ stopProfTimer startProfTimer $ do (f1, f2, f3) <- structFields - return $ P.encode P.binaryProtocol (Struct f1 f2 f3) + return $ P.encode proto (Struct f1 f2 f3) generate :: QC.Arbitrary a => IO a generate = QC.generate QC.arbitrary - - encode :: P.Pinchable a => a -> ByteString - encode = P.encode P.binaryProtocol diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/pinch.cabal new/pinch-0.3.0.1/pinch.cabal --- old/pinch-0.2.0.2/pinch.cabal 2016-07-13 06:05:59.000000000 +0200 +++ new/pinch-0.3.0.1/pinch.cabal 2016-07-13 06:11:11.000000000 +0200 @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: pinch -version: 0.2.0.2 +version: 0.3.0.1 cabal-version: >= 1.10 build-type: Simple license: BSD3 @@ -70,6 +70,7 @@ Pinch.Internal.Value Pinch.Protocol Pinch.Protocol.Binary + Pinch.Protocol.Compact other-modules: Pinch.Internal.Bits Pinch.Internal.Pinchable.Parser @@ -106,4 +107,5 @@ Pinch.Internal.Util Pinch.Internal.ValueSpec Pinch.Protocol.BinarySpec + Pinch.Protocol.CompactSpec default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Internal/Builder.hs new/pinch-0.3.0.1/src/Pinch/Internal/Builder.hs --- old/pinch-0.2.0.2/src/Pinch/Internal/Builder.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Internal/Builder.hs 2016-07-13 06:08:03.000000000 +0200 @@ -17,6 +17,7 @@ , append , int8 + , word8 , int16BE , int32BE , int64BE @@ -95,6 +96,11 @@ int8 = primFixed BP.int8 {-# INLINE int8 #-} +-- | Serialize a single unsigned byte. +word8 :: Word8 -> Builder +word8 = primFixed BP.word8 +{-# INLINE word8 #-} + -- | Serialize a signed 16-bit integer in big endian format. int16BE :: Int16 -> Builder int16BE = primFixed BP.int16BE diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Internal/FoldList.hs new/pinch-0.3.0.1/src/Pinch/Internal/FoldList.hs --- old/pinch-0.2.0.2/src/Pinch/Internal/FoldList.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Internal/FoldList.hs 2016-07-13 06:08:03.000000000 +0200 @@ -118,3 +118,11 @@ instance Hashable a => Hashable (FoldList a) where hashWithSalt s (FoldList l) = l hashWithSalt s + +instance Monoid (FoldList a) where + mempty = FoldList (\_ r -> r) + {-# INLINE mempty #-} + + FoldList f1 `mappend` FoldList f2 = + FoldList $ \cons nil -> f2 cons (f1 cons nil) + {-# INLINE mappend #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Internal/Parser.hs new/pinch-0.3.0.1/src/Pinch/Internal/Parser.hs --- old/pinch-0.2.0.2/src/Pinch/Internal/Parser.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Internal/Parser.hs 2016-07-13 06:08:03.000000000 +0200 @@ -15,8 +15,10 @@ module Pinch.Internal.Parser ( Parser , runParser + , runParser' , int8 + , word8 , int16 , int32 , int64 @@ -31,6 +33,7 @@ import Data.Bits ((.|.)) import Data.ByteString (ByteString) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word8) import Prelude hiding (take) import qualified Control.Monad.ST as ST @@ -98,6 +101,13 @@ {-# INLINE runParser #-} +-- | Run the parser on the given ByteString. Return either the failure message +-- or the result and any left-over content. +runParser' :: Parser a -> ByteString -> Either String (ByteString, a) +runParser' (Parser f) b = f b Left (\b' r -> Right (b', r)) +{-# INLINE runParser' #-} + + -- | @take n@ gets exactly @n@ bytes or fails the parse. take :: Int -> Parser ByteString take n = Parser $ \b kFail kSucc -> @@ -121,6 +131,12 @@ {-# INLINE int8 #-} +-- | Produces the next byte and advances the parser. +word8 :: Parser Word8 +word8 = fromIntegral <$> int8 +{-# INLINE word8 #-} + + -- | Produces a signed 16-bit integer and advances the parser. int16 :: Parser Int16 int16 = mk <$> take 2 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Internal/Pinchable.hs new/pinch-0.3.0.1/src/Pinch/Internal/Pinchable.hs --- old/pinch-0.2.0.2/src/Pinch/Internal/Pinchable.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Internal/Pinchable.hs 2016-07-13 06:08:03.000000000 +0200 @@ -227,6 +227,7 @@ FL.foldl' (\m (!k, !v) -> mapInsert k v m) mapEmpty <$> FL.mapM go xs where go (MapItem k v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v +unpinchMap _ mapEmpty VNullMap = return mapEmpty unpinchMap _ _ x = fail $ "Failed to read map. Got " ++ show x instance IsTType a => Pinchable (Value a) where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Internal/Value.hs new/pinch-0.3.0.1/src/Pinch/Internal/Value.hs --- old/pinch-0.2.0.2/src/Pinch/Internal/Value.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Internal/Value.hs 2016-07-13 06:08:03.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} @@ -22,6 +23,10 @@ , valueTType ) where +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid (mempty) +#endif + import Control.DeepSeq (NFData (..)) import Data.ByteString (ByteString) import Data.Hashable (Hashable (..)) @@ -70,6 +75,7 @@ VMap :: forall k v. (IsTType k, IsTType v) => !(FoldList (MapItem k v)) -> Value TMap + VNullMap :: Value TMap VSet :: forall a. IsTType a => !(FoldList (Value a)) -> Value TSet VList :: forall a. IsTType a => !(FoldList (Value a)) -> Value TList deriving Typeable @@ -89,6 +95,7 @@ go xs i (SomeValue val) = (show i ++ ": " ++ show val):xs show (VMap x) = show x + show VNullMap = "[]" show (VSet x) = show x show (VList x) = show x @@ -105,8 +112,10 @@ VList as == VList bs = areEqual1 as bs VMap as == VMap bs = areEqual2 (toMap as) (toMap bs) where - toMap = F.foldl' (\m (MapItem k v) -> M.insert k v m) M.empty - VSet as == VSet bs = areEqual1 (toSet as) (toSet bs) + toMap = M.toList . F.foldl' (\m (MapItem k v) -> M.insert k v m) M.empty + VNullMap == VMap xs = mempty == xs + VMap xs == VNullMap = xs == mempty + VSet as == VSet bs = areEqual1 (toSet as) (toSet bs) _ == _ = False toSet :: forall f x. (F.Foldable f, Hashable x, Eq x) => f x -> S.HashSet x @@ -122,6 +131,7 @@ rnf (VBinary a) = rnf a rnf (VStruct a) = rnf a rnf (VMap as) = rnf as + rnf VNullMap = () rnf (VSet as) = rnf as rnf (VList as) = rnf as @@ -143,8 +153,8 @@ -- | Safely attempt to cast a Value into another. castValue :: forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b) -castValue v = case ttypeEqT of - Just (Refl :: a :~: b) -> Just v +castValue v = case ttypeEqT :: Maybe (a :~: b) of + Just Refl -> Just v Nothing -> Nothing {-# INLINE castValue #-} @@ -155,13 +165,13 @@ areEqual :: forall a b. (IsTType a, IsTType b) => Value a -> Value b -> Bool -areEqual l r = case ttypeEqT of - Just (Refl :: a :~: b) -> l == r +areEqual l r = case ttypeEqT :: Maybe (a :~: b) of + Just Refl -> l == r Nothing -> False {-# INLINE areEqual #-} areEqual1 - :: forall a b f. (IsTType a, IsTType b, Eq (f (Value a))) + :: forall a b f. (IsTType a, IsTType b, F.Foldable f, Eq (f (Value a))) => f (Value a) -> f (Value b) -> Bool areEqual1 l r = case ttypeEqT of Just (Refl :: a :~: b) -> l == r @@ -169,10 +179,9 @@ {-# INLINE areEqual1 #-} areEqual2 - :: forall f k1 v1 k2 v2. + :: forall k1 v1 k2 v2. ( IsTType k1, IsTType v1, IsTType k2, IsTType v2 - , Eq (f (Value k1) (Value v1)) - ) => f (Value k1) (Value v1) -> f (Value k2) (Value v2) -> Bool + ) => [(Value k1, Value v1)] -> [(Value k2, Value v2)] -> Bool areEqual2 l r = case ttypeEqT of Just (Refl :: k1 :~: k2) -> case ttypeEqT of Just (Refl :: v1 :~: v2) -> l == r @@ -191,6 +200,7 @@ VInt64 x -> s `hashWithSalt` (6 :: Int) `hashWithSalt` x VList x -> s `hashWithSalt` (7 :: Int) `hashWithSalt` x VMap x -> s `hashWithSalt` (8 :: Int) `hashWithSalt` x + VNullMap -> s `hashWithSalt` (8 :: Int) VSet x -> s `hashWithSalt` (9 :: Int) `hashWithSalt` x VStruct fields -> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Protocol/Binary.hs new/pinch-0.3.0.1/src/Pinch/Protocol/Binary.hs --- old/pinch-0.2.0.2/src/Pinch/Protocol/Binary.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Protocol/Binary.hs 2016-07-13 06:08:03.000000000 +0200 @@ -31,7 +31,7 @@ import Pinch.Internal.Builder (Builder) import Pinch.Internal.Message -import Pinch.Internal.Parser (Parser, runParser) +import Pinch.Internal.Parser (Parser, runParser, runParser') import Pinch.Internal.TType import Pinch.Internal.Value import Pinch.Protocol (Protocol (..)) @@ -45,7 +45,7 @@ binaryProtocol :: Protocol binaryProtocol = Protocol { serializeValue = binarySerialize - , deserializeValue = binaryDeserialize ttype + , deserializeValue' = binaryDeserialize ttype , serializeMessage = binarySerializeMessage , deserializeMessage = binaryDeserializeMessage } @@ -102,8 +102,8 @@ ------------------------------------------------------------------------------ -binaryDeserialize :: TType a -> ByteString -> Either String (Value a) -binaryDeserialize t = runParser (binaryParser t) +binaryDeserialize :: TType a -> ByteString -> Either String (ByteString, Value a) +binaryDeserialize t = runParser' (binaryParser t) binaryParser :: TType a -> Parser (Value a) binaryParser typ = case typ of @@ -263,6 +263,7 @@ {-# INLINE serializeStruct #-} serializeMap :: Value TMap -> Builder +serializeMap VNullMap = error "serializeMap: VNullMap" serializeMap (VMap items) = serialize ttype ttype items where serialize diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Protocol/Compact.hs new/pinch-0.3.0.1/src/Pinch/Protocol/Compact.hs --- old/pinch-0.2.0.2/src/Pinch/Protocol/Compact.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/pinch-0.3.0.1/src/Pinch/Protocol/Compact.hs 2016-07-13 06:08:03.000000000 +0200 @@ -0,0 +1,475 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Pinch.Protocol.Compact +-- Copyright : (c) Ben Gamari 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta <[email protected]> +-- Stability : experimental +-- +-- Implements the Thrift Compact Protocol as a 'Protocol'. +module Pinch.Protocol.Compact (compactProtocol) where + + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Control.Monad +import Data.Bits hiding (shift) +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import Data.Int (Int16, Int32, Int64) +import Data.List (sortBy) +import Data.Monoid +import Data.Ord (comparing) +import Data.Typeable (Typeable) +import Data.Word (Word64, Word8) + +import qualified Data.ByteString as B +import qualified Data.HashMap.Strict as M +import qualified Data.Text.Encoding as TE + +import Pinch.Internal.Builder (Builder) +import Pinch.Internal.Message +import Pinch.Internal.Parser (Parser, runParser, runParser') +import Pinch.Internal.TType +import Pinch.Internal.Value +import Pinch.Protocol (Protocol (..)) + +import qualified Pinch.Internal.Builder as BB +import qualified Pinch.Internal.FoldList as FL +import qualified Pinch.Internal.Parser as P + + +-- | Provides an implementation of the Thrift Compact Protocol. +compactProtocol :: Protocol +compactProtocol = Protocol + { serializeValue = compactSerialize + , deserializeValue' = compactDeserialize ttype + , serializeMessage = compactSerializeMessage + , deserializeMessage = compactDeserializeMessage + } + +------------------------------------------------------------------------------ + +protocolId, version :: Word8 +protocolId = 0x82 +version = 0x01 + +compactSerializeMessage :: Message -> Builder +compactSerializeMessage msg = + BB.word8 protocolId <> + BB.word8 ((version .&. 0x1f) .|. (messageCode (messageType msg) `shiftL` 5)) <> + serializeVarint (fromIntegral $ messageId msg) <> + string (TE.encodeUtf8 $ messageName msg) <> + compactSerialize (messagePayload msg) + +compactDeserializeMessage :: ByteString -> Either String Message +compactDeserializeMessage = runParser compactMessageParser + +compactMessageParser :: Parser Message +compactMessageParser = do + pid <- P.word8 + when (pid /= protocolId) $ fail "Invalid protocol ID" + w <- P.word8 + let ver = w .&. 0x1f + when (ver /= version) $ fail $ "Unsupported version: " ++ show ver + let code = w `shiftR` 5 + msgId <- parseVarint + msgName <- TE.decodeUtf8 <$> (parseVarint >>= P.take . fromIntegral) + payload <- compactParser ttype + mtype <- case fromMessageCode code of + Nothing -> fail $ "unknown message type: " ++ show code + Just t -> return t + return Message { messageType = mtype + , messageId = fromIntegral msgId + , messageName = msgName + , messagePayload = payload + } + + +------------------------------------------------------------------------------ + +compactDeserialize :: TType a -> ByteString -> Either String (ByteString, Value a) +compactDeserialize t = runParser' (compactParser t) + +compactParser :: TType a -> Parser (Value a) +compactParser typ = case typ of + TBool -> do + n <- P.int8 + return $ VBool (n == 1) + TByte -> parseByte + TDouble -> parseDouble + TInt16 -> parseInt16 + TInt32 -> parseInt32 + TInt64 -> parseInt64 + TBinary -> parseBinary + TStruct -> parseStruct + TMap -> parseMap + TSet -> parseSet + TList -> parseList + +intToZigZag :: Int64 -> Int64 +intToZigZag n = + (n `shiftL` 1) `xor` (n `shiftR` 63) + +zigZagToInt :: Int64 -> Int64 +zigZagToInt n = + fromIntegral (n' `shiftR` 1) `xor` (-(n .&. 1)) + where + n' = fromIntegral n :: Word64 + -- ensure no sign extension + +parseVarint :: Parser Int64 +parseVarint = go 0 0 + where + go !val !shift = do + when (shift >= 64) $ fail "parseVarint: too wide" + n <- P.word8 + let val' = val .|. ((fromIntegral n .&. 0x7f) `shiftL` shift) + if testBit n 7 + then go val' (shift + 7) + else return val' + +getCType :: Word8 -> Parser SomeCType +getCType code = + maybe (fail $ "Unknown CType: " ++ show code) return $ fromCompactCode code + +parseByte :: Parser (Value TByte) +parseByte = VByte <$> P.int8 + +parseDouble :: Parser (Value TDouble) +parseDouble = VDouble <$> P.double + +parseInt16 :: Parser (Value TInt16) +parseInt16 = VInt16 . fromIntegral . zigZagToInt <$> parseVarint + +parseInt32 :: Parser (Value TInt32) +parseInt32 = VInt32 . fromIntegral . zigZagToInt <$> parseVarint + +parseInt64 :: Parser (Value TInt64) +parseInt64 = VInt64 . fromIntegral . zigZagToInt <$> parseVarint + +parseBinary :: Parser (Value TBinary) +parseBinary = do + n <- parseVarint + when (n < 0) $ + fail $ "parseBinary: invalid length " ++ show n + VBinary <$> P.take (fromIntegral n) + + +parseMap :: Parser (Value TMap) +parseMap = do + count <- parseVarint + case count of + 0 -> return VNullMap + _ -> do + tys <- P.word8 + SomeCType kctype <- getCType (tys `shiftR` 4) + SomeCType vctype <- getCType (tys .&. 0x0f) + + let ktype = cTypeToTType kctype + vtype = cTypeToTType vctype + + items <- FL.replicateM (fromIntegral count) $ + MapItem <$> compactParser ktype + <*> compactParser vtype + return $ VMap items + + +parseCollection + :: (forall a. IsTType a => FL.FoldList (Value a) -> Value b) + -> Parser (Value b) +parseCollection buildValue = do + sizeAndType <- P.word8 + SomeCType ctype <- getCType (sizeAndType .&. 0x0f) + count <- case sizeAndType `shiftR` 4 of + 0xf -> parseVarint + n -> return $ fromIntegral n + let vtype = cTypeToTType ctype + buildValue <$> FL.replicateM (fromIntegral count) (compactParser vtype) + +parseSet :: Parser (Value TSet) +parseSet = parseCollection VSet + +parseList :: Parser (Value TList) +parseList = parseCollection VList + +parseStruct :: Parser (Value TStruct) +parseStruct = loop M.empty 0 + where + loop :: HashMap Int16 SomeValue -> Int16 -> Parser (Value TStruct) + loop fields lastFieldId = do + sizeAndType <- P.word8 + SomeCType ctype <- getCType (sizeAndType .&. 0x0f) + case ctype of + CStop -> return (VStruct fields) + _ -> do + fieldId <- case sizeAndType `shiftR` 4 of + 0x0 -> fromIntegral . zigZagToInt <$> parseVarint + n -> return (lastFieldId + fromIntegral n) + value <- case ctype of + CBoolTrue -> return (SomeValue $ VBool True) + CBoolFalse -> return (SomeValue $ VBool False) + _ -> + let vtype = cTypeToTType ctype + in SomeValue <$> compactParser vtype + loop (M.insert fieldId value fields) fieldId + + +------------------------------------------------------------------------------ + +compactSerialize :: forall a. IsTType a => Value a -> Builder +compactSerialize = case (ttype :: TType a) of + TBinary -> serializeBinary + TBool -> serializeBool + TByte -> serializeByte + TDouble -> serializeDouble + TInt16 -> serializeInt16 + TInt32 -> serializeInt32 + TInt64 -> serializeInt64 + TStruct -> serializeStruct + TList -> serializeList + TMap -> serializeMap + TSet -> serializeSet +{-# INLINE compactSerialize #-} + +serializeBinary :: Value TBinary -> Builder +serializeBinary (VBinary x) = string x +{-# INLINE serializeBinary #-} + +serializeBool :: Value TBool -> Builder +serializeBool (VBool x) = compactCode $ if x then CBoolTrue else CBoolFalse +{-# INLINE serializeBool #-} + +serializeByte :: Value TByte -> Builder +serializeByte (VByte x) = BB.int8 x +{-# INLINE serializeByte #-} + +serializeDouble :: Value TDouble -> Builder +serializeDouble (VDouble x) = BB.doubleBE x +{-# INLINE serializeDouble #-} + +serializeVarint :: Int64 -> Builder +serializeVarint = go . fromIntegral + where + -- Ensure we don't sign extend + go :: Word64 -> Builder + go n + | complement 0x7f .&. n == 0 = + BB.word8 $ fromIntegral n + | otherwise = + BB.word8 (0x80 .|. (fromIntegral n .&. 0x7f)) <> + go (n `shiftR` 7) + +serializeInt16 :: Value TInt16 -> Builder +serializeInt16 (VInt16 x) = serializeVarint $ intToZigZag $ fromIntegral x +{-# INLINE serializeInt16 #-} + +serializeInt32 :: Value TInt32 -> Builder +serializeInt32 (VInt32 x) = serializeVarint $ intToZigZag $ fromIntegral x +{-# INLINE serializeInt32 #-} + +serializeInt64 :: Value TInt64 -> Builder +serializeInt64 (VInt64 x) = serializeVarint $ intToZigZag x +{-# INLINE serializeInt64 #-} + +serializeList :: Value TList -> Builder +serializeList (VList xs) = serializeCollection ttype xs +{-# INLINE serializeList #-} + +serializeSet :: Value TSet -> Builder +serializeSet (VSet xs) = serializeCollection ttype xs +{-# INLINE serializeSet #-} + +serializeStruct :: Value TStruct -> Builder +serializeStruct (VStruct fields) = + loop 0 (sortBy (comparing fst) $ M.toList fields) + where + loop _ [] = compactCode CStop + loop lastFieldId ((fieldId, val) : rest) = + let x = case val of + SomeValue (VBool True) -> writeFieldHeader CBoolTrue + SomeValue (VBool False) -> writeFieldHeader CBoolFalse + SomeValue (v :: Value a) -> + writeFieldHeader (tTypeToCType (ttype :: TType a)) <> compactSerialize v + in x <> loop fieldId rest + where + writeFieldHeader :: CType a -> Builder + writeFieldHeader ccode + | fieldId > lastFieldId && fieldId - lastFieldId < 16 + = compactCode' ccode (fromIntegral $ fieldId - lastFieldId) + | otherwise + = compactCode ccode <> serializeVarint (intToZigZag $ fromIntegral fieldId) +{-# INLINE serializeStruct #-} + +serializeMap :: Value TMap -> Builder +serializeMap VNullMap = BB.int8 0 +serializeMap (VMap items) = serialize ttype ttype items + where + serialize + :: (IsTType k, IsTType v) + => TType k -> TType v -> FL.FoldList (MapItem k v) -> Builder + serialize kt vt xs + | size == 0 = BB.int8 0 + | otherwise = + serializeVarint (fromIntegral size) <> BB.word8 typeByte <> body + where + code = toCompactCode . tTypeToCType + typeByte = (code kt `shiftL` 4) .|. code vt + (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs + go (prev, !c) (MapItem k v) = + ( prev <> compactSerialize k <> compactSerialize v + , c + 1 + ) +{-# INLINE serializeMap #-} + +serializeCollection + :: IsTType a + => TType a -> FL.FoldList (Value a) -> Builder +serializeCollection vtype xs = + let go (prev, !c) item = (prev <> compactSerialize item, c + 1) + (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs + type_and_size + | size < 15 = typeCode' vtype (fromIntegral size) + | otherwise = typeCode' vtype 0xf <> serializeVarint (fromIntegral size) + in type_and_size <> body +{-# INLINE serializeCollection #-} + +------------------------------------------------------------------------------ + + +messageCode :: MessageType -> Word8 +messageCode Call = 1 +messageCode Reply = 2 +messageCode Exception = 3 +messageCode Oneway = 4 +{-# INLINE messageCode #-} + + +fromMessageCode :: Word8 -> Maybe MessageType +fromMessageCode 1 = Just Call +fromMessageCode 2 = Just Reply +fromMessageCode 3 = Just Exception +fromMessageCode 4 = Just Oneway +fromMessageCode _ = Nothing +{-# INLINE fromMessageCode #-} + + +data TStop deriving (Typeable) + +instance IsTType TStop where + ttype = error "ttype TStop" + +-- | A compact message type. +data CType a where + CStop :: CType TStop + CBoolTrue :: CType TBool + CBoolFalse :: CType TBool + CByte :: CType TByte + CInt16 :: CType TInt16 + CInt32 :: CType TInt32 + CInt64 :: CType TInt64 + CDouble :: CType TDouble + CBinary :: CType TBinary + CList :: CType TList + CSet :: CType TSet + CMap :: CType TMap + CStruct :: CType TStruct + + +data SomeCType where + SomeCType :: forall a. IsTType a => CType a -> SomeCType + + +-- | Map a TType to its type code. +toCompactCode :: CType a -> Word8 +toCompactCode CStop = 0 +toCompactCode CBoolTrue = 1 +toCompactCode CBoolFalse = 2 +toCompactCode CByte = 3 +toCompactCode CInt16 = 4 +toCompactCode CInt32 = 5 +toCompactCode CInt64 = 6 +toCompactCode CDouble = 7 +toCompactCode CBinary = 8 +toCompactCode CList = 9 +toCompactCode CSet = 10 +toCompactCode CMap = 11 +toCompactCode CStruct = 12 +{-# INLINE toCompactCode #-} + + +-- | Map a type code to the corresponding TType. +fromCompactCode :: Word8 -> Maybe SomeCType +fromCompactCode 0 = Just $ SomeCType CStop +fromCompactCode 1 = Just $ SomeCType CBoolTrue +fromCompactCode 2 = Just $ SomeCType CBoolFalse +fromCompactCode 3 = Just $ SomeCType CByte +fromCompactCode 4 = Just $ SomeCType CInt16 +fromCompactCode 5 = Just $ SomeCType CInt32 +fromCompactCode 6 = Just $ SomeCType CInt64 +fromCompactCode 7 = Just $ SomeCType CDouble +fromCompactCode 8 = Just $ SomeCType CBinary +fromCompactCode 9 = Just $ SomeCType CList +fromCompactCode 10 = Just $ SomeCType CSet +fromCompactCode 11 = Just $ SomeCType CMap +fromCompactCode 12 = Just $ SomeCType CStruct +fromCompactCode _ = Nothing +{-# INLINE fromCompactCode #-} + +tTypeToCType :: TType a -> CType a +tTypeToCType TBool = CBoolTrue +tTypeToCType TByte = CByte +tTypeToCType TInt16 = CInt16 +tTypeToCType TInt32 = CInt32 +tTypeToCType TInt64 = CInt64 +tTypeToCType TDouble = CDouble +tTypeToCType TBinary = CBinary +tTypeToCType TList = CList +tTypeToCType TSet = CSet +tTypeToCType TMap = CMap +tTypeToCType TStruct = CStruct + +cTypeToTType :: CType a -> TType a +cTypeToTType CStop = error "cTypeToTType: CStop" +cTypeToTType CBoolTrue = TBool +cTypeToTType CBoolFalse = TBool +cTypeToTType CByte = TByte +cTypeToTType CInt16 = TInt16 +cTypeToTType CInt32 = TInt32 +cTypeToTType CInt64 = TInt64 +cTypeToTType CDouble = TDouble +cTypeToTType CBinary = TBinary +cTypeToTType CList = TList +cTypeToTType CSet = TSet +cTypeToTType CMap = TMap +cTypeToTType CStruct = TStruct + +------------------------------------------------------------------------------ + + +string :: ByteString -> Builder +string b = serializeVarint (fromIntegral $ B.length b) <> BB.byteString b +{-# INLINE string #-} + +compactCode :: CType a -> Builder +compactCode = BB.word8 . toCompactCode +{-# INLINE compactCode #-} + +compactCode' :: CType a -- ^ The compact type code + -> Word8 -- ^ a four-bit (unshifted) payload + -> Builder +compactCode' ty payload = + BB.word8 (toCompactCode ty .|. (fromIntegral payload `shiftL` 4)) +{-# INLINE compactCode' #-} + +typeCode' :: TType a -> Word8 -> Builder +typeCode' ty = compactCode' (tTypeToCType ty) +{-# INLINE typeCode' #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch/Protocol.hs new/pinch-0.3.0.1/src/Pinch/Protocol.hs --- old/pinch-0.2.0.2/src/Pinch/Protocol.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch/Protocol.hs 2016-07-13 06:08:03.000000000 +0200 @@ -13,6 +13,7 @@ -- 'Pinch.Pinchable.Pinchable'. module Pinch.Protocol ( Protocol(..) + , deserializeValue ) where import Data.ByteString (ByteString) @@ -33,9 +34,15 @@ -- -- Returns a @Builder@ and the total length of the serialized content. - , deserializeValue - :: forall a. IsTType a => ByteString -> Either String (Value a) - -- ^ Reads a 'Value' from a ByteString. + , deserializeValue' + :: forall a. IsTType a => ByteString -> Either String (ByteString, Value a) + -- ^ Reads a 'Value' from a ByteString and returns leftovers from parse. , deserializeMessage :: ByteString -> Either String Message -- ^ Reads a 'Message' and its payload from a ByteString. } + + +-- | Reads a 'Value' from a ByteString. +deserializeValue :: forall a. IsTType a + => Protocol -> ByteString -> Either String (Value a) +deserializeValue proto = fmap snd . deserializeValue' proto diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/src/Pinch.hs new/pinch-0.3.0.1/src/Pinch.hs --- old/pinch-0.2.0.2/src/Pinch.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/src/Pinch.hs 2016-07-13 06:08:03.000000000 +0200 @@ -112,6 +112,7 @@ , Protocol , binaryProtocol + , compactProtocol -- * TType @@ -158,6 +159,7 @@ import Pinch.Internal.Value import Pinch.Protocol import Pinch.Protocol.Binary +import Pinch.Protocol.Compact ------------------------------------------------------------------------------ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/tests/Pinch/Internal/PinchableSpec.hs new/pinch-0.3.0.1/tests/Pinch/Internal/PinchableSpec.hs --- old/pinch-0.2.0.2/tests/Pinch/Internal/PinchableSpec.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/tests/Pinch/Internal/PinchableSpec.hs 2016-07-13 06:08:03.000000000 +0200 @@ -307,6 +307,10 @@ (HM.fromList [("a", 1), ("b", 2) :: (ByteString, Int16)]) + it "can unpinch empty maps" $ + unpinch' V.VNullMap `shouldBe` + Right (HM.empty :: HashMap ByteString Int16) + it "rejects key type mismatch" $ (unpinch' :: V.Value T.TMap -> Either String (HashMap Int32 Int16)) (vmap [(vbin "a", vi16 1)]) @@ -335,6 +339,10 @@ (M.fromList [("a", 1), ("b", 2) :: (ByteString, Int16)]) + it "can unpinch empty maps" $ + unpinch' V.VNullMap `shouldBe` + Right (M.empty :: Map ByteString Int16) + it "rejects key type mismatch" $ (unpinch' :: V.Value T.TMap -> Either String (Map Int32 Int16)) (vmap [(vbin "a", vi16 1)]) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/tests/Pinch/Protocol/BinarySpec.hs new/pinch-0.3.0.1/tests/Pinch/Protocol/BinarySpec.hs --- old/pinch-0.2.0.2/tests/Pinch/Protocol/BinarySpec.hs 2016-07-13 06:05:47.000000000 +0200 +++ new/pinch-0.3.0.1/tests/Pinch/Protocol/BinarySpec.hs 2016-07-13 06:08:03.000000000 +0200 @@ -17,7 +17,7 @@ import Pinch.Internal.TType import Pinch.Internal.Util import Pinch.Internal.Value (SomeValue (..), Value (..)) -import Pinch.Protocol (Protocol (..)) +import Pinch.Protocol import Pinch.Protocol.Binary (binaryProtocol) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pinch-0.2.0.2/tests/Pinch/Protocol/CompactSpec.hs new/pinch-0.3.0.1/tests/Pinch/Protocol/CompactSpec.hs --- old/pinch-0.2.0.2/tests/Pinch/Protocol/CompactSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/pinch-0.3.0.1/tests/Pinch/Protocol/CompactSpec.hs 2016-07-13 06:08:03.000000000 +0200 @@ -0,0 +1,270 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pinch.Protocol.CompactSpec (spec) where + +import Data.ByteString (ByteString) +import Data.Word (Word8) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import qualified Data.ByteString as B + +import Pinch.Arbitrary () +import Pinch.Internal.Builder (runBuilder) +import Pinch.Internal.Message +import Pinch.Internal.TType +import Pinch.Internal.Util +import Pinch.Internal.Value (SomeValue (..), Value (..)) +import Pinch.Protocol +import Pinch.Protocol.Compact (compactProtocol) + + +serialize :: IsTType a => Value a -> ByteString +serialize = runBuilder . serializeValue compactProtocol + + +deserialize :: IsTType a => ByteString -> Either String (Value a) +deserialize = deserializeValue compactProtocol + + +serializeMsg :: Message -> ByteString +serializeMsg = runBuilder . serializeMessage compactProtocol + +deserializeMsg :: ByteString -> Either String Message +deserializeMsg = deserializeMessage compactProtocol + + +-- | For each given pair, verifies that parsing the byte array yields the +-- value, and that serializing the value yields the byte array. +readWriteCases :: IsTType a => [([Word8], Value a)] -> Expectation +readWriteCases = mapM_ . uncurry $ \bytes value -> do + let bs = B.pack bytes + deserialize bs `shouldBe` Right value + serialize value `shouldBe` bs + + +readWriteMessageCases :: [([Word8], Message)] -> Expectation +readWriteMessageCases = mapM_ . uncurry $ \bytes msg -> do + let bs = B.pack bytes + deserializeMsg bs `shouldBe` Right msg + serializeMsg msg `shouldBe` bs + + +-- | For each pair, verifies that if the given TType is parsed, the request +-- fails to parse because the type ID was invalid. +invalidTypeIDCases :: [(SomeTType, [Word8])] -> Expectation +invalidTypeIDCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v + where + go :: forall a. IsTType a => TType a -> [Word8] -> Expectation + go _ bytes = + case deserialize (B.pack bytes) :: Either String (Value a) of + Right v -> expectationFailure $ + "Expected " ++ show bytes ++ " to fail to parse. " ++ + "Got: " ++ show v + Left msg -> msg `shouldContain` "Unknown CType" + + +-- | For each pair, verifies that if the given TType is parsed, the request +-- fails to parse because the input was too short. +tooShortCases :: [(SomeTType, [Word8])] -> Expectation +tooShortCases = mapM_ . uncurry $ \(SomeTType t) v -> go t v + where + go :: forall a. IsTType a => TType a -> [Word8] -> Expectation + go _ bytes = + case deserialize (B.pack bytes) :: Either String (Value a) of + Right v -> expectationFailure $ + "Expected " ++ show bytes ++ " to fail to parse. " ++ + "Got: " ++ show v + Left msg -> msg `shouldContain` "Input is too short" + + +spec :: Spec +spec = describe "CompactProtocol" $ do + + prop "can roundtrip values" $ \(SomeValue someVal) -> + deserialize (serialize someVal) === Right someVal + + prop "can roundtrip messages" $ \(msg :: Message) -> + deserializeMsg (serializeMsg msg) == Right msg + + it "can read and write booleans" $ readWriteCases + [ ([0x01], vbool True) + , ([0x02], vbool False) + ] + + it "can read and write binary" $ readWriteCases + [ ([ 0x00 ], vbin "") + , ([ 0x05 -- length = 5 + , 0x68, 0x65, 0x6c, 0x6c, 0x6f -- hello + ], vbin "hello") + ] + + it "can read and write 8-bit integers" $ readWriteCases + [ ([0x01], vbyt 1) + , ([0x05], vbyt 5) + , ([0x7f], vbyt 127) + , ([0xff], vbyt -1) + , ([0x80], vbyt -128) + ] + + it "can read and write 16-bit integers" $ readWriteCases + [ ([0x02], vi16 1) + , ([0xfe, 0x03], vi16 255) + , ([0x80, 0x04], vi16 256) + , ([0x82, 0x04], vi16 257) + , ([0xfe, 0xff, 0x03], vi16 32767) + , ([0x01], vi16 -1) + , ([0x03], vi16 -2) + , ([0xff, 0x03], vi16 -256) + , ([0xfd, 0x03], vi16 -255) + , ([0xff, 0xff, 0x03], vi16 -32768) + ] + + it "can read and write 32-bit integers" $ readWriteCases + [ ([0x02], vi32 1) + , ([0xfe, 0x03], vi32 255) + , ([0xfe, 0xff, 0x07], vi32 65535) + , ([0xfe, 0xff, 0xff, 0x0f], vi32 16777215) + , ([0xfe, 0xff, 0xff, 0xff, 0x0f], vi32 2147483647) + , ([0x01], vi32 -1) + , ([0xff, 0x03], vi32 -256) + , ([0xff, 0xff, 0x07], vi32 -65536) + , ([0xff, 0xff, 0xff, 0x0f], vi32 -16777216) + , ([0xff, 0xff, 0xff, 0xff, 0x0f], vi32 -2147483648) + ] + + it "can read and write 64-bit integers" $ readWriteCases + [ ([0x02], vi64 1) + , ([0xfe, 0xff, 0xff, 0xff, 0x1f], vi64 4294967295) + , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f], vi64 1099511627775) + , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f], vi64 281474976710655) + , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 72057594037927935) + , ([0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 9223372036854775807) + , ([0x01], vi64 -1) + , ([0xff, 0xff, 0xff, 0xff, 0x1f], vi64 -4294967296) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0x3f], vi64 -1099511627776) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f], vi64 -281474976710656) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 -72057594037927936) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x01], vi64 -9223372036854775808) + ] + + it "can read and write doubles" $ readWriteCases + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vdub 0.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vdub 1.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], vdub 1.0000000001) + , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], vdub 1.1) + , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], vdub -1.1) + , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], vdub 3.141592653589793) + , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], vdub -1.0000000001) + ] + + it "can read and write structs" $ readWriteCases + [ ([0x00], vstruct []) + + , ([ 0x15 -- ttype = i32, field ID = 1 + , 0x54 -- 42 + , 0x00 -- stop + ], vstruct [(1, vi32_ 42)]) + + , ([ 0x11 -- ttype = bool true, field ID = 1 + , 0x52 -- ttype = bool false, field ID = 6 + , 0x23, 0x2a -- ttype = byte, field ID = 8, byte 42 + , 0x03, 0x40, 0x2b -- ttype = byte, field ID = 32, byte 42 + , 0x00 -- stop + ], vstruct [(1, vbool_ True), (6, vbool_ False), (8, vbyt_ 42), (32, vbyt_ 43)]) + + , ([ 0x29 -- ttype = list, field ID = 2 + , 0x28 + + , 0x03, 0x66, 0x6f, 0x6f -- "foo" + , 0x03, 0x62, 0x61, 0x72 -- "bar" + + , 0x00 -- stop + ], vstruct + [ (2, vlist_ [vbin "foo", vbin "bar"]) + ]) + ] + + it "can read and write maps" $ readWriteCases + [ ([ 0x00 + ], vmap ([] :: [(Value TBool, Value TByte)])) + , ([ 0x01, 0x89 -- ktype = binary, vtype = list + + -- "world" + , 0x05 -- length = 5 + , 0x77, 0x6f, 0x72, 0x6c, 0x64 -- world + + -- [1, 2, 3] + , 0x33 -- type = byte, count = 3 + , 0x01, 0x02, 0x03 -- 1, 2, 3 + ], vmap + [ (vbin "world", vlist [vbyt 1, vbyt 2, vbyt 3]) + ]) + ] + + it "can read and write sets" $ readWriteCases + [ ([0x01 + ], vset ([] :: [Value TBool])) + , ([ 0x11, 0x01 + ], vset [vbool True]) + ] + + it "can read and write lists" $ readWriteCases + [ ([0x01 + ], vlist ([] :: [Value TBool])) + , ([ 0x51, 0x01, 0x02, 0x02 + , 0x01, 0x01 + ], vlist + [ vbool True + , vbool False + , vbool False + , vbool True + , vbool True + ]) + ] + + it "fails if the input is too short" $ tooShortCases + [ (SomeTType TBool, []) + , (SomeTType TByte, []) + , (SomeTType TInt16, []) + , (SomeTType TInt32, []) + , (SomeTType TInt64, []) + , (SomeTType TDouble, [0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07]) + , (SomeTType TBinary, [0x01]) + + , (SomeTType TMap, [0x02]) + , (SomeTType TMap, [0x02, 0x33]) + , (SomeTType TMap, [0x02, 0x33, 0x01]) + + , (SomeTType TSet, [0x2a]) + , (SomeTType TSet, [0x2a, 0x33, 0x00]) + + , (SomeTType TList, [0x29]) + , (SomeTType TList, [0x29, 0x33]) + ] + + it "denies invalid type IDs" $ invalidTypeIDCases + [ (SomeTType TStruct, [0x0d, 0x00, 0x01]) + , (SomeTType TMap, [0x1a, 0xd1, 0x00]) + , (SomeTType TSet, [0x1d]) + , (SomeTType TList, [0x1d]) + ] + + it "can read and write messages" $ readWriteMessageCases + [ ([ 0x82 -- Protocol id + , 0x21 -- Version and Type = Call + , 0x2a -- seqId = 42 + , 0x06 -- name length = 6 + , 0x67, 0x65, 0x74, 0x46, 0x6f, 0x6f -- 'getFoo' + , 0x00 -- stop + ], Message "getFoo" Call 42 (vstruct [])) + , ([ 0x82 -- Protocol id + , 0x41 -- Version and Type = Reply + , 0x01 -- seqId = 01 + , 0x06 -- name length = 6 + , 0x73, 0x65, 0x74, 0x42, 0x61, 0x72 -- 'setBar' + , 0x00 -- stop + ], Message "setBar" Reply 1 (vstruct [])) + ]
