msgpack-testsuite (empty) → 0.0.15
raw patch · 7 files changed
+483/−0 lines, 7 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, containers, hashable, hspec, monad-validate, msgpack-testsuite, msgpack-types, text, unordered-containers, vector
Files
- LICENSE +25/−0
- Setup.lhs +3/−0
- msgpack-testsuite.cabal +61/−0
- src/Test/MessagePack/BytePacker.hs +37/−0
- src/Test/MessagePack/Spec.hs +342/−0
- test/Test/MessagePack/SpecSpec.hs +14/−0
- test/testsuite.hs +1/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2017-2018, The TokTok Team+Copyright (c) 2009-2010, Hideyuki Tanaka+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the Hideyuki Tanaka nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ msgpack-testsuite.cabal view
@@ -0,0 +1,61 @@+name: msgpack-testsuite+version: 0.0.15+synopsis: A Haskell implementation of MessagePack+homepage: http://msgpack.org/+license: BSD3+license-file: LICENSE+author: Hideyuki Tanaka+maintainer: Iphigenia Df <iphydf@gmail.com>+copyright: Copyright (c) 2009-2016, Hideyuki Tanaka+category: Data+stability: Experimental+cabal-version: >= 1.10+build-type: Simple+description:+ A Haskell implementation of MessagePack <http://msgpack.org/>+ .+ This is a fork of msgpack-haskell <https://github.com/msgpack/msgpack-haskell>,+ since the original author is unreachable. This fork incorporates a number of+ bugfixes and is actively being developed.++source-repository head+ type: git+ location: https://github.com/TokTok/hs-msgpack-testsuite++library+ default-language: Haskell2010+ hs-source-dirs:+ src+ ghc-options:+ -Wall+ -fno-warn-unused-imports+ exposed-modules:+ Test.MessagePack.BytePacker+ Test.MessagePack.Spec+ build-depends:+ base < 5+ , QuickCheck+ , bytestring+ , containers+ , hashable+ , hspec+ , monad-validate+ , msgpack-types >= 0.2 && < 0.3+ , text+ , unordered-containers+ , vector++test-suite testsuite+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: testsuite.hs+ other-modules:+ Test.MessagePack.SpecSpec+ ghc-options:+ -Wall+ -fno-warn-unused-imports+ build-depends:+ base < 5+ , hspec+ , msgpack-testsuite
+ src/Test/MessagePack/BytePacker.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+module Test.MessagePack.BytePacker+ ( BytePacker (..)+ , unpackEither, unpack+ ) where++import Control.Monad.Validate (Validate, runValidate)+import qualified Data.ByteString.Lazy as LBS+import Data.MessagePack.Types (DecodeError, MessagePack (..))+++class BytePacker p where+ -- | Pack a Haskell value to MessagePack binary.+ pack :: MessagePack a => p -> a -> LBS.ByteString+ -- | Unpack MessagePack binary to a Haskell value.+ --+ -- On failure, returns a list of error messages.+ unpackValidate :: MessagePack a => p -> LBS.ByteString -> Validate DecodeError a+++unpackEither :: (BytePacker p, MessagePack a) => p -> LBS.ByteString -> Either DecodeError a+unpackEither p = runValidate . unpackValidate p+++-- | Unpack MessagePack binary to a Haskell value. If it fails, it fails in the+-- Monad. In the Maybe monad, failure returns Nothing.+#if (MIN_VERSION_base(4,13,0))+unpack :: (BytePacker p, Monad m, MonadFail m, MessagePack a)+#else+unpack :: (BytePacker p, Monad m, MessagePack a)+#endif+ => p -> LBS.ByteString -> m a+unpack p = eitherToM . unpackEither p+ where+ eitherToM (Left msgs) = fail $ show msgs+ eitherToM (Right res) = return res
+ src/Test/MessagePack/Spec.hs view
@@ -0,0 +1,342 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Trustworthy #-}+module Test.MessagePack.Spec where++import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck.Gen as Gen++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L8+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HashMap+import Data.Int (Int16, Int32, Int64, Int8)+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text.Lazy as LT+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Generics (Generic)++import Data.MessagePack.Types+import Test.MessagePack.BytePacker (BytePacker)+import qualified Test.MessagePack.BytePacker as BytePacker+++data Unit = Unit+ deriving (Eq, Show, Generic)++instance MessagePack Unit+++data TyConArgs = TyConArgs Int Int Int+ deriving (Eq, Show, Generic)++instance MessagePack TyConArgs+++data Record = Record+ { recordField1 :: Int+ , recordField2 :: Double+ , recordField3 :: String+ }+ deriving (Eq, Show, Generic)++instance MessagePack Record+++data Foo+ = Foo1+ | Foo2 Int+ | Foo3 Int+ | Foo4 Int+ | Foo5 Int+ | Foo6 { unFoo3 :: Int }+ | Foo7 Int+ | Foo8 Int Int+ | Foo9 Int Int Int+ deriving (Eq, Show, Generic)++instance MessagePack Foo++instance Arbitrary Foo where+ arbitrary = Gen.oneof+ [ return Foo1+ , Foo2 <$> arbitrary+ , Foo3 <$> arbitrary+ , Foo4 <$> arbitrary+ , Foo5 <$> arbitrary+ , Foo6 <$> arbitrary+ , Foo7 <$> arbitrary+ , Foo8 <$> arbitrary <*> arbitrary+ , Foo9 <$> arbitrary <*> arbitrary <*> arbitrary+ ]+++instance (Hashable k, Ord k, Eq k, Arbitrary k, Arbitrary v)+ => Arbitrary (HashMap.HashMap k v) where+ arbitrary = HashMap.fromList . Map.assocs <$> 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 S.ByteString where+ arbitrary = S.pack <$> arbitrary++instance Arbitrary L.ByteString where+ arbitrary = L.pack <$> arbitrary++instance Arbitrary LT.Text where+ arbitrary = LT.pack <$> arbitrary+++type UnpackResult a = Either DecodeError a++checkMessage :: Show a => UnpackResult a -> Expectation+checkMessage (Right res) =+ expectationFailure $ "unexpected success: " ++ show res+checkMessage (Left msgs) =+ show msgs `shouldContain` "invalid encoding for "+++spec :: BytePacker p => p -> Spec+spec p = do+ describe "unpack" $+ it "does not throw exceptions on arbitrary data" $+ property $ \bs ->+ case unpack bs of+ Just "" -> return () :: IO ()+ _ -> return () :: IO ()++ describe "Assoc" $ do+ it "supports read/show" $+ property $ \(a :: Assoc [(Int, Int)]) ->+ read (show a) `shouldBe` a++ it "inherits ordering from its contained type" $+ property $ \(a :: Assoc Int) b ->+ (unAssoc a < unAssoc b) `shouldBe` (a < b)++ describe "failures" $+ it "should contain the same start of the failure message for all types" $ do+ checkMessage (unpackEither (pack $ ObjectInt (-1)) :: UnpackResult Foo)+ checkMessage (unpackEither (pack [ObjectInt (-1), ObjectInt 0]) :: UnpackResult Foo)+ checkMessage (unpackEither (pack $ ObjectArray []) :: UnpackResult TyConArgs)+ checkMessage (unpackEither (pack $ ObjectArray []) :: UnpackResult Record)+ checkMessage (unpackEither (pack [0 :: Int, 1, 2, 3]) :: UnpackResult Record)+ checkMessage (unpackEither (pack "") :: UnpackResult Unit)+ checkMessage (unpackEither (pack "") :: UnpackResult TyConArgs)+ checkMessage (unpackEither (pack "") :: UnpackResult Record)+ checkMessage (unpackEither (pack "") :: UnpackResult ())+ checkMessage (unpackEither (pack ()) :: UnpackResult Int)+ checkMessage (unpackEither (pack ()) :: UnpackResult Bool)+ checkMessage (unpackEither (pack ()) :: UnpackResult Float)+ checkMessage (unpackEither (pack ()) :: UnpackResult Double)+ checkMessage (unpackEither (pack ()) :: UnpackResult S.ByteString)+ checkMessage (unpackEither (pack ()) :: UnpackResult LT.Text)+ checkMessage (unpackEither (pack "") :: UnpackResult [String])+ checkMessage (unpackEither (pack ()) :: UnpackResult (V.Vector Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (VS.Vector Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (VU.Vector Int))+ checkMessage (unpackEither (pack "") :: UnpackResult (Assoc [(Int, Int)]))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int, Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int, Int, Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int, Int, Int, Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int, Int, Int, Int, Int, Int))+ checkMessage (unpackEither (pack ()) :: UnpackResult (Int, Int, Int, Int, Int, Int, Int, Int, Int))++ describe "type coercion" $ do+ it "bool<-int" $+ property $ \(a :: Int) -> coerce a `shouldBe` (Nothing :: Maybe Bool)++ it "int<-bool" $+ property $ \(a :: Bool) -> coerce a `shouldBe` (Nothing :: Maybe Int)++ it "float<-int" $+ property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Float)+ it "float<-double" $+ property $ \(a :: Double) -> coerce a `shouldBe` Just (realToFrac a :: Float)+ it "float<-string" $+ property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Float)++ it "double<-int" $+ property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Double)+ it "double<-float" $+ property $ \(a :: Float) -> coerce a `shouldBe` Just (realToFrac a :: Double)+ it "double<-string" $+ property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Double)++ it "bin<-string" $+ property $ \(a :: S.ByteString) -> coerce a `shouldBe` (Nothing :: Maybe String)++ it "string<-bin" $+ property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe S.ByteString)++ describe "Identity Properties" $ do+ let sizes = [0xf, 0x10, 0x1f, 0x20, 0xff, 0x100, 0xffff, 0x10000]++ it "unit encoding" $+ Unit `shouldBe` mid Unit++ it "map encodings" $ do+ let rt n = let a = IntMap.fromList [(x, -x) | x <- [0..n]] in a `shouldBe` mid a+ mapM_ rt sizes++ it "list encodings" $ do+ let rt n = let a = replicate n "hello" in a `shouldBe` mid a+ mapM_ rt sizes++ it "vector encodings" $ do+ let rt n = let a = V.fromList [0..n] in a `shouldBe` mid a+ mapM_ rt sizes++ it "storable-vector encodings" $ do+ let rt n = let a = VS.fromList [0..n] in a `shouldBe` mid a+ mapM_ rt sizes++ it "unboxed-vector encodings" $ do+ let rt n = let a = VU.fromList [0..n] in a `shouldBe` mid a+ mapM_ rt sizes++ it "string encodings" $ do+ let rt n = let a = replicate n 'a' in a `shouldBe` mid a+ mapM_ rt sizes++ it "bytestring encodings" $ do+ let rt n = let a = S.pack $ replicate n 'a' in a `shouldBe` mid a+ mapM_ rt sizes++ it "ext encodings" $ do+ let rt n = let a = ObjectExt 0 $ S.pack $ replicate n 'a' in a `shouldBe` mid a+ mapM_ rt [0..20]+ mapM_ rt sizes++ it "int encodings" $ do+ (-0x7fffffffffffffff) `shouldBe` intMid (-0x7fffffffffffffff)+ (-0x80000000) `shouldBe` intMid (-0x80000000)+ (-0x7fffffff) `shouldBe` intMid (-0x7fffffff)+ (-0x8000) `shouldBe` intMid (-0x8000)+ (-0x7fff) `shouldBe` intMid (-0x7fff)+ (-1) `shouldBe` intMid (-1)+ 0 `shouldBe` intMid 0+ 1 `shouldBe` intMid 1+ 0x7fff `shouldBe` intMid 0x7fff+ 0x8000 `shouldBe` intMid 0x8000+ 0x7fffffff `shouldBe` intMid 0x7fffffff+ 0x80000000 `shouldBe` intMid 0x80000000+ 0x7fffffffffffffff `shouldBe` intMid 0x7fffffffffffffff++ it "int" $ property $ \(a :: Int ) -> a `shouldBe` mid a+ it "int8" $ property $ \(a :: Int8 ) -> a `shouldBe` mid a+ it "int16" $ property $ \(a :: Int16 ) -> a `shouldBe` mid a+ it "int32" $ property $ \(a :: Int32 ) -> a `shouldBe` mid a+ it "int64" $ property $ \(a :: Int64 ) -> a `shouldBe` mid a+ it "word" $ property $ \(a :: Word ) -> a `shouldBe` mid a+ it "word8" $ property $ \(a :: Word8 ) -> a `shouldBe` mid a+ it "word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a+ it "word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a+ it "word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a++ it "ext" $+ property $ \(n, a) -> ObjectExt n a `shouldBe` mid (ObjectExt n a)+ it "nil" $+ property $ \(a :: ()) -> a `shouldBe` mid a+ it "bool" $+ property $ \(a :: Bool) -> a `shouldBe` mid a+ it "float" $+ property $ \(a :: Float) -> a `shouldBe` mid a+ it "double" $+ property $ \(a :: Double) -> a `shouldBe` mid a+ it "string" $+ property $ \(a :: String) -> a `shouldBe` mid a+ it "bytestring" $+ property $ \(a :: S.ByteString) -> a `shouldBe` mid a+ it "lazy-bytestring" $+ property $ \(a :: L.ByteString) -> a `shouldBe` mid a+ it "lazy-text" $+ property $ \(a :: LT.Text) -> a `shouldBe` mid a+ it "[int]" $+ property $ \(a :: [Int]) -> a `shouldBe` mid a+ it "vector int" $+ property $ \(a :: V.Vector Int) -> a `shouldBe` mid a+ it "storable-vector int" $+ property $ \(a :: VS.Vector Int) -> a `shouldBe` mid a+ it "unboxed-vector int" $+ property $ \(a :: VU.Vector Int) -> a `shouldBe` mid a+ it "[string]" $+ property $ \(a :: [String]) -> a `shouldBe` mid a+ it "(int, int)" $+ property $ \(a :: (Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int)" $+ property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int, int)" $+ property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int, int, int)" $+ property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int, int, int, int)" $+ property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int, int, int, int, int)" $+ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int, int, int, int, int, int)" $+ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "(int, int, int, int, int, int, int, int, int)" $+ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "[(int, double)]" $+ property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a+ it "[(string, string)]" $+ property $ \(a :: [(String, String)]) -> a `shouldBe` mid a+ it "Assoc [(string, int)]" $+ property $ \(a :: Assoc [(String, Int)]) -> a `shouldBe` mid a+ it "Map String Int" $+ property $ \(a :: Map.Map String Int) -> a `shouldBe` mid a+ it "IntMap Int" $+ property $ \(a :: IntMap.IntMap Int) -> a `shouldBe` mid a+ it "HashMap String Int" $+ property $ \(a :: HashMap.HashMap String Int) -> a `shouldBe` mid a++ it "generics" $+ property $ \(a :: Foo) -> a `shouldBe` mid a+ it "arbitrary message" $+ property $ \(a :: Object) -> a `shouldBe` mid a++ describe "encoding validation" $ do+ it "word64 2^64-1" $+ pack (0xffffffffffffffff :: Word64) `shouldBe` L8.pack [0xCF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF]++ it "decodes empty array as ()" $+ unpack (pack ([] :: [Int])) `shouldBe` Just ()++ where+ mid :: MessagePack a => a -> a+ mid = Maybe.fromJust . unpack . pack++ intMid :: Int64 -> Int64+ intMid = mid++ unpackEither :: MessagePack a => L.ByteString -> Either DecodeError a+ unpackEither = BytePacker.unpackEither p++ pack :: MessagePack a => a -> L.ByteString+ pack = BytePacker.pack p++ unpack :: (MonadFail m, MessagePack a) => L.ByteString -> m a+ unpack = BytePacker.unpack p++ coerce :: (MessagePack a, MessagePack b) => a -> Maybe b+ coerce = unpack . pack
+ test/Test/MessagePack/SpecSpec.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Trustworthy #-}+module Test.MessagePack.SpecSpec where++import Test.Hspec++import Test.MessagePack.Spec++spec :: Spec+spec = do+ describe "TyConArgs" $+ it "has a working Eq instance" $ do+ TyConArgs 1 2 3 `shouldBe` TyConArgs 1 2 3+ TyConArgs 1 2 3 `shouldNotBe` TyConArgs 3 2 1
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}