{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE Trustworthy #-} module Data.MessagePack.Types.ClassSpec where import Control.Applicative (empty, pure, (<$>), (<*>), (<|>)) import Control.Monad (mplus, mzero) import Control.Monad.Validate (MonadValidate (..), runValidate) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HashMap import Data.Hashable (Hashable) import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map import Data.MessagePack.Arbitrary () import Data.MessagePack.Types (Assoc (..), MessagePack (..), Object (..), defaultConfig, errorMessages) import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Generics (Generic) import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) import Test.QuickCheck (Arbitrary (..), genericShrink, property, withMaxSuccess) import Test.QuickCheck.Arbitrary.Generic (genericArbitrary) data MyType = SequenceTyCon Int String Int Int | EnumTyCon | RecordTyCon { intValue :: Int } | F01 Int8 | F02 Int16 | F03 Int32 | F04 Int64 | F05 Word | F06 Word8 | F07 Word16 | F08 Word32 | F09 Word64 | F10 () | F11 Bool | F12 Float | F13 Double | F14 BS.ByteString | F15 LBS.ByteString | F16 Text.Text | F17 LText.Text | F18 (V.Vector Int) | F19 (VS.Vector Int) | F20 (VU.Vector Int) | F21 (Assoc [(Int, String)]) | F22 (Map.Map Int Int) | F23 (IntMap.IntMap Int) | F24 (HashMap.HashMap Int Int) | F25 (Int, Int) | F26 (Int, Int, Int) | F27 (Int, Int, Int, Int) | F28 (Int, Int, Int, Int, Int) | F29 (Int, Int, Int, Int, Int, Int) | F30 (Int, Int, Int, Int, Int, Int, Int) | F31 (Int, Int, Int, Int, Int, Int, Int, Int) | F32 (Int, Int, Int, Int, Int, Int, Int, Int, Int) deriving (Show, Eq, Generic) instance MessagePack MyType instance Arbitrary MyType where arbitrary = genericArbitrary shrink = genericShrink instance Arbitrary BS.ByteString where arbitrary = BS.pack . take 10 <$> arbitrary instance Arbitrary LBS.ByteString where arbitrary = LBS.pack . take 10 <$> arbitrary instance Arbitrary Text.Text where arbitrary = Text.pack . take 10 <$> arbitrary instance Arbitrary LText.Text where arbitrary = LText.pack . take 10 <$> arbitrary instance Arbitrary a => Arbitrary (V.Vector a) where arbitrary = V.fromList <$> arbitrary instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where arbitrary = VS.fromList <$> arbitrary instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where arbitrary = VU.fromList <$> arbitrary instance (Arbitrary a, Hashable a, Eq a, Arbitrary b) => Arbitrary (HashMap.HashMap a b) where arbitrary = HashMap.fromList <$> arbitrary type Result a = Either [String] a decode :: MessagePack a => Object -> Result a decode = mapLeft errorMessages . runValidate . fromObjectWith defaultConfig where mapLeft f (Left a) = Left (f a) mapLeft _ (Right b) = Right b spec :: Spec spec = do describe "GMessagePack" $ do it "is a reversible operation" $ withMaxSuccess 10000 $ property $ \(x :: MyType) -> decode (toObject defaultConfig x) `shouldBe` Right x it "handles arbitrary values" $ withMaxSuccess 10000 $ property $ \ob -> decode ob `shouldSatisfy` \case Right EnumTyCon -> True Right _ -> True Left _ -> True it "produces msgpack values as expected" $ do toObject defaultConfig (SequenceTyCon 111 "hello" 2 3) `shouldBe` ObjectArray (V.fromList [ ObjectWord 0 , ObjectArray (V.fromList [ObjectWord 111, ObjectStr "hello", ObjectWord 2, ObjectWord 3]) ]) toObject defaultConfig EnumTyCon `shouldBe` ObjectWord 1 toObject defaultConfig (RecordTyCon 222) `shouldBe` ObjectArray (V.fromList [ObjectWord 2, ObjectWord 222]) describe "MessagePack" $ do it "handles wrong encodings correctly" $ do (decode $ ObjectArray (V.fromList [ObjectWord 1, ObjectWord 222]) :: Result MyType) `shouldBe` Left ["invalid encoding for custom unit type"] (decode ObjectNil :: Result MyType) `shouldBe` Left ["invalid encoding for tuple"] (decode $ ObjectArray (V.fromList [ObjectWord 99999]) :: Result MyType) `shouldBe` Left ["invalid encoding for tuple"] (decode $ ObjectArray V.empty :: Result MyType) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result Int64) `shouldBe` Left ["invalid encoding for integer type"] (decode ObjectNil :: Result BS.ByteString) `shouldBe` Left ["invalid encoding for ByteString"] (decode ObjectNil :: Result LBS.ByteString) `shouldBe` Left ["invalid encoding for ByteString"] (decode ObjectNil :: Result Text.Text) `shouldBe` Left ["invalid encoding for Text"] (decode ObjectNil :: Result LText.Text) `shouldBe` Left ["invalid encoding for Text"] (decode ObjectNil :: Result (V.Vector Int)) `shouldBe` Left ["invalid encoding for Vector"] (decode ObjectNil :: Result (VU.Vector Int)) `shouldBe` Left ["invalid encoding for Unboxed Vector"] (decode ObjectNil :: Result (VS.Vector Int)) `shouldBe` Left ["invalid encoding for Storable Vector"] (decode ObjectNil :: Result (Assoc [(Int, Int)])) `shouldBe` Left ["invalid encoding for Assoc"] (decode ObjectNil :: Result (Map.Map Int Int)) `shouldBe` Left ["invalid encoding for Assoc"] (decode ObjectNil :: Result (IntMap.IntMap Int)) `shouldBe` Left ["invalid encoding for Assoc"] (decode ObjectNil :: Result (HashMap.HashMap Int Int)) `shouldBe` Left ["invalid encoding for Assoc"] (decode ObjectNil :: Result Word64) `shouldBe` Left ["invalid encoding for integer type"] (decode (ObjectArray (V.fromList [ObjectWord 0])) :: Result ()) `shouldBe` Left ["invalid encoding for ()"] (decode ObjectNil :: Result (Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode ObjectNil :: Result (Int, Int, Int, Int, Int, Int, Int, Int)) `shouldBe` Left ["invalid encoding for tuple"] (decode $ ObjectArray (V.fromList [ObjectNil, ObjectNil]) :: Result (Int, String)) `shouldBe` Left ["invalid encoding for integer type", "invalid encoding for Text"] it "has a working Read/Show implementation" $ property $ \(x :: Object) -> read (show x) `shouldBe` x it "can parse both nil and [] as ()" $ do (decode ObjectNil :: Result ()) `shouldBe` Right () (decode (ObjectArray V.empty) :: Result ()) `shouldBe` Right () it "can parse ints and doubles as floats" $ do (decode (ObjectDouble 123) :: Result Float) `shouldBe` Right 123 (decode (ObjectWord 123) :: Result Float) `shouldBe` Right 123 (decode (ObjectInt (-123)) :: Result Float) `shouldBe` Right (-123) it "can parse ints and floats as doubles" $ do (decode (ObjectFloat 123) :: Result Double) `shouldBe` Right 123 (decode (ObjectWord 123) :: Result Double) `shouldBe` Right 123 (decode (ObjectInt (-123)) :: Result Double) `shouldBe` Right (-123)