packages feed

packer-messagepack (empty) → 0.1.0.0

raw patch · 10 files changed

+1663/−0 lines, 10 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, hedgehog, packer, packer-messagepack, safe-exceptions, text, unliftio

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Moritz Schulte (c) 2017++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 Moritz Schulte nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 THE COPYRIGHT+OWNER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,122 @@+# packer-messagepack [![Hackage version](https://img.shields.io/hackage/v/packer-messagepack.svg?label=Hackage)](https://hackage.haskell.org/package/packer-messagepack) [![Build Status](https://travis-ci.org/mtesseract/packer-messagepack.svg?branch=master)](https://travis-ci.org/mtesseract/packer-messagepack)++### About++This package provides [MessagePack](http://msgpack.org/index.html)+serialization / deserialization built on top of+[Packer](https://hackage.haskell.org/package/packer).++More precisely, this package exposes the following:++- the type class `ToMsgPack`:++```haskell+class ToMsgPack a where+  toMsgPack :: a -> Packing ()+  msgPackSize :: MonadThrow m => a -> m Int64+```++- the type class `FromMsgPack`:++```haskell+class FromMsgPack a where+  fromMsgPack :: Unpacking a+```++- the type `Object`:++```haskell+data Object = ObjectString Text+            | ObjectBinary ByteString+            | ObjectUInt Word64+            | ObjectInt Int64+            | ObjectBool Bool+            | ObjectFloat32 Float+            | ObjectFloat64 Double+            | ObjectArray [Object]+            | ObjectMap (Map Object Object)+            | ObjectNil+```++- Instances for the following types:++  - Bool+  - Int+  - Word8+  - Word16+  - Word32+  - Word64+  - Int8+  - Int16+  - Int32+  - Int64+  - Float+  - Double+  - ByteString+  - Text+  - Object++  - Furthermore there are instances for++    - lists `[a]`, if the type `a` is an instance of `FromMsgPack`+      resp. `ToMsgPack`.++    - maps `Map k v` if the types `k` and `v` are instances of+      `FromMsgPack` resp. `ToMsgPack`.++### Usage++For example, to serialize a number into a MessagePack encoded+ByteString, use:++```haskell+let n = 2342 :: Int+size <- msgPackSize n+let bytes = runPacking size (toMsgPack n)+```++To deserialize a `ByteString` you can use `fromMsgPack` specialized to+`fromMsgPack :: Unpacking Object` in case the type of the next+MessagePack object is not known. For example:++```haskell+let obj = runUnpacking fromMsgPack bytes :: Object+```++On the other hand, if a specific type is expected, `fromMsgPack` can+be used specialized to the respective type as follows:++```haskell+let n' = runUnpacking fromMsgPack bytes :: Int+```++Note that a MessagePack signed (resp. unsigned) integer can be as big+as an `Int64` (resp. `Word64`). Therefore, if you want to make sure+that there are no overflow problems, use `Int64` (resp. `Word64`)+during deserialization. In case of overflows exceptions will be+thrown. For example:++```haskell+let n = (2^62) :: Int64+size <- msgPackSize n+let bytes = runPacking size (toMsgPack n)+    n' = runUnpacking fromMsgPack bytes :: Int32+```++Because the number `2^62` exceeds the boundaries of `Int32`, `n'` will+denote a pure exception:++```haskell+MsgPackDeserializationFailure "Integer Overflow"+```++### Stackage++Currently, [Packer](https://hackage.haskell.org/package/packer) is not+included in [Stackage](https://www.stackage.org/) yet. Therefore, if+you would like to use this package together with Stackage, you could+pull them in via extra-deps. For example:++```+extra-deps: [packer-VERSION, packer-messagepack-VERSION]+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ packer-messagepack.cabal view
@@ -0,0 +1,59 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:           packer-messagepack+version:        0.1.0.0+synopsis:       MessagePack Serialization an Deserialization for Packer+description:    This package implements MessagePack on top of the Packer package.+category:       Data+homepage:       https://github.com/mtesseract/packer-msgpack#readme+author:         Moritz Schulte+maintainer:     mtesseract@silverratio.net+copyright:      (c) 2017 Moritz Schulte+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    README.md++library+  hs-source-dirs:+      src+  ghc-options: -Wall -fno-warn-type-defaults+  build-depends:+      base >= 4.7 && < 5+    , packer >= 0.1.9 && < 0.2+    , unliftio+    , text+    , bytestring+    , containers+    , safe-exceptions+  exposed-modules:+      Data.Packer.MessagePack+      Data.Packer.MessagePack.Internal.Util+  other-modules:+      Data.Packer.MessagePack.Internal.Constants+      Data.Packer.MessagePack.Internal.Exceptions+      Data.Packer.MessagePack.Internal.Types+      Paths_packer_messagepack+  default-language: Haskell2010++test-suite packer-msgpack-test-suite+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  hs-source-dirs:+      tests+  ghc-options: -Wall -fno-warn-type-defaults -threaded+  build-depends:+      base >= 4.7 && < 5+    , packer >= 0.1.9 && < 0.2+    , packer-messagepack+    , hedgehog+    , containers+    , bytestring+    , text+    , safe-exceptions+  default-language: Haskell2010
+ src/Data/Packer/MessagePack.hs view
@@ -0,0 +1,8 @@+module Data.Packer.MessagePack+  ( ToMsgPack(..)+  , FromMsgPack(..)+  , Object(..)+  , MsgPackException(..)+  ) where++import           Data.Packer.MessagePack.Internal.Types
+ src/Data/Packer/MessagePack/Internal/Constants.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE BinaryLiterals #-}++module Data.Packer.MessagePack.Internal.Constants where++import           Data.Word (Word8)++markerBoolFalse :: Word8+markerBoolFalse = 0xC2++markerBoolTrue :: Word8+markerBoolTrue = 0xC3++markerUInt8 :: Word8+markerUInt8 = 0xCC++markerInt8 :: Word8+markerInt8 = 0xD0++markerUInt16 :: Word8+markerUInt16 = 0xCD++markerInt16 :: Word8+markerInt16 = 0xD1++markerUInt32 :: Word8+markerUInt32 = 0xCE++markerInt32 :: Word8+markerInt32 = 0xD2++markerUInt64 :: Word8+markerUInt64 = 0xCF++markerInt64 :: Word8+markerInt64 = 0xD3++markerNil :: Word8+markerNil = 0xC0++markerBin8 :: Word8+markerBin8 = 0xC4++markerBin16 :: Word8+markerBin16 = 0xC5++markerBin32 :: Word8+markerBin32 = 0xC6++markerFloat32 :: Word8+markerFloat32 = 0xCA++markerFloat64 :: Word8+markerFloat64 = 0xCB++markerFixStr :: Word8+markerFixStr = 0b10100000++markerStr8 :: Word8+markerStr8 = 0xD9++markerStr16 :: Word8+markerStr16 = 0xDA++markerStr32 :: Word8+markerStr32 = 0xDB++markerFixArray :: Word8+markerFixArray = 0b10010000++markerArray16 :: Word8+markerArray16 = 0xDC++markerArray32 :: Word8+markerArray32 = 0xDD++markerFixMap :: Word8+markerFixMap = 0b10000000++markerMap16 :: Word8+markerMap16 = 0xDE++markerMap32 :: Word8+markerMap32 = 0xDF
+ src/Data/Packer/MessagePack/Internal/Exceptions.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Packer.MessagePack.Internal.Exceptions where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Monoid+import           Data.Packer+import           Data.Text+import           Data.Word+import           UnliftIO.Exception++data MsgPackException = MsgPackDeserializationFailure Text+                      | MsgPackSerializationFailure Text+  deriving (Show)++instance Exception MsgPackException++deserializationFailure :: MonadIO m => Text -> m a+deserializationFailure msg =+  throwIO $ MsgPackDeserializationFailure ("Expected " <> msg)++deserializationAssert :: Word8 -> Text -> Unpacking ()+deserializationAssert w msg = do+  w' <- getWord8+  unless (w == w') $+    deserializationFailure msg
+ src/Data/Packer/MessagePack/Internal/Types.hs view
@@ -0,0 +1,663 @@+{-# LANGUAGE BinaryLiterals      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Packer.MessagePack.Internal.Types+  ( ToMsgPack(..)+  , FromMsgPack(..)+  , Object(..)+  , MsgPackException(..)+  ) where++import           Control.Exception.Safe                      (MonadThrow, throw)+import           Control.Monad+import           Data.Bits+import           Data.Bool+import           Data.ByteString                             (ByteString)+import qualified Data.ByteString                             as ByteString+import           Data.Int+import           Data.Map                                    (Map)+import qualified Data.Map                                    as Map+import           Data.Monoid+import           Data.Packer+import           Data.Packer.MessagePack.Internal.Constants+import           Data.Packer.MessagePack.Internal.Exceptions+import           Data.Packer.MessagePack.Internal.Util+import           Data.Text                                   (Text)+import qualified Data.Text                                   as Text+import qualified Data.Text.Encoding                          as Text+import           Data.Word+import           GHC.Generics+import           UnliftIO.Exception++-- | Type class for values which support MessagePack serialization.+class ToMsgPack a where+  -- | Serializes the provided value as MessagePack within a 'Packing'+  -- monad.+  toMsgPack :: a -> Packing ()+  -- | Computes the size of the serialized data in bytes.+  msgPackSize :: MonadThrow m => a -> m Int++-- | Type class for values which support MessagePack deserialization.+class FromMsgPack a where+  -- | Deserializes a MessagePack value in an 'Unpacking' monad.+  fromMsgPack :: Unpacking a++-- | Serialize a single 'Word64' value. Depending on the size of the+-- value, one of the follow formats is used:+--+--  - Pos FixInt+--  - UInt  8+--  - UInt 16+--  - UInt 32+--  - UInt 64+toMsgPackUInt :: Word64 -> Packing ()+toMsgPackUInt x+  | x < 2^7   = putWord8 (fromIntegral x)+  | x < 2^8   = putWord8 markerUInt8  >> putWord8    (fromIntegral x)+  | x < 2^16  = putWord8 markerUInt16 >> putWord16BE (fromIntegral x)+  | x < 2^32  = putWord8 markerUInt32 >> putWord32BE (fromIntegral x)+  | otherwise = putWord8 markerUInt64 >> putWord64BE (fromIntegral x)++-- | Computes the deserialization size of the provided 'Word64'+-- number.+sizeMsgPackUInt :: Word64 -> Int+sizeMsgPackUInt x+  | x < 2^7   = 1+  | x < 2^8   = 2+  | x < 2^16  = 3+  | x < 2^32  = 5+  | otherwise = 9++-- | Deserialize an unsigned integer as a 'Word64' value.+fromMsgPackUInt :: Unpacking Word64+fromMsgPackUInt = do+  w <- getWord8+  if | hasMarkerPosFixNum w  -> fromIntegral <$> pure w+     | w == markerUInt8      -> fromIntegral <$> getWord8+     | w == markerUInt16     -> fromIntegral <$> getWord16BE+     | w == markerUInt32     -> fromIntegral <$> getWord32BE+     | w == markerUInt64     -> fromIntegral <$> getWord64BE+     | otherwise             -> throwIO (exn w)+  where exn w    = MsgPackDeserializationFailure (exnMsg w)+        exnMsg w = "Invalid UInt Marker: " <> Text.pack (show w)++-- | Serialize a single 'Int64' value. Depending on the size of the+-- value, one of the follow formats is used:+--+--  - Pos FixInt+--  - Neg FixInt+--  - Int  8+--  - Int 16+--  - Int 32+--  - Int 64+toMsgPackInt :: Int64 -> Packing ()+toMsgPackInt x+  | 0     <= x && x < 2^7  = putWord8 (fromIntegral x)+  | -2^5  <= x && x < 0    = putWord8 (fromIntegral x)+  | -2^7  <= x && x < 2^7  = putWord8 markerInt8  >> putWord8    (fromIntegral x)+  | -2^15 <= x && x < 2^15 = putWord8 markerInt16 >> putWord16BE (fromIntegral x)+  | -2^31 <= x && x < 2^31 = putWord8 markerInt32 >> putWord32BE (fromIntegral x)+  | otherwise              = putWord8 markerInt64 >> putWord64BE (fromIntegral x)++-- | Computes the deserialization size of the provided 'Int64' number.+sizeMsgPackInt :: Int64 -> Int+sizeMsgPackInt x+  | 0     <= x && x < 2^7  = 1+  | -2^5  <= x && x < 0    = 1+  | -2^7  <= x && x < 2^7  = 2+  | -2^15 <= x && x < 2^15 = 3+  | -2^31 <= x && x < 2^31 = 5+  | otherwise              = 9++-- | Deserialize a signed integer as an 'Int64' value.+fromMsgPackInt :: Unpacking Int64+fromMsgPackInt = do+  w <- getWord8+  if | hasMarkerPosFixNum w -> fromIntegral <$> pure w+     | hasMarkerNegFixNum w -> fromIntegral . (fromIntegral :: Word8  -> Int8)  <$> pure w+     | w == markerInt8      -> fromIntegral . (fromIntegral :: Word8  -> Int8)  <$> getWord8+     | w == markerInt16     -> fromIntegral . (fromIntegral :: Word16 -> Int16) <$> getWord16BE+     | w == markerInt32     -> fromIntegral . (fromIntegral :: Word32 -> Int32) <$> getWord32BE+     | w == markerInt64     -> fromIntegral . (fromIntegral :: Word64 -> Int64) <$> getWord64BE+     | otherwise            -> throwIO (exn w)+  where exn w    = MsgPackDeserializationFailure (exnMsg w)+        exnMsg w = "Invalid Int Marker: " <> Text.pack (show w)++-- | Data type wrapping any supported MessagePack value.+data Object = ObjectString Text+            | ObjectBinary ByteString+            | ObjectUInt Word64+            | ObjectInt Int64+            | ObjectBool Bool+            | ObjectFloat32 Float+            | ObjectFloat64 Double+            | ObjectArray [Object]+            | ObjectMap (Map Object Object)+            | ObjectNil+  deriving (Eq, Show, Ord, Generic)++-- | ToMsgPack instance for boolean values. This implements+-- serialization for the MessagePack bool format family.+instance ToMsgPack Bool where+  toMsgPack = putWord8 . bool markerBoolFalse markerBoolTrue+  msgPackSize _ = return 1++-- | FromMsgPack instance for boolean values. This implements+-- deserialization for the MessagePack bool format family.+instance FromMsgPack Bool where+  fromMsgPack = getWord8 >>= \w ->+    if | w == markerBoolTrue  -> return True+       | w == markerBoolFalse -> return False+       | otherwise            -> deserializationFailure "Bool"++-- | ToMsgPack instance for 'Word8' values. This implements+-- serialization for those unsigned values within the MessagePack int+-- format family, which fit in a 'Word8': positive fixint, uint8.+instance ToMsgPack Word8 where+  toMsgPack = toMsgPack . (fromIntegral :: Word8 -> Word64)+  msgPackSize = msgPackSize . (fromIntegral :: Word8 -> Word64)++-- | FromMsgPack instance for 'Word8' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in a 'Word8': positive fixint, uint8.+-- Deserializing bigger values will cause a+-- 'MsgPackDeserializationFailure' exception to be thrown.+instance FromMsgPack Word8 where+  fromMsgPack = fromMsgPackUInt >>= shrinkTypeIO++-- | ToMsgPack instance for 'Int' values. This implements+-- serialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int' (at least positive fixint,+-- negative fixint, int8, int16).+instance ToMsgPack Int where+  toMsgPack = toMsgPack . (fromIntegral :: Int -> Int64)+  msgPackSize = msgPackSize . (fromIntegral :: Int -> Int64)++-- | ToMsgPack instance for 'Int8' values. This implements+-- serialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int8': positive fixint, negative+-- fixint, int8.+instance ToMsgPack Int8 where+  toMsgPack = toMsgPack . (fromIntegral :: Int8 -> Int64)+  msgPackSize = msgPackSize . (fromIntegral :: Int8 -> Int64)++-- | FromMsgPack instance for 'Int' values. This implements+-- deserialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int' (at least positive fixint,+-- negative fixint, int8, int16). Deserializing bigger values will+-- cause a 'MsgPackDeserializationFailure' exception to be thrown.+instance FromMsgPack Int where+  fromMsgPack = fromMsgPackInt >>= shrinkTypeIO++-- | FromMsgPack instance for 'Int8' values. This implements+-- deserialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int8': positive fixint, negative+-- fixint, int8. Deserializing bigger values will cause a+-- 'MsgPackDeserializationFailure' exception to be thrown.+instance FromMsgPack Int8 where+  fromMsgPack = fromMsgPackInt >>= shrinkTypeIO++-- | ToMsgPack instance for 'Word16' values. This implements+-- serialization for those unsigned values within the MessagePack int+-- format family, which fit in a 'Word16': positive fixint, uint8,+-- uint16.+instance ToMsgPack Word16 where+  toMsgPack = toMsgPack . (fromIntegral :: Word16 -> Word64)+  msgPackSize = msgPackSize . (fromIntegral :: Word16 -> Word64)++-- | FromMsgPack instance for 'Word16' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in a 'Word16': positive fixint, uint8,+-- uint16. Deserializing bigger values will cause a+-- 'MsgPackDeserializationFailure' exception to be thrown.+instance FromMsgPack Word16 where+  fromMsgPack = fromMsgPackUInt >>= shrinkTypeIO++-- | ToMsgPack instance for 'Int16' values. This implements+-- serialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int16': positive fixint, negative+-- fixint, int8, int16.+instance ToMsgPack Int16 where+  toMsgPack = toMsgPack . (fromIntegral :: Int16 -> Int64)+  msgPackSize = msgPackSize . (fromIntegral :: Int16 -> Int64)++-- | FromMsgPack instance for 'Int16' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in an 'Int16': positive fixint,+-- negative fixint, int8, int16. Deserializing bigger values will+-- cause a 'MsgPackDeserializationFailure' exception to be thrown.+instance FromMsgPack Int16 where+  fromMsgPack = fromMsgPackInt >>= shrinkTypeIO++-- | ToMsgPack instance for 'Word32' values. This implements+-- serialization for those unsigned values within the MessagePack int+-- format family, which fit in a 'Word32': positive fixint, uint8,+-- uint16, uint32.+instance ToMsgPack Word32 where+  toMsgPack = toMsgPack . (fromIntegral :: Word32 -> Word64)+  msgPackSize = msgPackSize . (fromIntegral :: Word32 -> Word64)++-- | FromMsgPack instance for 'Word32' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in a 'Word32': positive fixint, uint8,+-- uint16, uint32. Deserializing bigger values will cause a+-- 'MsgPackDeserializationFailure' exception to be thrown.+instance FromMsgPack Word32 where+  fromMsgPack = fromMsgPackUInt >>= shrinkTypeIO++-- | ToMsgPack instance for 'Int32' values. This implements+-- serialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int32': positive fixint, negative+-- fixint, int8, int16, int32.+instance ToMsgPack Int32 where+  toMsgPack = toMsgPack . (fromIntegral :: Int32 -> Int64)+  msgPackSize = msgPackSize . (fromIntegral :: Int32 -> Int64)++-- | FromMsgPack instance for 'Int32' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in an 'Int16': positive fixint,+-- negative fixint, int8, int16, int32. Deserializing bigger values+-- will cause a 'MsgPackDeserializationFailure' exception to be+-- thrown.+instance FromMsgPack Int32 where+  fromMsgPack = fromMsgPackInt >>= shrinkTypeIO++-- | ToMsgPack instance for '64' values. This implements+-- serialization for those unsigned values within the MessagePack int+-- format family, which fit in a 'Word64': positive fixint, uint8,+-- uint16, uint32, uint64.+instance ToMsgPack Word64 where+  toMsgPack = toMsgPackUInt+  msgPackSize = return . sizeMsgPackUInt++-- | FromMsgPack instance for 'Word64' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in a 'Word64': positive fixint, uint8,+-- uint16, uint32, uint64.+instance FromMsgPack Word64 where+  fromMsgPack = fromMsgPackUInt++-- | ToMsgPack instance for 'Int64' values. This implements+-- serialization for those signed values within the MessagePack int+-- format family, which fit in an 'Int64': positive fixint, negative+-- fixint, int8, int16, int32, int64.+instance ToMsgPack Int64 where+  toMsgPack   = toMsgPackInt+  msgPackSize = return . sizeMsgPackInt++-- | FromMsgPack instance for 'Int64' values. This implements+-- deserialization for those unsigned values within the MessagePack+-- int format family, which fit in an 'Int64': positive fixint,+-- negative fixint, int8, int16, int32, int64.+instance FromMsgPack Int64 where+  fromMsgPack = fromMsgPackInt++-- | ToMsgPack instance for float values. This implements+-- serialization for the MessagePack float32 format family.+instance ToMsgPack Float where+  toMsgPack x = putWord8 markerFloat32 >> putFloat32BE x+  msgPackSize _ = return 5++-- | FromMsgPack instance for float values. This implements+-- deserialization for the MessagePack float32 format family.+instance FromMsgPack Float where+  fromMsgPack = deserializationAssert markerFloat32 "Float32" >> getFloat32BE++-- | ToMsgPack instance for double values. This implements+-- serialization for the MessagePack float64 format family.+instance ToMsgPack Double where+  toMsgPack x = putWord8 markerFloat64 >> putFloat64BE x+  msgPackSize _ = return 9++-- | FromMsgPack instance for double values. This implements+-- deserialization for the MessagePack float64 format family.+instance FromMsgPack Double where+  fromMsgPack = do+    deserializationAssert markerFloat64 "Float64"+    getFloat64BE++-- | ToMsgPack instance for 'ByteString's. This implements+-- serialization for the MessagePack bin format family for raw binary+-- strings up to a length of @2^32 - 1@.+instance ToMsgPack ByteString where+  toMsgPack bs+    | l < 2^8   = putWord8 markerBin8  >> putWord8    l >> putBytes bs+    | l < 2^16  = putWord8 markerBin16 >> putWord16BE l >> putBytes bs+    | l < 2^32  = putWord8 markerBin32 >> putWord32BE l >> putBytes bs+    | otherwise = failWithException++    where l :: Integral a => a+          l = fromIntegral $ ByteString.length bs+          failWithException = throwIO $ MsgPackSerializationFailure "ByteString too long"++  msgPackSize bs =+    if | l < 2^8   -> return (2 + l)+       | l < 2^16  -> return (3 + l)+       | l < 2^32  -> return (5 + l)+       | otherwise -> throw $ MsgPackSerializationFailure "ByteString too long"++    where l = fromIntegral (ByteString.length bs) -- FIXME++-- | FromMsgPack instance for 'ByteString's. This implements+-- deserialization for the MessagePack bin format family for raw binary+-- strings up to a length of @2^32 - 1@.+instance FromMsgPack ByteString where+  fromMsgPack = do+    w <- getWord8+    l <- if | w == markerBin8  -> fromIntegral <$> getWord8+            | w == markerBin16 -> fromIntegral <$> getWord16BE+            | w == markerBin32 -> fromIntegral <$> getWord32BE+            | otherwise        -> failWithException w+    getBytes l -- FIXME overflow++      where failWithException w =+              let msg = "Missing marker: Raw Bin (found " <> Text.pack (show w) <> ")"+              in throwIO $ MsgPackDeserializationFailure msg++-- | ToMsgPack instance for 'Text's. This implements serialization for+-- the MessagePack str format family for UTF8 encoded strings up to a+-- length of @2^32 - 1@.+instance ToMsgPack Text where+  toMsgPack t+    | l < 2^5   = putWord8 (markerFixStr .|. l)                          >> putBytes bs+    | l < 2^8   = putWord8 markerStr8  >> putWord8    (l .&.       0xFF) >> putBytes bs+    | l < 2^16  = putWord8 markerStr16 >> putWord16BE (l .&.     0xFFFF) >> putBytes bs+    | l < 2^32  = putWord8 markerStr32 >> putWord32BE (l .&. 0xFFFFFFFF) >> putBytes bs+    | otherwise = failWithException++    where bs = Text.encodeUtf8 t+          l :: Integral a => a+          l  = fromIntegral $ ByteString.length bs+          failWithException = throwIO $ MsgPackSerializationFailure "Text too long"++  msgPackSize t =+    if | l < 32    -> return (1 + l)+       | l < 2^8   -> return (2 + l)+       | l < 2^16  -> return (3 + l)+       | l < 2^32  -> return (5 + l)+       | otherwise -> throw $ MsgPackSerializationFailure "Text too long"++    where bs = Text.encodeUtf8 t+          l  = fromIntegral $ ByteString.length bs++-- | FromMsgPack instance for 'Text'. This implements deserialization+-- for the MessagePack str format family for UTF8 encoded strings up+-- to a length of @2^32 - 1@.+instance FromMsgPack Text where+  fromMsgPack = do+    w <- getWord8+    l <- if | hasMarkerFixStr w -> fromIntegral <$> pure (w .&. 0b00011111)+            | w == markerStr8   -> fromIntegral <$> getWord8+            | w == markerStr16  -> fromIntegral <$> getWord16BE+            | w == markerStr32  -> fromIntegral <$> getWord32BE+            | otherwise         -> failWithException w+    Text.decodeUtf8 <$> getBytes l++      where failWithException w = throwIO $ MsgPackDeserializationFailure (exnMsg w)+            exnMsg w = "Missing Marker: Raw String (found " <> Text.pack (show w) <> ")"++-- | ToMsgPack instance for lists. This implements serialization for+-- the MessagePack array format family for collections of up to a+-- length of @2^32 - 1@.+instance ToMsgPack a => ToMsgPack [a] where+  toMsgPack array+    | l < 16    = putWord8 (markerFixArray .|. (fromIntegral l .&. 0x0F)) >> mapM_ toMsgPack array+    | l < 2^16  = putWord8 markerArray16 >> putWord16BE (fromIntegral l)  >> mapM_ toMsgPack array+    | l < 2^32  = putWord8 markerArray32 >> putWord32BE (fromIntegral l)  >> mapM_ toMsgPack array+    | otherwise =  throwIO $ MsgPackSerializationFailure "Array too long"++    where l = length array++  msgPackSize array =+    if | l < 16    -> (1 +) <$> arraySize array+       | l < 2^16  -> (3 +) <$> arraySize array+       | l < 2^32  -> (5 +) <$> arraySize array+       | otherwise -> throw exn++    where l = fromIntegral (length array)+          arraySize a = sum <$> mapM msgPackSize a+          exn = MsgPackSerializationFailure "Array too long"++-- | FromMsgPack instance for lists. This implements deserialization+-- for the MessagePack array format family for collections of up to a+-- length of @2^32 - 1@.+instance FromMsgPack a => FromMsgPack [a] where+  fromMsgPack = do+    w <- getWord8+    l <- if | hasMarkerFixArray w -> fromIntegral <$> pure (w .&. 0b00001111)+            | w == markerArray16  -> fromIntegral <$> getWord16BE+            | w == markerArray32  -> fromIntegral <$> getWord32BE+            | otherwise           -> failWithException w+    replicateM (fromIntegral l) fromMsgPack++      where failWithException w =+              let msg = "Missing Marker: Array (found " <> Text.pack (show w) <> ")"+              in throwIO $ MsgPackDeserializationFailure msg++-- | ToMsgPack instance for pairs. This instance serializes the first+-- value of the pair and then the second value of the pair.+instance (ToMsgPack a, ToMsgPack b) => ToMsgPack (a, b) where+  toMsgPack (a, b) = toMsgPack a >> toMsgPack b+  msgPackSize (a, b) = liftM2 (+) (msgPackSize a) (msgPackSize b)++-- | FromMsgPack instance for pairs. This instance deserializes the+-- first value of the pair and then the second value of the pair.+instance (FromMsgPack a, FromMsgPack b) => FromMsgPack (a, b) where+  fromMsgPack = liftM2 (,) fromMsgPack fromMsgPack++-- | FromMsgPack instance for maps. This implements deserialization+-- for the MessagePack map format family for maps of up to @2^32 - 1@+-- keys resp. values.+instance (ToMsgPack k, ToMsgPack v) => ToMsgPack (Map k v) where+  toMsgPack m+    | l < 16 = do+        putWord8 $ markerFixMap .|. (fromIntegral l .&. 0x0F)+        mapM_ toMsgPack objects+    | l < 2^16 = do+        putWord8 markerMap16+        putWord16BE $ fromIntegral l+        mapM_ toMsgPack objects+    | l < 2^32 = do+        putWord8 markerMap32+        putWord32BE $ fromIntegral l+        mapM_ toMsgPack objects+    | otherwise =+        throwIO $ MsgPackSerializationFailure "Map too long"++    where l = Map.size m+          objects = Map.toList m++  msgPackSize m =+    if | l < 16    -> (1 +) <$> mapSize+       | l < 2^16  -> (3 +) <$> mapSize+       | l < 2^32  -> (5 +) <$> mapSize+       | otherwise -> throw exn++    where l = fromIntegral (Map.size m)+          mapSize = sum <$> mapM msgPackSize (Map.toList m)+          exn = MsgPackSerializationFailure "Map too long"+++-- | FromMsgPack instance for 'Map's. This implements deserialization+-- for the MessagePack map format family for maps of up to @2^32 - 1@+-- keys resp. values.+instance (Ord k, Ord v, FromMsgPack k, FromMsgPack v) => FromMsgPack (Map k v) where+  fromMsgPack = do+    w <- getWord8+    l <- if | hasMarkerFixMap w -> fromIntegral <$> pure (w .&. 0b00001111)+            | w == markerMap16  -> fromIntegral <$> getWord16BE+            | w == markerMap32  -> fromIntegral <$> getWord32BE+    Map.fromList <$> replicateM l ((,) <$> fromMsgPack <*> fromMsgPack)++-- | ToMsgPack instance for general MessagePack 'Object's.+instance ToMsgPack Object where+  toMsgPack = \case+    ObjectInt i     -> toMsgPack i+    ObjectUInt i    -> toMsgPack i+    ObjectMap m     -> toMsgPack m+    ObjectArray a   -> toMsgPack a+    ObjectString s  -> toMsgPack s+    ObjectNil       -> putWord8 markerNil+    ObjectBool b    -> toMsgPack b+    ObjectBinary bs -> toMsgPack bs+    -- ext+    -- fixext+    ObjectFloat32 b -> toMsgPack b+    ObjectFloat64 b -> toMsgPack b+  msgPackSize = \case+    ObjectInt i     -> msgPackSize i+    ObjectUInt i    -> msgPackSize i+    ObjectMap m     -> msgPackSize m+    ObjectArray a   -> msgPackSize a+    ObjectString s  -> msgPackSize s+    ObjectNil       -> return 1+    ObjectBool b    -> msgPackSize b+    ObjectBinary bs -> msgPackSize bs+    -- ext+    -- fixext+    ObjectFloat32 b -> msgPackSize b+    ObjectFloat64 b -> msgPackSize b++-- | Data type modelling all known MessagePack markers.+data Marker = MarkerNil+            | MarkerTrue+            | MarkerFalse+            | MarkerPosFixnum+            | MarkerNegFixnum+            | MarkerWord8+            | MarkerWord16+            | MarkerWord32+            | MarkerWord64+            | MarkerInt8+            | MarkerInt16+            | MarkerInt32+            | MarkerInt64+            | MarkerFixStr+            | MarkerStr8+            | MarkerStr16+            | MarkerStr32+            | MarkerBin8+            | MarkerBin16+            | MarkerBin32+            | MarkerFixArray+            | MarkerArray16+            | MarkerArray32+            | MarkerFixMap+            | MarkerMap16+            | MarkerMap32+            | MarkerFloat32+            | MarkerFloat64+            deriving (Show, Eq)++-- | Parse the provided MessagePack 'Word8' as MessagePack 'Marker'.+parseMarker :: Word8 -> Maybe Marker+parseMarker w+  | hasMarkerPosFixNum w  = pure MarkerPosFixnum+  | hasMarkerNegFixNum w  = pure MarkerNegFixnum+  | hasMarkerFixStr w     = pure MarkerFixStr+  | hasMarkerFixArray w   = pure MarkerFixArray+  | hasMarkerFixMap w     = pure MarkerFixMap+  | w == markerNil        = pure MarkerNil+  | w == markerBoolTrue   = pure MarkerTrue+  | w == markerBoolFalse  = pure MarkerFalse+  | w == markerStr8       = pure MarkerStr8+  | w == markerInt8       = pure MarkerInt8+  | w == markerInt16      = pure MarkerInt16+  | w == markerInt32      = pure MarkerInt32+  | w == markerInt64      = pure MarkerInt64+  | w == markerUInt8      = pure MarkerWord8+  | w == markerUInt16     = pure MarkerWord16+  | w == markerUInt32     = pure MarkerWord32+  | w == markerUInt64     = pure MarkerWord64+  | w == markerStr8       = pure MarkerStr8+  | w == markerStr16      = pure MarkerStr16+  | w == markerStr32      = pure MarkerStr32+  | w == markerBin8       = pure MarkerBin8+  | w == markerBin16      = pure MarkerBin16+  | w == markerBin32      = pure MarkerBin32+  | w == markerArray16    = pure MarkerArray16+  | w == markerArray32    = pure MarkerArray32+  | w == markerFixMap     = pure MarkerFixMap+  | w == markerMap16      = pure MarkerMap16+  | w == markerMap32      = pure MarkerMap32+  | w == markerFloat32    = pure MarkerFloat32+  | w == markerFloat64    = pure MarkerFloat64+  | otherwise = Nothing++-- | Check if the provided 'Word8' contains a FixStr marker.+hasMarkerFixStr :: Word8 -> Bool+hasMarkerFixStr w =+  w .&. 0b11100000 == markerFixStr++-- | Check if the provided 'Word8' contains a FixArray marker.+hasMarkerFixArray :: Word8 -> Bool+hasMarkerFixArray w =+  w .&. 0b11110000 == markerFixArray++-- | Check if the provided 'Word8' contains a FixMap marker.+hasMarkerFixMap :: Word8 -> Bool+hasMarkerFixMap w =+  w .&. 0b11110000 == markerFixMap++-- | Check if the provided 'Word8' contains a Pos FixNum marker.+hasMarkerPosFixNum :: Word8 -> Bool+hasMarkerPosFixNum  w =+  w .&. 0b10000000 == 0++-- | Check if the provided 'Word8' contains a Neg FixNum marker.+hasMarkerNegFixNum :: Word8 -> Bool+hasMarkerNegFixNum w =+  let wInt8 = fromIntegral w :: Int8+  in -2^5 <= wInt8 && wInt8 < 0++-- | Given a MessagePack marker, deserialize an object.+--+-- Note: A positive fix num will cause the object to be deserialized+-- as a ObjectInt, not an ObjectUInt.+parseObject :: Marker -> Unpacking Object+parseObject MarkerNil       = pure ObjectNil            <*  skipWord+parseObject MarkerTrue      = ObjectBool                <$> fromMsgPack+parseObject MarkerFalse     = ObjectBool                <$> fromMsgPack+parseObject MarkerPosFixnum = ObjectInt  . fromIntegral <$> (fromMsgPack :: Unpacking Int8)+parseObject MarkerNegFixnum = ObjectInt  . fromIntegral <$> (fromMsgPack :: Unpacking Int8)+parseObject MarkerWord8     = ObjectUInt . fromIntegral <$> (fromMsgPack :: Unpacking Word8)+parseObject MarkerWord16    = ObjectUInt . fromIntegral <$> (fromMsgPack :: Unpacking Word16)+parseObject MarkerWord32    = ObjectUInt . fromIntegral <$> (fromMsgPack :: Unpacking Word32)+parseObject MarkerWord64    = ObjectUInt                <$> fromMsgPack+parseObject MarkerInt8      = ObjectInt  . fromIntegral <$> (fromMsgPack :: Unpacking Int8)+parseObject MarkerInt16     = ObjectInt  . fromIntegral <$> (fromMsgPack :: Unpacking Int16)+parseObject MarkerInt32     = ObjectInt  . fromIntegral <$> (fromMsgPack :: Unpacking Int32)+parseObject MarkerInt64     = ObjectInt                 <$> fromMsgPack+parseObject MarkerFixStr    = ObjectString              <$> fromMsgPack+parseObject MarkerStr8      = ObjectString              <$> fromMsgPack+parseObject MarkerStr16     = ObjectString              <$> fromMsgPack+parseObject MarkerStr32     = ObjectString              <$> fromMsgPack+parseObject MarkerBin8      = ObjectBinary              <$> fromMsgPack+parseObject MarkerBin16     = ObjectBinary              <$> fromMsgPack+parseObject MarkerBin32     = ObjectBinary              <$> fromMsgPack+parseObject MarkerFixArray  = ObjectArray               <$> fromMsgPack+parseObject MarkerArray16   = ObjectArray               <$> fromMsgPack+parseObject MarkerArray32   = ObjectArray               <$> fromMsgPack+parseObject MarkerFixMap    = ObjectMap                 <$> fromMsgPack+parseObject MarkerMap16     = ObjectMap                 <$> fromMsgPack+parseObject MarkerMap32     = ObjectArray               <$> fromMsgPack+parseObject MarkerFloat32   = ObjectFloat32             <$> fromMsgPack+parseObject MarkerFloat64   = ObjectFloat64             <$> fromMsgPack++-- | FromMsgPack instance for general MessagePack 'Object's.+instance FromMsgPack Object where+  fromMsgPack = do+    w <- unpackPeekWord8+    case parseMarker w of+      Just marker -> parseObject marker+      Nothing     -> let msg = "Invalid MessagePack marker: " <> Text.pack (show w)+                     in throwIO $ MsgPackDeserializationFailure msg++-- | Skip a single Word8 in the provided 'Unpacking' monad.+skipWord :: Unpacking ()+skipWord = void getWord8
+ src/Data/Packer/MessagePack/Internal/Util.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Packer.MessagePack.Internal.Util where++import           Control.Monad.IO.Class+import           Data.Packer+import           Data.Word+import           UnliftIO.Exception++import           Data.Packer.MessagePack.Internal.Exceptions++unpackPeekWord8 :: Unpacking Word8+unpackPeekWord8 = do+  pos <- unpackGetPosition+  w   <- getWord8+  unpackSetPosition pos+  return w++shrinkType :: forall f a b.+              (Applicative f, Integral a, Integral b, Bounded a, Bounded b)+           => f b -> a -> f b+shrinkType overflowFail a =+  if fromIntegral (minBound :: b) <= a && a <= fromIntegral (maxBound :: b)+  then pure (fromIntegral a :: b)+  else overflowFail++shrinkTypeIO :: forall m a b.+                (MonadIO m, Integral a, Integral b, Bounded a, Bounded b)+             => a -> m b+shrinkTypeIO = shrinkType (throwIO (MsgPackDeserializationFailure "Integer Overflow"))
+ tests/Tests.hs view
@@ -0,0 +1,638 @@+{-# LANGUAGE BinaryLiterals      #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}++import           Hedgehog+import qualified Hedgehog.Gen            as Gen+import qualified Hedgehog.Range          as Range++import           Control.Exception.Safe+import           Data.Bits+import           Data.Bool+import           Data.ByteString         (ByteString)+import qualified Data.ByteString         as ByteString+import           Data.Foldable+import           Data.Int+import qualified Data.Map                as Map+import           Data.Maybe+import           Data.Monoid+import           Data.Packer+import           Data.Packer.MessagePack+import           Data.Proxy+import           Data.Text               (Text)+import qualified Data.Text.Encoding      as Text+import           Data.Word++data Bit = Bit0 | Bit1+  deriving (Eq, Show, Ord)++data BitException = BitParseFailure String+  deriving (Show, Typeable)++instance Exception BitException++showBits :: [Bit] -> String+showBits = map convert+  where convert Bit0 = '0'+        convert Bit1 = '1'++parseBits :: MonadThrow m => String -> m [Bit]+parseBits s = case parseBits' s of+  Right bits -> return bits+  Left  _    -> throwM $ BitParseFailure "Failure to bits"++parseBits' :: String -> Either String [Bit]+parseBits' = sequence . map parseBit+  where parseBit '1' = Right Bit1+        parseBit '0' = Right Bit0+        parseBit c   = Left ("Invalid character: " <> show c)++toBits :: FiniteBits a => a -> [Bit]+toBits a =+  reverse $ map (\i -> bool Bit0 Bit1 (testBit a i)) [0..(n - 1)]+  where n = finiteBitSize a++fromBits :: (Num a, Bits a) => [Bit] -> a+fromBits s =+  foldl' f 0 (zip (reverse s) [0..])+  where f accu (c, i) =+          case c of+            Bit1 -> setBit accu i+            Bit0 -> accu++nthWord :: (Bits a, Integral a) => a -> Int -> Word8+nthWord = go+  where go a 0 = fromIntegral $ a .&. 0xFF+        go a i = go (a `shiftR` 8) (i - 1)++genPosFixInt :: (MonadGen m, Integral a) => m a+genPosFixInt =+  Gen.integral (Range.linear 0 (2^7 - 1))++genNegFixInt :: forall m a. (MonadGen m, Integral a) => m a+genNegFixInt =+  fromIntegral . (fromIntegral :: a -> Int8)+  <$> Gen.integral (Range.linear (- 2^5) (- 1))++checkSerialization :: (Show a, Eq a, FromMsgPack a, ToMsgPack a)+                    => a -> [Word8] -> PropertyT IO ()+checkSerialization a ws = do+  annotate $ show a+  size <- msgPackSize a+  let bsSerialized = runPacking size (toMsgPack a)+      bsExpected   = ByteString.pack ws+  annotate . show $ (ByteString.length bsSerialized)+  annotate . show $ (ByteString.length bsExpected)+  ByteString.unpack bsSerialized === ByteString.unpack bsExpected+  annotate $ show bsSerialized+  a === runUnpacking fromMsgPack bsSerialized++extractWordsBE :: forall a. (Integral a, FiniteBits a) => a -> [Word8]+extractWordsBE = go nWords []++  where nWords = (finiteBitSize (undefined :: a) + 7) `div` 8++        go 0 accu _ = accu+        go i accu a =+          let a' = fromIntegral (a `shiftR` 8)+          in go (i - 1)  (fromIntegral (a .&. 0xFF) : accu) a'+++-- Nil++prop_nil :: Property+prop_nil = property $ do+  nil <- forAll $ Gen.constant ObjectNil+  checkSerialization nil [0xC0]++-- Bool++prop_bool :: Property+prop_bool = property $ do+  b <- forAll $ Gen.bool+  checkSerialization b [if b then 0xC3 else 0xC2]++prop_obj_bool :: Property+prop_obj_bool = property $ do+  b <- forAll Gen.bool+  checkSerialization (ObjectBool b) [if b then 0xC3 else 0xC2]++_prop_pos_fixnum_integral ::+  forall a. (Show a, FromMsgPack a, ToMsgPack a, Integral a)+  => Proxy a -> PropertyT IO ()+_prop_pos_fixnum_integral _proxy = do+  a :: a <- forAll genPosFixInt+  checkSerialization a [fromIntegral a .&. 0b01111111]++_prop_obj_pos_fixnum_integral ::+  forall a. (Show a, FromMsgPack a, ToMsgPack a, Integral a)+  => Proxy a -> PropertyT IO ()+_prop_obj_pos_fixnum_integral _proxy = do+  a :: a <- forAll genPosFixInt+  checkSerialization (ObjectInt (fromIntegral a)) [fromIntegral a .&. 0b01111111]++prop_pos_fixnum_int8 :: Property+prop_pos_fixnum_int8 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Int8)++prop_obj_pos_fixnum_int8 :: Property+prop_obj_pos_fixnum_int8 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Int8)++prop_pos_fixnum_int16 :: Property+prop_pos_fixnum_int16 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Int16)++prop_obj_pos_fixnum_int16 :: Property+prop_obj_pos_fixnum_int16 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Int16)++prop_pos_fixnum_int32 :: Property+prop_pos_fixnum_int32 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Int32)++prop_obj_pos_fixnum_int32 :: Property+prop_obj_pos_fixnum_int32 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Int32)++prop_pos_fixnum_int64 :: Property+prop_pos_fixnum_int64 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Int64)++prop_obj_pos_fixnum_int64 :: Property+prop_obj_pos_fixnum_int64 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Int64)++prop_obj_pos_fixnum_word8 :: Property+prop_obj_pos_fixnum_word8 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Word8)++prop_pos_fixnum_word16 :: Property+prop_pos_fixnum_word16 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Word16)++prop_obj_pos_fixnum_word16 :: Property+prop_obj_pos_fixnum_word16 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Word16)++prop_pos_fixnum_word32 :: Property+prop_pos_fixnum_word32 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Word32)++prop_obj_pos_fixnum_word32 :: Property+prop_obj_pos_fixnum_word32 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Word32)++prop_pos_fixnum_word64 :: Property+prop_pos_fixnum_word64 = property $ _prop_pos_fixnum_integral (Proxy :: Proxy Word64)++prop_obj_pos_fixnum_word64 :: Property+prop_obj_pos_fixnum_word64 = property $ _prop_obj_pos_fixnum_integral (Proxy :: Proxy Word64)++_prop_neg_fixnum_integral ::+  forall a. (Show a, FromMsgPack a, ToMsgPack a, Integral a)+  => Proxy a -> PropertyT IO ()+_prop_neg_fixnum_integral _proxy = do+  a :: a <- forAll genNegFixInt+  checkSerialization a [fromIntegral a .&. 0b11111111]++_prop_obj_neg_fixnum_integral ::+  forall a. (Show a, FromMsgPack a, ToMsgPack a, Integral a)+  => Proxy a -> PropertyT IO ()+_prop_obj_neg_fixnum_integral _proxy = do+  a :: a <- forAll genNegFixInt+  checkSerialization (ObjectInt (fromIntegral a)) [fromIntegral a .&. 0b11111111]++prop_neg_fixnum_int8 :: Property+prop_neg_fixnum_int8 = property $ _prop_neg_fixnum_integral (Proxy :: Proxy Int8)++prop_obj_neg_fixnum_int8 :: Property+prop_obj_neg_fixnum_int8 = property $ _prop_obj_neg_fixnum_integral (Proxy :: Proxy Int8)++prop_neg_fixnum_int16 :: Property+prop_neg_fixnum_int16 = property $ _prop_neg_fixnum_integral (Proxy :: Proxy Int16)++prop_obj_neg_fixnum_int16 :: Property+prop_obj_neg_fixnum_int16 = property $ _prop_obj_neg_fixnum_integral (Proxy :: Proxy Int16)++prop_neg_fixnum_int32 :: Property+prop_neg_fixnum_int32 = property $ _prop_neg_fixnum_integral (Proxy :: Proxy Int32)++prop_obj_neg_fixnum_int32 :: Property+prop_obj_neg_fixnum_int32 = property $ _prop_obj_neg_fixnum_integral (Proxy :: Proxy Int32)++prop_neg_fixnum_int64 :: Property+prop_neg_fixnum_int64 = property $ _prop_neg_fixnum_integral (Proxy :: Proxy Int64)++prop_obj_neg_fixnum_int64 :: Property+prop_obj_neg_fixnum_int64 = property $ _prop_obj_neg_fixnum_integral (Proxy :: Proxy Int64)++genWord8 :: forall m a. (MonadGen m, Integral a) => m a+genWord8 =+  fromIntegral . (fromIntegral :: a -> Word8)+  <$> Gen.integral (Range.linear (2^7) (2^8 - 1))++prop_word8_word8 :: Property+prop_word8_word8 = property $ do+  i :: Word8 <- forAll genWord8+  checkSerialization i [0xCC, fromIntegral i]++prop_obj_word8 :: Property+prop_obj_word8 = property $ do+  i <- forAll genWord8+  checkSerialization (ObjectUInt i) [0xCC, fromIntegral i]++prop_word8_word16 :: Property+prop_word8_word16 = property $ do+  i :: Word16 <- forAll genWord8+  checkSerialization i [0xCC, fromIntegral i]++prop_word8_word32 :: Property+prop_word8_word32 = property $ do+  i :: Word32 <- forAll genWord8+  checkSerialization i [0xCC, fromIntegral i]++prop_word8_word64 :: Property+prop_word8_word64 = property $ do+  i :: Word64 <- forAll genWord8+  checkSerialization i [0xCC, fromIntegral i]+++-- UInt16++genWord16 :: forall m a. (MonadGen m, Integral a) => m a+genWord16 =+  fromIntegral . (fromIntegral :: a -> Word16)+  <$> Gen.integral (Range.linear (2^8) (2^16 - 1))++prop_word16_word16 :: Property+prop_word16_word16 = property $ do+  i :: Word16 <- forAll genWord16+  checkSerialization i [0xCD, nthWord i 1, nthWord i 0]++prop_obj_word16 :: Property+prop_obj_word16 = property $ do+  i :: Word16 <- forAll genWord16+  checkSerialization (ObjectUInt (fromIntegral i)) (0xCD : extractWordsBE i)++prop_word16_word32 :: Property+prop_word16_word32 = property $ do+  i :: Word16 <- forAll genWord16+  checkSerialization (fromIntegral i :: Word32) (0xCD : extractWordsBE i)++prop_word16_word64 :: Property+prop_word16_word64 = property $ do+  i :: Word64 <- forAll genWord16+  checkSerialization i [0xCD, nthWord i 1, nthWord i 0]++-- UInt32++genWord32 :: forall m a. (MonadGen m, Integral a) => m a+genWord32 =+  fromIntegral . (fromIntegral :: a -> Word32)+  <$> Gen.integral (Range.linear (2^16) (2^32 - 1))++prop_word32_word32 :: Property+prop_word32_word32 = property $ do+  i :: Word32 <- forAll genWord32+  checkSerialization i (0xCE : extractWordsBE i)++prop_obj_word32 :: Property+prop_obj_word32 = property $ do+  i :: Word32 <- forAll genWord32+  checkSerialization (ObjectUInt (fromIntegral i)) (0xCE : extractWordsBE i)++prop_word32_word64 :: Property+prop_word32_word64 = property $ do+  i :: Word32 <- forAll genWord32+  checkSerialization (fromIntegral i :: Word64) (0xCE : extractWordsBE i)++-- UInt64++genWord64 :: forall m a. (MonadGen m, Integral a) => m a+genWord64 =+  fromIntegral . (fromIntegral :: a -> Word64)+  <$> Gen.integral (Range.linear (2^32) (2^64 - 1))++prop_word64_word64 :: Property+prop_word64_word64 = property $ do+  i :: Word64 <- forAll genWord64+  checkSerialization i (0xCF : extractWordsBE i)++prop_obj_word64 :: Property+prop_obj_word64 = property $ do+  i :: Word64 <- forAll genWord64+  checkSerialization (ObjectUInt i) (0xCF : extractWordsBE i)++-- Int8++genInt8 :: forall m a. (MonadGen m, Integral a) => m a+genInt8 =+  fromIntegral . (fromIntegral :: a -> Int8)+  <$> Gen.integral (Range.linear (-2^5 - 1) (-2^7))++prop_int8_int8 :: Property+prop_int8_int8 = property $ do+  i :: Int8 <- forAll genInt8+  checkSerialization i [0xD0, fromIntegral i]++prop_obj_int8 :: Property+prop_obj_int8 = property $ do+  i :: Int8 <- forAll genInt8+  checkSerialization (ObjectInt (fromIntegral i)) (0xD0 : extractWordsBE i)++prop_int8_int16 :: Property+prop_int8_int16 = property $ do+  i :: Int8 <- forAll genInt8+  checkSerialization (fromIntegral i :: Int16) (0xD0 : extractWordsBE i)++prop_int8_int32 :: Property+prop_int8_int32 = property $ do+  i :: Int8 <- forAll genInt8+  checkSerialization (fromIntegral i :: Int32) (0xD0 : extractWordsBE i)++prop_int8_int64 :: Property+prop_int8_int64 = property $ do+  i :: Int8 <- forAll genInt8+  checkSerialization (fromIntegral i :: Int64) (0xD0 : extractWordsBE i)++-- Int++prop_int8_int :: Property+prop_int8_int = property $ do+  i :: Int8 <- forAll genInt8+  checkSerialization (fromIntegral i :: Int) (0xD0 : extractWordsBE i)++prop_int16_int :: Property+prop_int16_int = property $ do+  i :: Int16 <- forAll genInt16+  checkSerialization (fromIntegral i :: Int) (0xD1 : extractWordsBE i)++-- Int16++genInt16 :: forall m a. (MonadGen m, Integral a) => m a+genInt16 =+  fromIntegral . (fromIntegral :: a -> Int16)+  <$> Gen.choice [ Gen.integral (Range.linear (-2^15) (-2^ 7 - 1))+                 , Gen.integral (Range.linear ( 2^ 7) ( 2^15 - 1)) ]++prop_int16_int16 :: Property+prop_int16_int16 = property $ do+  i :: Int16 <- forAll genInt16+  checkSerialization i (0xD1 : extractWordsBE i)++prop_obj_int16 :: Property+prop_obj_int16 = property $ do+  i :: Int16 <- forAll genInt16+  checkSerialization (ObjectInt (fromIntegral i)) (0xD1 : extractWordsBE i)++prop_int16_int32 :: Property+prop_int16_int32 = property $ do+  i :: Int32 <- forAll genInt16+  checkSerialization i (0xD1 : extractWordsBE (fromIntegral i :: Int16))++prop_int16_int64 :: Property+prop_int16_int64 = property $ do+  i :: Int64 <- forAll genInt16+  checkSerialization i (0xD1 : extractWordsBE (fromIntegral i :: Int16))++-- Int32++genInt32 :: forall m a. (MonadGen m, Integral a) => m a+genInt32 =+  fromIntegral . (fromIntegral :: a -> Int32)+  <$> Gen.choice [ Gen.integral (Range.linear (-2^31) (-2^15 - 1))+                 , Gen.integral (Range.linear ( 2^15) ( 2^31 - 1))]++prop_int32_int32 :: Property+prop_int32_int32 = property $ do+  i :: Int32 <- forAll genInt32+  checkSerialization i (0xD2 : extractWordsBE (fromIntegral i :: Int32))++prop_obj_int32 :: Property+prop_obj_int32 = property $ do+  i :: Int32 <- forAll genInt32+  checkSerialization (ObjectInt (fromIntegral i)) (0xD2 : extractWordsBE i)++prop_int32_int64 :: Property+prop_int32_int64 = property $ do+  i :: Int64 <- forAll genInt32+  checkSerialization i (0xD2 : extractWordsBE (fromIntegral i :: Int32))++-- Int64++genInt64 :: forall m a. (MonadGen m, Integral a) => m a+genInt64 =+  fromIntegral . (fromIntegral :: a -> Int64)+  <$> Gen.choice [ Gen.integral (Range.linear (-2^63) (-2^31 - 1))+                 , Gen.integral (Range.linear ( 2^31) ( 2^63 - 1))]++prop_int64_int64 :: Property+prop_int64_int64 = property $ do+  i :: Int64 <- forAll genInt64+  checkSerialization i (0xD3 : extractWordsBE (fromIntegral i :: Int64))++prop_obj_int64 :: Property+prop_obj_int64 = property $ do+  i :: Int64 <- forAll genInt64+  checkSerialization i (0xD3 : extractWordsBE i)++-- Float32++genFloat32 :: MonadGen m => m Float+genFloat32 = Gen.float (Range.exponentialFloat (- 2^32) (2^32))++prop_float32 :: Property+prop_float32 = property $ do+  f <- forAll genFloat32+  checkSerialization f (0xCA : ByteString.unpack (runPacking 16 (putFloat32BE f)))++floatWordsBE :: Float -> [Word8]+floatWordsBE f =+  ByteString.unpack (runPacking 16 (putFloat32BE f))++doubleWordsBE :: Double -> [Word8]+doubleWordsBE f =+  ByteString.unpack (runPacking 16 (putFloat64BE f))++prop_obj_float32 :: Property+prop_obj_float32 = property $ do+  f <- forAll genFloat32+  checkSerialization (ObjectFloat32 f) (0xCA : floatWordsBE f)++-- Float64++genFloat64 :: MonadGen m => m Double+genFloat64 = Gen.double (Range.exponentialFloat (- 2^64) (2^64))++prop_float64 :: Property+prop_float64 = property $ do+  f <- forAll genFloat64+  checkSerialization f (0xCB : ByteString.unpack (runPacking 16 (putFloat64BE f)))++prop_obj_float64 :: Property+prop_obj_float64 = property $ do+  f <- forAll genFloat64+  checkSerialization (ObjectFloat64 f) (0xCB : doubleWordsBE f)++-- Produces much more ASCII characters than unicode in order to+-- increase the change that generated texts will have a UTF decoded+-- bytestring in the requested range.+genChar :: MonadGen m => m Char+genChar = Gen.frequency [ (1, Gen.unicode)+                        , (9, Gen.ascii) ]++genStr :: MonadGen m => Range Int -> m Text+genStr range =+  Gen.filter (decodedTextInRange range) (Gen.text range genChar)++decodedTextInRange :: Range Int -> Text -> Bool+decodedTextInRange range text =+  let l = ByteString.length (Text.encodeUtf8 text)+      lower = Range.lowerBound 100 range+      upper = Range.upperBound 100 range+  in lower <= l && l <= upper++decodeTextLength :: Integral a => Text -> (ByteString, a)+decodeTextLength t =+  let bs = Text.encodeUtf8 t+      n  = fromIntegral $ ByteString.length bs+  in (bs, n)++-- FixStr++genFixStr :: MonadGen m => m Text+genFixStr = genStr $ Range.linear 0 (2^5 - 1)++prop_fixstr :: Property+prop_fixstr = property $ do+  t <- forAll genFixStr+  let (bs, n :: Word8) = decodeTextLength t+  checkSerialization t $ (fromIntegral n .|. 0b10100000) : ByteString.unpack bs++prop_obj_fixstr :: Property+prop_obj_fixstr = property $ do+  t <- forAll genFixStr+  let (bs, n :: Word8) = decodeTextLength t+  checkSerialization (ObjectString t) $ (fromIntegral n .|. 0b10100000) : ByteString.unpack bs++-- Str8++genStr8 :: MonadGen m => m Text+genStr8 = genStr $ Range.linear (2^5) (2^8 - 1)++prop_str8 :: Property+prop_str8 = property $ do+  s <- forAll genStr8+  let (bs, l :: Word8) = decodeTextLength s+  checkSerialization s (0xD9 : (extractWordsBE l ++ ByteString.unpack bs))++prop_obj_str8 :: Property+prop_obj_str8 = property $ do+  s <- forAll genStr8+  let (bs, l :: Word8) = decodeTextLength s+  checkSerialization (ObjectString s) (0xD9 : (extractWordsBE l ++ ByteString.unpack bs))++-- Str16++genStr16 :: MonadGen m => m Text+genStr16 = genStr $ Range.linear (2^8) (2^9 - 1) -- 2^16 - 1 would be too slow.++prop_str16 :: Property+prop_str16 = property $ do+  s <- forAll genStr16+  let (bs, l :: Word16) = decodeTextLength s+  checkSerialization s (0xDA : (extractWordsBE l ++ ByteString.unpack bs))++prop_obj_str16 :: Property+prop_obj_str16 = property $ do+  s <- forAll genStr16+  let (bs, l :: Word16) = decodeTextLength s+  checkSerialization (ObjectString s) (0xDA : (extractWordsBE l ++ ByteString.unpack bs))++-- Bin8++genBin8 :: MonadGen m => m ByteString+genBin8 = Gen.bytes $ Range.linear 0 (2^8 - 1)++prop_bin8 :: Property+prop_bin8 = property $ do+  b <- forAll genBin8+  let l = fromIntegral (ByteString.length b) :: Word8+  checkSerialization b (0xC4 : (extractWordsBE l ++ ByteString.unpack b))++prop_obj_bin8 :: Property+prop_obj_bin8 = property $ do+  b <- forAll genBin8+  let l = fromIntegral (ByteString.length b) :: Word8+  checkSerialization (ObjectBinary b) (0xC4 : (extractWordsBE l ++ ByteString.unpack b))++-- Bin16++genBin16 :: MonadGen m => m ByteString+genBin16 = Gen.bytes $ Range.linear (2^8) (2^9 - 1) -- 2^16 - 1 would be too slow.++prop_bin16 :: Property+prop_bin16 = property $ do+  b <- forAll genBin16+  let l = fromIntegral (ByteString.length b) :: Word16+  checkSerialization b (0xC5 : (extractWordsBE l ++ ByteString.unpack b))++prop_obj_bin16 :: Property+prop_obj_bin16 = property $ do+  b <- forAll genBin16+  let l = fromIntegral (ByteString.length b) :: Word16+  checkSerialization (ObjectBinary b) (0xC5 : (extractWordsBE l ++ ByteString.unpack b))+++genObject :: MonadGen m => m Object+genObject =+  Gen.frequency [ (1, ObjectBinary <$> genBin8)+                , (1, pure ObjectNil)+                , (1, ObjectBool <$> Gen.bool)+                , (1, ObjectString <$> genFixStr)+                , (1, ObjectString <$> genStr8)+                , (1, ObjectBinary <$> genBin8)+                , (1, ObjectInt <$> genInt16)+                , (1, ObjectUInt <$> genWord16)+                ]++genObjectWithSize :: MonadGen m => m (Maybe (Object, Int))+genObjectWithSize = do+  obj <- genObject+  case msgPackSize obj of+    Just size -> return $ Just (obj, size)+    Nothing   -> return Nothing++serializeObj :: Object -> Int -> ByteString+serializeObj obj size =+  runPacking size (toMsgPack obj)++genObjectPairWithSize :: MonadGen m => m (Maybe ((Object, Int), (Object, Int)))+genObjectPairWithSize = do+  a <- genObjectWithSize+  b <- genObjectWithSize+  return $ (,) <$> a <*> b++prop_array :: Property+prop_array = property $ do+  objsWithSize <- catMaybes <$> (forAll $ Gen.list (Range.linear (2^4) (2^6)) genObjectWithSize)+  let objs = map fst objsWithSize+      n = fromIntegral (length objs) :: Int16+      objsSerialized = ByteString.unpack . mconcat . map (uncurry serializeObj)  $ objsWithSize+  checkSerialization (ObjectArray objs) (0xDC : (extractWordsBE n ++ objsSerialized))++serializeObjPair :: (Object, Int) -> (Object, Int) -> ByteString+serializeObjPair (obj0, size0) (obj1, size1) =+  runPacking (fromIntegral (size0 + size1)) (toMsgPack obj0 >> toMsgPack obj1)++filterDuplicates :: (Ord a, Ord b) => [(a, b)] -> [(a, b)]+filterDuplicates = Map.toList . Map.fromList++prop_fixmap :: Property+prop_fixmap = property $ do+  objsWithSize <- filterDuplicates . catMaybes <$> (forAll $ Gen.list (Range.linear 0 15) genObjectPairWithSize)+  let objPairs = map (\(a, b) -> (fst a, fst b)) objsWithSize+      n = fromIntegral (length objPairs) :: Int16+      objsSerialized = ByteString.unpack . mconcat . map (uncurry serializeObjPair)  $ objsWithSize+  annotate . show $ n+  checkSerialization (ObjectMap (Map.fromList objPairs)) ((0b10000000 .|. (fromIntegral n)) : objsSerialized)++tests :: IO Bool+tests = checkParallel $$(discover)++main :: IO ()+main =+  tests >>= \case+  True  -> putStrLn "Tests Passed"+  False -> putStrLn "Tests Failed"