{-# 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) , ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x3f], vdub 1.0) , ([0x38, 0xdf, 0x06, 0x00, 0x00, 0x00, 0xf0, 0x3f], vdub 1.0000000001) , ([0x9a, 0x99, 0x99, 0x99, 0x99, 0x99, 0xf1, 0x3f], vdub 1.1) , ([0x9a, 0x99, 0x99, 0x99, 0x99, 0x99, 0xf1, 0xbf], vdub -1.1) , ([0x18, 0x2d, 0x44, 0x54, 0xfb, 0x21, 0x09, 0x40], vdub 3.141592653589793) , ([0x38, 0xdf, 0x06, 0x00, 0x00, 0x00, 0xf0, 0xbf], 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 [])) ]