msgpack-binary (empty) → 0.0.14
raw patch · 13 files changed
+1158/−0 lines, 13 filesdep +QuickCheckdep +basedep +binarysetup-changed
Dependencies added: QuickCheck, base, binary, bytestring, containers, criterion, data-binary-ieee754, deepseq, groom, hashable, hspec, msgpack-binary, msgpack-types, text, unordered-containers, vector
Files
- LICENSE +25/−0
- Setup.lhs +3/−0
- bench/Data/MessagePack/IntBench.hs +87/−0
- bench/Data/MessagePackBench.hs +50/−0
- bench/benchmark.hs +14/−0
- msgpack-binary.cabal +100/−0
- src/Data/MessagePack.hs +61/−0
- src/Data/MessagePack/Get.hs +170/−0
- src/Data/MessagePack/Put.hs +173/−0
- test/Data/MessagePackSpec.hs +393/−0
- test/Data/Result.hs +30/−0
- test/testsuite.hs +1/−0
- tools/msgpack-parser.hs +51/−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
+ bench/Data/MessagePack/IntBench.hs view
@@ -0,0 +1,87 @@+module Data.MessagePack.IntBench (suite) where++import Criterion.Main (Benchmark, bench, bgroup, nf)+import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int64)++import Data.MessagePack+++packInt :: Int64 -> LBS.ByteString+packInt = pack++unpackInt :: LBS.ByteString -> Maybe Int64+unpackInt = unpack+++suite :: [Benchmark]+suite =+ [ bgroup "pack" -- should be constant time+ [ bench "0x1" $ nf packInt 0x1+ , bench "0x10" $ nf packInt 0x10+ , bench "0x100" $ nf packInt 0x100+ , bench "0x1000" $ nf packInt 0x1000+ , bench "0x10000" $ nf packInt 0x10000+ , bench "0x100000" $ nf packInt 0x100000+ , bench "0x1000000" $ nf packInt 0x1000000+ , bench "0x10000000" $ nf packInt 0x10000000+ , bench "0x100000000" $ nf packInt 0x100000000+ , bench "0x1000000000" $ nf packInt 0x1000000000+ , bench "0x10000000000" $ nf packInt 0x10000000000+ , bench "0x100000000000" $ nf packInt 0x100000000000+ , bench "0x1000000000000" $ nf packInt 0x1000000000000+ , bench "0x10000000000000" $ nf packInt 0x10000000000000+ , bench "0x100000000000000" $ nf packInt 0x100000000000000+ , bench "0x1000000000000000" $ nf packInt 0x1000000000000000+ , bench "-0x1" $ nf packInt (-0x1 )+ , bench "-0x10" $ nf packInt (-0x10 )+ , bench "-0x100" $ nf packInt (-0x100 )+ , bench "-0x1000" $ nf packInt (-0x1000 )+ , bench "-0x10000" $ nf packInt (-0x10000 )+ , bench "-0x100000" $ nf packInt (-0x100000 )+ , bench "-0x1000000" $ nf packInt (-0x1000000 )+ , bench "-0x10000000" $ nf packInt (-0x10000000 )+ , bench "-0x100000000" $ nf packInt (-0x100000000 )+ , bench "-0x1000000000" $ nf packInt (-0x1000000000 )+ , bench "-0x10000000000" $ nf packInt (-0x10000000000 )+ , bench "-0x100000000000" $ nf packInt (-0x100000000000 )+ , bench "-0x1000000000000" $ nf packInt (-0x1000000000000 )+ , bench "-0x10000000000000" $ nf packInt (-0x10000000000000 )+ , bench "-0x100000000000000" $ nf packInt (-0x100000000000000 )+ , bench "-0x1000000000000000" $ nf packInt (-0x1000000000000000)+ ]+ , bgroup "unpack" -- should be constant time+ [ bench "0x1" $ nf unpackInt (packInt 0x1 )+ , bench "0x10" $ nf unpackInt (packInt 0x10 )+ , bench "0x100" $ nf unpackInt (packInt 0x100 )+ , bench "0x1000" $ nf unpackInt (packInt 0x1000 )+ , bench "0x10000" $ nf unpackInt (packInt 0x10000 )+ , bench "0x100000" $ nf unpackInt (packInt 0x100000 )+ , bench "0x1000000" $ nf unpackInt (packInt 0x1000000 )+ , bench "0x10000000" $ nf unpackInt (packInt 0x10000000 )+ , bench "0x100000000" $ nf unpackInt (packInt 0x100000000 )+ , bench "0x1000000000" $ nf unpackInt (packInt 0x1000000000 )+ , bench "0x10000000000" $ nf unpackInt (packInt 0x10000000000 )+ , bench "0x100000000000" $ nf unpackInt (packInt 0x100000000000 )+ , bench "0x1000000000000" $ nf unpackInt (packInt 0x1000000000000 )+ , bench "0x10000000000000" $ nf unpackInt (packInt 0x10000000000000 )+ , bench "0x100000000000000" $ nf unpackInt (packInt 0x100000000000000 )+ , bench "0x1000000000000000" $ nf unpackInt (packInt 0x1000000000000000 )+ , bench "-0x1" $ nf unpackInt (packInt (-0x1 ))+ , bench "-0x10" $ nf unpackInt (packInt (-0x10 ))+ , bench "-0x100" $ nf unpackInt (packInt (-0x100 ))+ , bench "-0x1000" $ nf unpackInt (packInt (-0x1000 ))+ , bench "-0x10000" $ nf unpackInt (packInt (-0x10000 ))+ , bench "-0x100000" $ nf unpackInt (packInt (-0x100000 ))+ , bench "-0x1000000" $ nf unpackInt (packInt (-0x1000000 ))+ , bench "-0x10000000" $ nf unpackInt (packInt (-0x10000000 ))+ , bench "-0x100000000" $ nf unpackInt (packInt (-0x100000000 ))+ , bench "-0x1000000000" $ nf unpackInt (packInt (-0x1000000000 ))+ , bench "-0x10000000000" $ nf unpackInt (packInt (-0x10000000000 ))+ , bench "-0x100000000000" $ nf unpackInt (packInt (-0x100000000000 ))+ , bench "-0x1000000000000" $ nf unpackInt (packInt (-0x1000000000000 ))+ , bench "-0x10000000000000" $ nf unpackInt (packInt (-0x10000000000000 ))+ , bench "-0x100000000000000" $ nf unpackInt (packInt (-0x100000000000000 ))+ , bench "-0x1000000000000000" $ nf unpackInt (packInt (-0x1000000000000000))+ ]+ ]
+ bench/Data/MessagePackBench.hs view
@@ -0,0 +1,50 @@+module Data.MessagePackBench (suite) where++import Control.DeepSeq (NFData)+import Criterion.Main (Benchmark, bench, bgroup, nf)+import qualified Data.ByteString.Lazy as LBS+import Data.Int (Int64)+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import Test.QuickCheck.Gen (resize, unGen)+import Test.QuickCheck.Random (mkQCGen)++import Data.MessagePack+++defaultSeed :: Int+defaultSeed = 301+++arb :: Arbitrary a => Int -> a+arb size =+ let g = unGen $ resize size arbitrary in+ g (mkQCGen defaultSeed) defaultSeed+++benchRange+ :: NFData b+ => Int -> Int -> Int -> (a -> b) -> (Int -> a) -> [Benchmark]+benchRange from to steps f g =+ map (\step ->+ let sz = from + ((to - from) `div` (steps - 1)) * step in+ bench (show sz) $ nf f (g sz)+ ) [0..steps-1]+++suite :: [Benchmark]+suite =+ [ bgroup "pack"+ [ bench "Just Int" $ nf pack (Just (3 :: Int))+ , bench "Nothing" $ nf pack (Nothing :: Maybe Int)+ , bench "()" $ nf pack ()+ , bgroup "[a]" $ benchRange 1000 10000 10 pack (`replicate` ())+ -- ^ should be linear+ ]+ , bgroup "unpack"+ [ bench "Just Int" $ nf (unpack :: LBS.ByteString -> Maybe Int) (pack (Just (3 :: Int)))+ , bench "Nothing" $ nf (unpack :: LBS.ByteString -> Maybe Int) (pack (Nothing :: Maybe Int))+ , bench "()" $ nf (unpack :: LBS.ByteString -> Maybe () ) (pack ())+ , bgroup "[a]" $ benchRange 1000 10000 10 pack (`replicate` ())+ -- ^ should be linear+ ]+ ]
+ bench/benchmark.hs view
@@ -0,0 +1,14 @@+module Main (main) where++import Criterion.Main (bgroup, defaultMain)+import Test.QuickCheck.Random (mkQCGen)++import qualified Data.MessagePack.IntBench+import qualified Data.MessagePackBench+++main :: IO ()+main = defaultMain+ [ bgroup "Data.MessagePack" Data.MessagePackBench.suite+ , bgroup "Data.MessagePack.Int" Data.MessagePack.IntBench.suite+ ]
+ msgpack-binary.cabal view
@@ -0,0 +1,100 @@+name: msgpack-binary+version: 0.0.14+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-binary.git++library+ default-language: Haskell2010+ hs-source-dirs:+ src+ ghc-options:+ -Wall+ -fno-warn-unused-imports+ exposed-modules:+ Data.MessagePack+ other-modules:+ Data.MessagePack.Get+ Data.MessagePack.Put+ build-depends:+ base < 5+ , binary >= 0.7.0.0+ , bytestring+ , data-binary-ieee754+ , msgpack-types >= 0.0.1 && < 0.1.0+ , text++executable msgpack-parser+ default-language: Haskell2010+ hs-source-dirs:+ tools+ ghc-options:+ -Wall+ -fno-warn-unused-imports+ main-is: msgpack-parser.hs+ build-depends:+ base < 5+ , bytestring+ , groom+ , msgpack-binary++test-suite testsuite+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: testsuite.hs+ other-modules:+ Data.MessagePackSpec+ Data.Result+ ghc-options:+ -Wall+ -fno-warn-unused-imports+ build-depends:+ base < 5+ , QuickCheck+ , bytestring+ , containers+ , hashable+ , hspec+ , msgpack-binary+ , msgpack-types+ , text+ , unordered-containers+ , vector++benchmark benchmark+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: bench+ main-is: benchmark.hs+ other-modules:+ Data.MessagePack.IntBench+ Data.MessagePackBench+ ghc-options:+ -Wall+ -fno-warn-unused-imports+ build-depends:+ base < 5+ , QuickCheck+ , bytestring+ , criterion+ , deepseq+ , msgpack-binary
+ src/Data/MessagePack.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- Simple interface to pack and unpack MessagePack data.+--+--------------------------------------------------------------------++module Data.MessagePack (+ -- * Simple interface to pack and unpack msgpack binary+ pack+ , unpack++ -- * Re-export modules+ -- $reexports+ , module X+ ) where++import Control.Applicative (Applicative)+import Control.Monad ((>=>))+import Data.Binary (Binary (..), decodeOrFail, encode)+import qualified Data.ByteString.Lazy as L++import Data.MessagePack.Get as X+import Data.MessagePack.Put as X+import Data.MessagePack.Types as X+++-- | Pack a Haskell value to MessagePack binary.+pack :: MessagePack a => a -> L.ByteString+pack = encode . toObject++-- | 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 :: (Applicative m, Monad m, MonadFail m, MessagePack a)+#else+unpack :: (Applicative m, Monad m, MessagePack a)+#endif+ => L.ByteString -> m a+unpack = eitherToM . decodeOrFail >=> fromObject+ where+ eitherToM (Left (_, _, msg)) = fail msg+ eitherToM (Right (_, _, res)) = return res+++instance Binary Object where+ get = getObject+ {-# INLINE get #-}++ put = putObject+ {-# INLINE put #-}
+ src/Data/MessagePack/Get.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Trustworthy #-}++--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack.Get+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- MessagePack Deserializer using @Data.Binary@+--+--------------------------------------------------------------------++module Data.MessagePack.Get+ ( getObject+ , getNil+ , getBool+ , getInt+ , getWord+ , getFloat+ , getDouble+ , getStr+ , getBin+ , getArray+ , getMap+ , getExt+ ) where++import Control.Applicative (empty, (<$), (<$>), (<*>), (<|>))+import Control.Monad (guard, replicateM)+import Data.Binary (Get)+import Data.Binary.Get (getByteString, getWord16be,+ getWord32be, getWord64be, getWord8)+import Data.Binary.IEEE754 (getFloat32be, getFloat64be)+import Data.Bits ((.&.))+import qualified Data.ByteString as S+import Data.Int (Int16, Int32, Int64, Int8)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word64, Word8)++import Data.MessagePack.Types (Object (..))++getObject :: Get Object+getObject =+ ObjectNil <$ getNil+ <|> ObjectBool <$> getBool+ <|> ObjectInt <$> getInt+ <|> ObjectWord <$> getWord+ <|> ObjectFloat <$> getFloat+ <|> ObjectDouble <$> getDouble+ <|> ObjectStr <$> getStr+ <|> ObjectBin <$> getBin+ <|> ObjectArray <$> getArray getObject+ <|> ObjectMap <$> getMap getObject getObject+ <|> uncurry ObjectExt <$> getExt++getNil :: Get ()+getNil = tag 0xC0++getBool :: Get Bool+getBool =+ False <$ tag 0xC2 <|>+ True <$ tag 0xC3++getInt :: Get Int64+getInt =+ getWord8 >>= \case+ c | c .&. 0xE0 == 0xE0 ->+ return $ fromIntegral (fromIntegral c :: Int8)+ 0xD0 -> fromIntegral <$> getInt8+ 0xD1 -> fromIntegral <$> getInt16be+ 0xD2 -> fromIntegral <$> getInt32be+ 0xD3 -> fromIntegral <$> getInt64be+ _ -> empty++getWord :: Get Word64+getWord =+ getWord8 >>= \case+ c | c .&. 0x80 == 0x00 ->+ return $ fromIntegral c+ 0xCC -> fromIntegral <$> getWord8+ 0xCD -> fromIntegral <$> getWord16be+ 0xCE -> fromIntegral <$> getWord32be+ 0xCF -> fromIntegral <$> getWord64be+ _ -> empty++getFloat :: Get Float+getFloat = tag 0xCA >> getFloat32be++getDouble :: Get Double+getDouble = tag 0xCB >> getFloat64be++getStr :: Get T.Text+getStr = do+ len <- getWord8 >>= \case+ t | t .&. 0xE0 == 0xA0 ->+ return $ fromIntegral $ t .&. 0x1F+ 0xD9 -> fromIntegral <$> getWord8+ 0xDA -> fromIntegral <$> getWord16be+ 0xDB -> fromIntegral <$> getWord32be+ _ -> empty+ bs <- getByteString len+ case T.decodeUtf8' bs of+ Left _ -> empty+ Right v -> return v++getBin :: Get S.ByteString+getBin = do+ len <- getWord8 >>= \case+ 0xC4 -> fromIntegral <$> getWord8+ 0xC5 -> fromIntegral <$> getWord16be+ 0xC6 -> fromIntegral <$> getWord32be+ _ -> empty+ getByteString len++getArray :: Get a -> Get [a]+getArray g = do+ len <- getWord8 >>= \case+ t | t .&. 0xF0 == 0x90 ->+ return $ fromIntegral $ t .&. 0x0F+ 0xDC -> fromIntegral <$> getWord16be+ 0xDD -> fromIntegral <$> getWord32be+ _ -> empty+ replicateM len g++getMap :: Get a -> Get b -> Get [(a, b)]+getMap k v = do+ len <- getWord8 >>= \case+ t | t .&. 0xF0 == 0x80 ->+ return $ fromIntegral $ t .&. 0x0F+ 0xDE -> fromIntegral <$> getWord16be+ 0xDF -> fromIntegral <$> getWord32be+ _ -> empty+ replicateM len $ (,) <$> k <*> v++getExt :: Get (Word8, S.ByteString)+getExt = do+ len <- getWord8 >>= \case+ 0xD4 -> return 1+ 0xD5 -> return 2+ 0xD6 -> return 4+ 0xD7 -> return 8+ 0xD8 -> return 16+ 0xC7 -> fromIntegral <$> getWord8+ 0xC8 -> fromIntegral <$> getWord16be+ 0xC9 -> fromIntegral <$> getWord32be+ _ -> empty+ (,) <$> getWord8 <*> getByteString len++getInt8 :: Get Int8+getInt8 = fromIntegral <$> getWord8++getInt16be :: Get Int16+getInt16be = fromIntegral <$> getWord16be++getInt32be :: Get Int32+getInt32be = fromIntegral <$> getWord32be++getInt64be :: Get Int64+getInt64be = fromIntegral <$> getWord64be++tag :: Word8 -> Get ()+tag t = do+ b <- getWord8+ guard $ t == b
+ src/Data/MessagePack/Put.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Trustworthy #-}+--------------------------------------------------------------------+-- |+-- Module : Data.MessagePack.Put+-- Copyright : (c) Hideyuki Tanaka, 2009-2015+-- License : BSD3+--+-- Maintainer: tanaka.hideyuki@gmail.com+-- Stability : experimental+-- Portability: portable+--+-- MessagePack Serializer using @Data.Binary@+--+--------------------------------------------------------------------++module Data.MessagePack.Put+ ( putObject+ , putNil+ , putBool+ , putInt+ , putWord+ , putFloat+ , putDouble+ , putStr+ , putBin+ , putArray+ , putMap+ , putExt+ ) where++import Data.Binary (Put)+import Data.Binary.IEEE754 (putFloat32be, putFloat64be)+import Data.Binary.Put (putByteString, putWord16be,+ putWord32be, putWord64be, putWord8,+ putWord8)+import Data.Bits ((.|.))+import qualified Data.ByteString as S+import Data.Int (Int64)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word64, Word8)++import Prelude hiding (putStr)++import Data.MessagePack.Types (Object (..))+++putObject :: Object -> Put+putObject = \case+ ObjectNil -> putNil+ ObjectBool b -> putBool b+ ObjectInt n -> putInt n+ ObjectWord n -> putWord n+ ObjectFloat f -> putFloat f+ ObjectDouble d -> putDouble d+ ObjectStr t -> putStr t+ ObjectBin b -> putBin b+ ObjectArray a -> putArray putObject a+ ObjectMap m -> putMap putObject putObject m+ ObjectExt b r -> putExt b r++putNil :: Put+putNil = putWord8 0xC0++putBool :: Bool -> Put+putBool False = putWord8 0xC2+putBool True = putWord8 0xC3++putInt :: Int64 -> Put+putInt n+ | -0x20 <= n && n < 0x80 =+ putWord8 (fromIntegral n)+ | 0 <= n && n < 0x100 =+ putWord8 0xCC >> putWord8 (fromIntegral n)+ | 0 <= n && n < 0x10000 =+ putWord8 0xCD >> putWord16be (fromIntegral n)+ | 0 <= n && n < 0x100000000 =+ putWord8 0xCE >> putWord32be (fromIntegral n)+ | 0 <= n =+ putWord8 0xCF >> putWord64be (fromIntegral n)+ | -0x80 <= n =+ putWord8 0xD0 >> putWord8 (fromIntegral n)+ | -0x8000 <= n =+ putWord8 0xD1 >> putWord16be (fromIntegral n)+ | -0x80000000 <= n =+ putWord8 0xD2 >> putWord32be (fromIntegral n)+ | otherwise =+ putWord8 0xD3 >> putWord64be (fromIntegral n)++putWord :: Word64 -> Put+putWord n+ | n < 0x80 =+ putWord8 (fromIntegral n)+ | n < 0x100 =+ putWord8 0xCC >> putWord8 (fromIntegral n)+ | n < 0x10000 =+ putWord8 0xCD >> putWord16be (fromIntegral n)+ | n < 0x100000000 =+ putWord8 0xCE >> putWord32be (fromIntegral n)+ | otherwise =+ putWord8 0xCF >> putWord64be n++putFloat :: Float -> Put+putFloat f = do+ putWord8 0xCA+ putFloat32be f++putDouble :: Double -> Put+putDouble d = do+ putWord8 0xCB+ putFloat64be d++putStr :: T.Text -> Put+putStr t = do+ let bs = T.encodeUtf8 t+ case S.length bs of+ len | len <= 31 ->+ putWord8 $ 0xA0 .|. fromIntegral len+ | len < 0x100 ->+ putWord8 0xD9 >> putWord8 (fromIntegral len)+ | len < 0x10000 ->+ putWord8 0xDA >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDB >> putWord32be (fromIntegral len)+ putByteString bs++putBin :: S.ByteString -> Put+putBin bs = do+ case S.length bs of+ len | len < 0x100 ->+ putWord8 0xC4 >> putWord8 (fromIntegral len)+ | len < 0x10000 ->+ putWord8 0xC5 >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xC6 >> putWord32be (fromIntegral len)+ putByteString bs++putArray :: (a -> Put) -> [a] -> Put+putArray p xs = do+ case length xs of+ len | len <= 15 ->+ putWord8 $ 0x90 .|. fromIntegral len+ | len < 0x10000 ->+ putWord8 0xDC >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDD >> putWord32be (fromIntegral len)+ mapM_ p xs++putMap :: (a -> Put) -> (b -> Put) -> [(a, b)] -> Put+putMap p q xs = do+ case length xs of+ len | len <= 15 ->+ putWord8 $ 0x80 .|. fromIntegral len+ | len < 0x10000 ->+ putWord8 0xDE >> putWord16be (fromIntegral len)+ | otherwise ->+ putWord8 0xDF >> putWord32be (fromIntegral len)+ mapM_ (\(a, b) -> p a >> q b) xs++putExt :: Word8 -> S.ByteString -> Put+putExt typ dat = do+ case S.length dat of+ 1 -> putWord8 0xD4+ 2 -> putWord8 0xD5+ 4 -> putWord8 0xD6+ 8 -> putWord8 0xD7+ 16 -> putWord8 0xD8+ len | len < 0x100 -> putWord8 0xC7 >> putWord8 (fromIntegral len)+ | len < 0x10000 -> putWord8 0xC8 >> putWord16be (fromIntegral len)+ | otherwise -> putWord8 0xC9 >> putWord32be (fromIntegral len)+ putWord8 typ+ putByteString dat
+ test/Data/MessagePackSpec.hs view
@@ -0,0 +1,393 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+module Data.MessagePackSpec where++import Test.Hspec+import Test.QuickCheck+import qualified Test.QuickCheck.Gen as Gen++import Control.Applicative ((<$>), (<*>))+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.Result as R+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.Void (Void)+import Data.Word (Word, Word16, Word32, Word64,+ Word8)+import GHC.Generics (Generic)++import Data.MessagePack+++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 (Maybe Foo)+ | Foo8 Int+ | Foo9 Int Int+ | Foo10 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+ , Foo9 <$> arbitrary <*> arbitrary+ , Foo10 <$> 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++mid :: MessagePack a => a -> a+mid = Maybe.fromJust . unpack . pack+++intMid :: Int64 -> Int64+intMid = mid+++coerce :: (MessagePack a, MessagePack b) => a -> Maybe b+coerce = unpack . pack+++checkMessage :: Show a => R.Result a -> Expectation+checkMessage (R.Success res) =+ expectationFailure $ "unexpected success: " ++ show res+checkMessage (R.Failure msg) =+ msg `shouldContain` "invalid encoding for "+++spec :: Spec+spec = 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 (unpack (pack $ ObjectInt (-1)) :: R.Result Foo)+ checkMessage (unpack (pack [ObjectInt (-1), ObjectInt 0]) :: R.Result Foo)+ checkMessage (unpack (pack $ ObjectArray []) :: R.Result TyConArgs)+ checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result TyConArgs)+ checkMessage (unpack (pack $ ObjectArray []) :: R.Result Record)+ checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result Record)+ checkMessage (unpack (pack "") :: R.Result Unit)+ checkMessage (unpack (pack "") :: R.Result TyConArgs)+ checkMessage (unpack (pack "") :: R.Result Record)+ checkMessage (unpack (pack "") :: R.Result ())+ checkMessage (unpack (pack ()) :: R.Result Int)+ checkMessage (unpack (pack ()) :: R.Result Bool)+ checkMessage (unpack (pack ()) :: R.Result Float)+ checkMessage (unpack (pack ()) :: R.Result Double)+ checkMessage (unpack (pack ()) :: R.Result S.ByteString)+ checkMessage (unpack (pack ()) :: R.Result LT.Text)+ checkMessage (unpack (pack "") :: R.Result [String])+ checkMessage (unpack (pack ()) :: R.Result (V.Vector Int))+ checkMessage (unpack (pack ()) :: R.Result (VS.Vector Int))+ checkMessage (unpack (pack ()) :: R.Result (VU.Vector Int))+ checkMessage (unpack (pack "") :: R.Result (Assoc [(Int, Int)]))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int))+ checkMessage (unpack (pack ()) :: R.Result (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 "maybe int" $+ property $ \(a :: (Maybe Int)) -> 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 "maybe int" $+ property $ \(a :: Maybe Int) -> a `shouldBe` mid a+ it "maybe nil" $+ property $ \(a :: Maybe ()) -> a `shouldBe` mid a+ it "maybe maybe int" $+ property $ \(a :: Maybe (Maybe Int)) -> a `shouldBe` mid a+ it "maybe bool" $+ property $ \(a :: Maybe Bool) -> a `shouldBe` mid a+ it "maybe double" $+ property $ \(a :: Maybe Double) -> a `shouldBe` mid a+ it "maybe string" $+ property $ \(a :: Maybe String) -> a `shouldBe` mid a+ it "maybe bytestring" $+ property $ \(a :: Maybe S.ByteString) -> a `shouldBe` mid a+ it "maybe lazy-bytestring" $+ property $ \(a :: Maybe L.ByteString) -> a `shouldBe` mid a+ it "maybe [int]" $+ property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a+ it "maybe [string]" $+ property $ \(a :: Maybe [String]) -> a `shouldBe` mid a+ it "maybe (int, int)" $+ property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a+ it "maybe (int, int, int)" $+ property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a+ it "maybe (int, int, int, int)" $+ property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "maybe (int, int, int, int, int)" $+ property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a+ it "maybe [(int, double)]" $+ property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a+ it "maybe [(string, string)]" $+ property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a+ it "maybe (Assoc [(string, int)])" $+ property $ \(a :: Maybe (Assoc [(String, Int)])) -> a `shouldBe` mid a+ it "either int float" $+ property $ \(a :: Either Int Float) -> 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 ()++ describe "show" $ do+ it "Foo" $ do+ show (toObject Foo1) `shouldBe` "ObjectWord 0"+ show (toObject $ Foo3 3) `shouldBe` "ObjectArray [ObjectWord 2,ObjectWord 3]"+ show (toObject $ Foo3 (-3)) `shouldBe` "ObjectArray [ObjectWord 2,ObjectInt (-3)]"+ show (toObject $ Foo9 3 5) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectWord 3,ObjectWord 5]]"+ show (toObject $ Foo9 (-3) (-5)) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectInt (-3),ObjectInt (-5)]]"+ show (toObject $ Foo10 3 5 7) `shouldBe` "ObjectArray [ObjectWord 9,ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]]"+ show (toObject $ Foo10 (-3) (-5) 7) `shouldBe` "ObjectArray [ObjectWord 9,ObjectArray [ObjectInt (-3),ObjectInt (-5),ObjectWord 7]]"++ it "TyConArgs" $+ show (toObject $ TyConArgs 3 5 7) `shouldBe` "ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]"++ it "Record" $+ show (toObject $ Record 3 5 "7") `shouldBe` "ObjectArray [ObjectWord 3,ObjectDouble 5.0,ObjectStr \"7\"]"++voidTest :: Void -> Object+voidTest = toObject
+ test/Data/Result.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE Safe #-}+module Data.Result+ ( Result (..)+ ) where++import Control.Applicative (Applicative (..), (<$>), (<*>))+import Control.Monad.Fail (MonadFail (..))++data Result a+ = Success a+ | Failure String+ deriving (Read, Show, Eq, Functor)++instance Applicative Result where+ pure = Success++ Success f <*> x = fmap f x+ Failure msg <*> _ = Failure msg++instance Monad Result where+ return = Success+ fail = Failure++ Success x >>= f = f x+ Failure msg >>= _ = Failure msg++instance MonadFail Result where+ fail = Failure
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tools/msgpack-parser.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE Trustworthy #-}+-- | A MessagePack parser.+--+-- Example usage:+-- $ echo -ne "\x94\x01\xa1\x32\xa1\x33\xa4\x50\x6f\x6f\x66" | ./msgpack-parser+-- or+-- $ echo 'ObjectArray [ObjectInt 97, ObjectStr "test", ObjectBool True]' | ./msgpack-parser+--+-- This tool performs two symmetrical functions:+-- 1. It can decode binary data representing a+-- Data.MessagePack.Object into a human-readable string.+-- 2. It can do the reverse: encode a human-readable string into+-- a binary representation of Data.MessagePack.Object.+--+-- No flags are required as it automatically detects which of these+-- two functions it should perform. This is done by first assuming+-- the input is human readable. If it fails to parse it, it then+-- considers it as binary data.+--+-- Therefore, given a valid input, the tool has the following property+-- $ ./msgpack-parser < input.bin | ./msgpack-parser+-- will output back the contents of input.bin.+--+-- In case the input is impossible to parse, nothing is output.+--+-- Known bugs:+-- - If no input is given, the tool exits with+-- "Data.Binary.Get.runGet at position 0: not enough bytes"+-- - The tool does not check that all the input is parsed.+-- Therefore, "abc" is interpreted as just "ObjectInt 97".+--+module Main where++import Control.Applicative ((<$>), (<|>))+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Maybe (fromMaybe)+import Data.MessagePack (Object, pack, unpack)+import Text.Groom (groom)+import Text.Read (readMaybe)+++parse :: L.ByteString -> L.ByteString+parse str = fromMaybe L.empty $+ pack <$> (readMaybe $ L8.unpack str :: Maybe Object)+ <|>+ L8.pack . flip (++) "\n" . groom <$> (unpack str :: Maybe Object)+++main :: IO ()+main = parse <$> L.getContents >>= L.putStr