diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/msgpack-types.cabal b/msgpack-types.cabal new file mode 100644 --- /dev/null +++ b/msgpack-types.cabal @@ -0,0 +1,74 @@ +name: msgpack-types +version: 0.0.4 +synopsis: A Haskell implementation of MessagePack. +homepage: http://msgpack.org/ +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Iphigenia Df +copyright: Copyright (c) 2009-2016, Hideyuki Tanaka +category: Data +stability: Experimental +cabal-version: >= 1.10 +build-type: Simple +description: + A Haskell implementation of MessagePack + . + This is a fork of 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-types.git + +library + default-language: Haskell2010 + hs-source-dirs: + src + ghc-options: + -Wall + -fno-warn-unused-imports + exposed-modules: + Data.MessagePack.Types + other-modules: + Data.MessagePack.Types.Assoc + Data.MessagePack.Types.Class + Data.MessagePack.Types.Generic + Data.MessagePack.Types.Instances + Data.MessagePack.Types.Object + build-depends: + base < 5 + , QuickCheck + , bytestring + , containers + , deepseq + , hashable + , 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: + Data.MessagePack.Types.AssocSpec + Data.MessagePack.Types.ClassSpec + ghc-options: + -Wall + -fno-warn-unused-imports + build-depends: + base < 5 + , QuickCheck + , bytestring + , containers + , deepseq + , generic-arbitrary + , hashable + , hspec + , msgpack-types + , text + , unordered-containers + , vector diff --git a/src/Data/MessagePack/Types.hs b/src/Data/MessagePack/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} +module Data.MessagePack.Types + ( Assoc (..) + , Object (..) + , MessagePack (..) + ) where + +import Data.MessagePack.Types.Assoc (Assoc (..)) +import Data.MessagePack.Types.Class (MessagePack (..)) +import Data.MessagePack.Types.Instances () +import Data.MessagePack.Types.Object (Object (..)) diff --git a/src/Data/MessagePack/Types/Assoc.hs b/src/Data/MessagePack/Types/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Assoc.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Types.Assoc +-- Copyright : (c) Daiki Handa, 2010-2011 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack map labeling type +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Types.Assoc + ( Assoc (..) + ) where + +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) + +-- not defined for general Functor for performance reason. +-- (ie. you would want to write custom instances for each type using +-- specialized mapM-like functions) +newtype Assoc a + = Assoc { unAssoc :: a } + deriving (Show, Read, Eq, Ord, Typeable, NFData) + +instance Arbitrary a => Arbitrary (Assoc a) where + arbitrary = Assoc <$> arbitrary diff --git a/src/Data/MessagePack/Types/Class.hs b/src/Data/MessagePack/Types/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Class.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Object +-- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack object definition +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Types.Class + ( MessagePack (..) + , GMessagePack (..) + ) where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Arrow ((***)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import qualified Data.Text as T +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 (Word, Word16, Word32, Word64, + Word8) +import GHC.Generics (Generic, Rep, from, to) + +import Data.MessagePack.Types.Assoc (Assoc (..)) +import Data.MessagePack.Types.Object (Object (..)) + + +-- Generic serialisation. + +class GMessagePack f where + gToObject :: f a -> Object + gFromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + => Object + -> m (f a) + + +class MessagePack a where + toObject :: a -> Object + fromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + => Object + -> m a + + default toObject :: (Generic a, GMessagePack (Rep a)) => a -> Object + toObject = genericToObject + default fromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + , Generic a, GMessagePack (Rep a)) + => Object + -> m a + fromObject = genericFromObject + + +genericToObject :: (Generic a, GMessagePack (Rep a)) => a -> Object +genericToObject = gToObject . from + +genericFromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + , Generic a + , GMessagePack (Rep a) + ) + => Object + -> m a +genericFromObject x = to <$> gFromObject x + + +-- Instances for integral types (Int etc.). + +toInt :: Integral a => a -> Int64 +toInt = fromIntegral + +fromInt :: Integral a => Int64 -> a +fromInt = fromIntegral + +toWord :: Integral a => a -> Word64 +toWord = fromIntegral + +fromWord :: Integral a => Word64 -> a +fromWord = fromIntegral + +instance MessagePack Int64 where + toObject i | i < 0 = ObjectInt i + | otherwise = ObjectWord $ toWord i + fromObject = \case + ObjectInt n -> return n + ObjectWord n -> return $ toInt n + _ -> fail "invalid encoding for integer type" + +instance MessagePack Word64 where + toObject = ObjectWord + fromObject = \case + ObjectWord n -> return n + _ -> fail "invalid encoding for integer type" + +instance MessagePack Int where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } + +instance MessagePack Word where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } +instance MessagePack Word8 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } +instance MessagePack Word16 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } +instance MessagePack Word32 where { toObject = toObject . toWord; fromObject o = fromWord <$> fromObject o } + + +-- Core instances. + +instance MessagePack Object where + toObject = id + fromObject = return + +instance MessagePack () where + toObject _ = ObjectNil + fromObject = \case + ObjectNil -> return () + ObjectArray [] -> return () + _ -> fail "invalid encoding for ()" + +instance MessagePack Bool where + toObject = ObjectBool + fromObject = \case + ObjectBool b -> return b + _ -> fail "invalid encoding for Bool" + +instance MessagePack Float where + toObject = ObjectFloat + fromObject = \case + ObjectInt n -> return $ fromIntegral n + ObjectWord n -> return $ fromIntegral n + ObjectFloat f -> return f + ObjectDouble d -> return $ realToFrac d + _ -> fail "invalid encoding for Float" + +instance MessagePack Double where + toObject = ObjectDouble + fromObject = \case + ObjectInt n -> return $ fromIntegral n + ObjectWord n -> return $ fromIntegral n + ObjectFloat f -> return $ realToFrac f + ObjectDouble d -> return d + _ -> fail "invalid encoding for Double" + +-- Because of overlapping instance, this must be above [a]. +-- IncoherentInstances and TypeSynonymInstances are required for this to work. +instance MessagePack String where + toObject = toObject . T.pack + fromObject obj = T.unpack <$> fromObject obj + + +-- Instances for binary and UTF-8 encoded string. + +instance MessagePack S.ByteString where + toObject = ObjectBin + fromObject = \case + ObjectBin r -> return r + _ -> fail "invalid encoding for ByteString" + +instance MessagePack L.ByteString where + toObject = ObjectBin . L.toStrict + fromObject obj = L.fromStrict <$> fromObject obj + +instance MessagePack T.Text where + toObject = ObjectStr + fromObject = \case + ObjectStr s -> return s + _ -> fail "invalid encoding for Text" + +instance MessagePack LT.Text where + toObject = toObject . LT.toStrict + fromObject obj = LT.fromStrict <$> fromObject obj + + +-- Instances for array-like data structures. + +instance MessagePack a => MessagePack [a] where + toObject = ObjectArray . map toObject + fromObject = \case + ObjectArray xs -> mapM fromObject xs + _ -> fail "invalid encoding for list" + +instance MessagePack a => MessagePack (V.Vector a) where + toObject = ObjectArray . map toObject . V.toList + fromObject = \case + ObjectArray o -> V.fromList <$> mapM fromObject o + _ -> fail "invalid encoding for Vector" + +instance (MessagePack a, VU.Unbox a) => MessagePack (VU.Vector a) where + toObject = ObjectArray . map toObject . VU.toList + fromObject = \case + ObjectArray o -> VU.fromList <$> mapM fromObject o + _ -> fail "invalid encoding for Unboxed Vector" + +instance (MessagePack a, VS.Storable a) => MessagePack (VS.Vector a) where + toObject = ObjectArray . map toObject . VS.toList + fromObject = \case + ObjectArray o -> VS.fromList <$> mapM fromObject o + _ -> fail "invalid encoding for Storable Vector" + +-- Instances for map-like data structures. + +instance (MessagePack a, MessagePack b) => MessagePack (Assoc [(a, b)]) where + toObject (Assoc xs) = ObjectMap $ map (toObject *** toObject) xs + fromObject = \case + ObjectMap xs -> + Assoc <$> mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs + _ -> fail "invalid encoding for Assoc" + +instance (MessagePack k, MessagePack v, Ord k) => MessagePack (Map.Map k v) where + toObject = toObject . Assoc . Map.toList + fromObject obj = Map.fromList . unAssoc <$> fromObject obj + +instance MessagePack v => MessagePack (IntMap.IntMap v) where + toObject = toObject . Assoc . IntMap.toList + fromObject obj = IntMap.fromList . unAssoc <$> fromObject obj + +instance (MessagePack k, MessagePack v, Hashable k, Eq k) => MessagePack (HashMap.HashMap k v) where + toObject = toObject . Assoc . HashMap.toList + fromObject obj = HashMap.fromList . unAssoc <$> fromObject obj + + +-- Instances for various tuple arities. + +instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where + toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] + fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where + toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] + fromObject (ObjectArray [a1, a2, a3]) = (,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4) => MessagePack (a1, a2, a3, a4) where + toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4] + fromObject (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5) => MessagePack (a1, a2, a3, a4, a5) where + toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5] + fromObject (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6) => MessagePack (a1, a2, a3, a4, a5, a6) where + toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7) => MessagePack (a1, a2, a3, a4, a5, a6, a7) where + toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8, MessagePack a9) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8, a9) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 <*> fromObject a9 + fromObject _ = fail "invalid encoding for tuple" diff --git a/src/Data/MessagePack/Types/Generic.hs b/src/Data/MessagePack/Types/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Generic.hs @@ -0,0 +1,159 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Data.MessagePack.Types.Generic () where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Monad ((>=>)) +import Data.Bits (shiftR) +import Data.Word (Word64) +import GHC.Generics + +import Data.MessagePack.Types.Class +import Data.MessagePack.Types.Object (Object (..)) + +instance GMessagePack V1 where + gToObject = undefined + gFromObject _ = fail "can't instantiate void type" + +instance GMessagePack U1 where + gToObject U1 = ObjectNil + gFromObject ObjectNil = return U1 + gFromObject _ = fail "invalid encoding for custom unit type" + +instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where + gToObject = toObject . prodToObject + gFromObject = fromObject >=> prodFromObject + +instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where + gToObject = sumToObject 0 size + where size = unTagged (sumSize :: Tagged (a :+: b) Word64) + + gFromObject = \case + ObjectWord code -> checkSumFromObject0 size (fromIntegral code) + o -> fromObject o >>= uncurry (checkSumFromObject size) + where size = unTagged (sumSize :: Tagged (a :+: b) Word64) + +instance GMessagePack a => GMessagePack (M1 t c a) where + gToObject (M1 x) = gToObject x + gFromObject x = M1 <$> gFromObject x + +instance MessagePack a => GMessagePack (K1 i a) where + gToObject (K1 x) = toObject x + gFromObject o = K1 <$> fromObject o + + +-- Product type packing. + +class GProdPack f where + prodToObject :: f a -> [Object] + prodFromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + => [Object] + -> m (f a) + + +instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where + prodToObject (a :*: b) = gToObject a : prodToObject b + prodFromObject (a : b) = (:*:) <$> gFromObject a <*> prodFromObject b + prodFromObject [] = fail "invalid encoding for product type" + +instance GMessagePack a => GProdPack (M1 t c a) where + prodToObject (M1 x) = [gToObject x] + prodFromObject [x] = M1 <$> gFromObject x + prodFromObject _ = fail "invalid encoding for product type" + + +-- Sum type packing. + +checkSumFromObject0 + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + => (GSumPack f) => Word64 -> Word64 -> m (f a) +checkSumFromObject0 size code | code < size = sumFromObject code size ObjectNil + | otherwise = fail "invalid encoding for sum type" + + +checkSumFromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a) +checkSumFromObject size code x + | code < size = sumFromObject code size x + | otherwise = fail "invalid encoding for sum type" + + +class GSumPack f where + sumToObject :: Word64 -> Word64 -> f a -> Object + sumFromObject + :: ( Applicative m + , Monad m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + => Word64 + -> Word64 + -> Object + -> m (f a) + + +instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where + sumToObject code size = \case + L1 x -> sumToObject code sizeL x + R1 x -> sumToObject (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + sumFromObject code size x + | code < sizeL = L1 <$> sumFromObject code sizeL x + | otherwise = R1 <$> sumFromObject (code - sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + +instance GSumPack (C1 c U1) where + sumToObject code _ _ = toObject code + sumFromObject _ _ = gFromObject + + +instance GMessagePack a => GSumPack (C1 c a) where + sumToObject code _ x = toObject (code, gToObject x) + sumFromObject _ _ = gFromObject + + +-- Sum size. + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged { unTagged :: b } + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + unTagged + (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/src/Data/MessagePack/Types/Instances.hs b/src/Data/MessagePack/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.MessagePack.Types.Instances () where + +import Data.Void (Void) + +import Data.MessagePack.Types.Class (MessagePack) +import Data.MessagePack.Types.Generic () + + +instance MessagePack a => MessagePack (Maybe a) +instance (MessagePack a, MessagePack b) => MessagePack (Either a b) +instance MessagePack Void diff --git a/src/Data/MessagePack/Types/Object.hs b/src/Data/MessagePack/Types/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Types/Object.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} +module Data.MessagePack.Types.Object + ( Object (..) + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.DeepSeq (NFData (..)) +import qualified Data.ByteString as S +import Data.Int (Int64) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Data.Word (Word64, Word8) +import GHC.Generics (Generic) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) +import qualified Test.QuickCheck.Gen as Gen + + +-- | Object Representation of MessagePack data. +data Object + = ObjectNil + -- ^ represents nil + | ObjectBool !Bool + -- ^ represents true or false + | ObjectInt {-# UNPACK #-} !Int64 + -- ^ represents a negative integer + | ObjectWord {-# UNPACK #-} !Word64 + -- ^ represents a positive integer + | ObjectFloat {-# UNPACK #-} !Float + -- ^ represents a floating point number + | ObjectDouble {-# UNPACK #-} !Double + -- ^ represents a floating point number + | ObjectStr !T.Text + -- ^ extending Raw type represents a UTF-8 string + | ObjectBin !S.ByteString + -- ^ extending Raw type represents a byte array + | ObjectArray ![Object] + -- ^ represents a sequence of objects + | ObjectMap ![(Object, Object)] + -- ^ represents key-value pairs of objects + | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString + -- ^ represents a tuple of an integer and a byte array where + -- the integer represents type information and the byte array represents data. + deriving (Read, Show, Eq, Ord, Typeable, Generic) + +instance NFData Object + +instance Arbitrary Object where + arbitrary = Gen.sized $ \n -> Gen.oneof + [ pure ObjectNil + , ObjectBool <$> arbitrary + , ObjectInt <$> negatives + , ObjectWord <$> arbitrary + , ObjectFloat <$> arbitrary + , ObjectDouble <$> arbitrary + , ObjectStr <$> (T.pack <$> arbitrary) + , ObjectBin <$> (S.pack <$> arbitrary) + , ObjectArray <$> Gen.resize (n `div` 2) arbitrary + , ObjectMap <$> Gen.resize (n `div` 4) arbitrary + , ObjectExt <$> arbitrary <*> (S.pack <$> arbitrary) + ] + where negatives = Gen.choose (minBound, -1) diff --git a/test/Data/MessagePack/Types/AssocSpec.hs b/test/Data/MessagePack/Types/AssocSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePack/Types/AssocSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +module Data.MessagePack.Types.AssocSpec where + +import Data.MessagePack.Types (Assoc (..)) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (Arbitrary (..), property) + +spec :: Spec +spec = + describe "Assoc" $ + it "has a working Read/Show implementation" + $ property + $ \(x :: Assoc [(Int, Int)]) -> read (show x) `shouldBe` x diff --git a/test/Data/MessagePack/Types/ClassSpec.hs b/test/Data/MessagePack/Types/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePack/Types/ClassSpec.hs @@ -0,0 +1,200 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +module Data.MessagePack.Types.ClassSpec where + +import Control.Applicative (empty, pure, (<$>), (<*>), + (<|>)) +import Control.Monad (mplus, mzero) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import Data.MessagePack.Types (Assoc (..), + MessagePack (..), + Object (..)) +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 + | 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 + + +spec :: Spec +spec = do + describe "GMessagePack" $ do + it "is a reversible operation" $ property $ \(x :: MyType) -> + fromObject (toObject x) `shouldBe` Just x + + it "handles arbitrary values" + $ withMaxSuccess 100000 + $ property + $ \ob -> fromObject ob `shouldSatisfy` \case + Just EnumTyCon -> True + Just _ -> True + Nothing -> True + + it "produces msgpack values as expected" $ do + toObject (SequenceTyCon 111 "hello") + `shouldBe` ObjectArray + [ ObjectWord 0 + , ObjectArray [ObjectWord 111, ObjectStr "hello"] + ] + toObject EnumTyCon `shouldBe` ObjectWord 1 + toObject (RecordTyCon 222) + `shouldBe` ObjectArray [ObjectWord 2, ObjectWord 222] + + describe "MessagePack" $ do + it "handles wrong encodings correctly" $ do + (fromObject $ ObjectArray [ObjectWord 1, ObjectWord 222] :: Maybe MyType) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe MyType) + `shouldBe` Nothing + (fromObject $ ObjectArray [ObjectWord 99999] :: Maybe MyType) + `shouldBe` Nothing + (fromObject $ ObjectArray [] :: Maybe MyType) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe Int64) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe BS.ByteString) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe LBS.ByteString) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe Text.Text) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe LText.Text) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (V.Vector Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (VU.Vector Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (VS.Vector Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Assoc [(Int, Int)])) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Map.Map Int Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (IntMap.IntMap Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (HashMap.HashMap Int Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe Word64) + `shouldBe` Nothing + (fromObject (ObjectArray [ObjectWord 0]) :: Maybe ()) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int, Int, Int)) + `shouldBe` Nothing + (fromObject ObjectNil :: Maybe (Int, Int, Int, Int, Int, Int, Int, Int, Int)) + `shouldBe` Nothing + + it "has a working Read/Show implementation" $ property $ \(x :: Object) -> + read (show x) `shouldBe` x + + it "can parse both nil and [] as ()" $ do + (fromObject ObjectNil :: Maybe ()) + `shouldBe` Just () + (fromObject (ObjectArray []) :: Maybe ()) + `shouldBe` Just () + + it "can parse ints and doubles as floats" $ do + (fromObject (ObjectDouble 123) :: Maybe Float) + `shouldBe` Just 123 + (fromObject (ObjectWord 123) :: Maybe Float) + `shouldBe` Just 123 + (fromObject (ObjectInt (-123)) :: Maybe Float) + `shouldBe` Just (-123) + + it "can parse ints and floats as doubles" $ do + (fromObject (ObjectFloat 123) :: Maybe Double) + `shouldBe` Just 123 + (fromObject (ObjectWord 123) :: Maybe Double) + `shouldBe` Just 123 + (fromObject (ObjectInt (-123)) :: Maybe Double) + `shouldBe` Just (-123) diff --git a/test/testsuite.hs b/test/testsuite.hs new file mode 100644 --- /dev/null +++ b/test/testsuite.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}