diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2017-2018, The TokTok Team +Copyright (c) 2009-2010, Hideyuki Tanaka +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the Hideyuki Tanaka nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/bench/Data/MessagePack/IntBench.hs b/bench/Data/MessagePack/IntBench.hs new file mode 100644 --- /dev/null +++ b/bench/Data/MessagePack/IntBench.hs @@ -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)) + ] + ] diff --git a/bench/Data/MessagePackBench.hs b/bench/Data/MessagePackBench.hs new file mode 100644 --- /dev/null +++ b/bench/Data/MessagePackBench.hs @@ -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 + ] + ] diff --git a/bench/benchmark.hs b/bench/benchmark.hs new file mode 100644 --- /dev/null +++ b/bench/benchmark.hs @@ -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 + ] diff --git a/msgpack-binary.cabal b/msgpack-binary.cabal new file mode 100644 --- /dev/null +++ b/msgpack-binary.cabal @@ -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 +copyright: Copyright (c) 2009-2016, Hideyuki Tanaka +category: Data +stability: Experimental +cabal-version: >= 1.10 +build-type: Simple +description: + A Haskell implementation of MessagePack + . + This is a fork of msgpack-haskell , + since the original author is unreachable. This fork incorporates a number of + bugfixes and is actively being developed. + +source-repository head + type: git + location: https://github.com/TokTok/hs-msgpack-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 diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack.hs @@ -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 #-} diff --git a/src/Data/MessagePack/Get.hs b/src/Data/MessagePack/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Get.hs @@ -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 diff --git a/src/Data/MessagePack/Put.hs b/src/Data/MessagePack/Put.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Put.hs @@ -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 diff --git a/test/Data/MessagePackSpec.hs b/test/Data/MessagePackSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/MessagePackSpec.hs @@ -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 diff --git a/test/Data/Result.hs b/test/Data/Result.hs new file mode 100644 --- /dev/null +++ b/test/Data/Result.hs @@ -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 diff --git a/test/testsuite.hs b/test/testsuite.hs new file mode 100644 --- /dev/null +++ b/test/testsuite.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tools/msgpack-parser.hs b/tools/msgpack-parser.hs new file mode 100644 --- /dev/null +++ b/tools/msgpack-parser.hs @@ -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