pinch 0.2.0.2 → 0.3.0.0

raw patch · 16 files changed

+850/−36 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +15/−13
• README.md +8/−2
• pinch.cabal +3/−1
• src/Pinch.hs +2/−0
• src/Pinch/Internal/Bits.hs +2/−2
• src/Pinch/Internal/Builder.hs +6/−0
• src/Pinch/Internal/FoldList.hs +8/−0
• src/Pinch/Internal/Parser.hs +16/−0
• src/Pinch/Internal/Pinchable.hs +1/−0
• src/Pinch/Internal/Value.hs +20/−10
• src/Pinch/Protocol.hs +10/−3
• src/Pinch/Protocol/Binary.hs +5/−4
• src/Pinch/Protocol/Compact.hs +475/−0
• tests/Pinch/Internal/PinchableSpec.hs +8/−0
• tests/Pinch/Protocol/BinarySpec.hs +1/−1
• tests/Pinch/Protocol/CompactSpec.hs +270/−0

@@ -1,15 +1,17 @@-0.2.0.2-=======+0.3.0.0 (2016-06-02)+==================== --   Compile on 32-bit systems.+-   Add support for the Thrift Compact Protocol (#2).+-   Add support for returning the leftover ByteString when parsing Thrift+    payloads (#3). -0.2.0.1-=======+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 +29,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. 

@@ -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. 

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           pinch-version:        0.2.0.2+version:        0.3.0.0 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

@@ -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  ------------------------------------------------------------------------------ 

@@ -18,7 +18,7 @@  #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base (Int (..), uncheckedShiftL#)-import GHC.Word (Word16 (..), Word32 (..), Word64 (..), uncheckedShiftL64#)+import GHC.Word (Word16 (..), Word32 (..), Word64 (..)) #else import Data.Bits (shiftL) import Data.Word (Word16, Word32, Word64)@@ -38,7 +38,7 @@ #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) w16ShiftL (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) w32ShiftL (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)-w64ShiftL (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)+w64ShiftL (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) #else w16ShiftL = shiftL w32ShiftL = shiftL

@@ -17,6 +17,7 @@      , append     , int8+    , word8     , int16BE     , int32BE     , int64BE@@ -94,6 +95,11 @@ int8 :: Int8 -> Builder 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

@@ -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 #-}

@@ -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 ->@@ -119,6 +129,12 @@         Nothing -> kFail "Input is too short. Expected 1 bytes. Got 0 bytes."         Just (w, b1) -> kSucc b1 (fromIntegral w) {-# 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.

@@ -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

@@ -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 ->

@@ -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

@@ -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

@@ -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 <mail@abhinavg.net>+-- 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' #-}

@@ -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)])@@ -334,6 +338,10 @@                         Right                           (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))

@@ -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)  

@@ -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 []))+        ]