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 - psimons@suse.com
+
+- 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
+-- 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 []))
+ ]
