diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +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/data-msgpack.cabal b/data-msgpack.cabal new file mode 100644 --- /dev/null +++ b/data-msgpack.cabal @@ -0,0 +1,59 @@ +name: data-msgpack +version: 0.0.2 +synopsis: A Haskell implementation of MessagePack +description: 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 + +source-repository head + type: git + location: https://github.com/TokTok/msgpack-haskell.git + +library + default-language: Haskell2010 + hs-source-dirs: + src + exposed-modules: + Data.MessagePack + Data.MessagePack.Assoc + Data.MessagePack.Class + Data.MessagePack.Generic + Data.MessagePack.Get + Data.MessagePack.Object + Data.MessagePack.Put + Data.MessagePack.Result + build-depends: + base < 5 + , QuickCheck + , binary + , bytestring + , containers + , data-binary-ieee754 + , deepseq + , hashable + , text + , unordered-containers + +test-suite testsuite + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: testsuite.hs + build-depends: + base < 5 + , QuickCheck + , bytestring + , containers + , data-msgpack + , hashable + , hspec + , text + , unordered-containers 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,50 @@ +{-# LANGUAGE Safe #-} +-------------------------------------------------------------------- +-- | +-- 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 (decodeOrFail, encode) +import qualified Data.ByteString.Lazy as L + +import Data.MessagePack.Assoc as X +import Data.MessagePack.Class as X +import Data.MessagePack.Generic () +import Data.MessagePack.Get as X +import Data.MessagePack.Object as X +import Data.MessagePack.Put 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. +unpack :: (Applicative m, Monad m, MessagePack a) + => L.ByteString -> m a +unpack = eitherToM . decodeOrFail >=> fromObject + where + eitherToM (Left (_, _, msg)) = fail msg + eitherToM (Right (_, _, res)) = return res diff --git a/src/Data/MessagePack/Assoc.hs b/src/Data/MessagePack/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Assoc.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Assoc +-- Copyright : (c) Daiki Handa, 2010-2011 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack map labeling type +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Assoc + ( Assoc (..) + ) where + +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) + +-- not defined for general Functor for performance reason. +-- (ie. you would want to write custom instances for each type using specialized mapM-like functions) +newtype Assoc a + = Assoc { unAssoc :: a } + deriving (Show, Read, Eq, Ord, Typeable, NFData) + +instance Arbitrary a => Arbitrary (Assoc a) where + arbitrary = Assoc <$> arbitrary diff --git a/src/Data/MessagePack/Class.hs b/src/Data/MessagePack/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Class.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Object +-- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack object definition +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Class + ( MessagePack (..) + , GMessagePack (..) + ) where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Arrow ((***)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Word (Word, Word16, Word32, Word64, Word8) +import GHC.Generics + +import Data.MessagePack.Assoc +import Data.MessagePack.Object + + +-- Generic serialisation. + +class GMessagePack f where + gToObject :: f a -> Object + gFromObject :: (Applicative m, Monad m) => Object -> m (f a) + + +class MessagePack a where + toObject :: a -> Object + fromObject :: (Applicative m, Monad m) => Object -> m a + + default toObject :: (Generic a, GMessagePack (Rep a)) + => a -> Object + toObject = genericToObject + default fromObject :: ( Applicative m, Monad m + , Generic a, GMessagePack (Rep a)) + => Object -> m a + fromObject = genericFromObject + + +genericToObject :: (Generic a, GMessagePack (Rep a)) + => a -> Object +genericToObject = gToObject . from + +genericFromObject :: ( Applicative m, Monad m + , Generic a, GMessagePack (Rep a)) + => Object -> m a +genericFromObject x = to <$> gFromObject x + + +-- Instances for integral types (Int etc.). + +toInt :: Integral a => a -> Int64 +toInt = fromIntegral + +fromInt :: Integral a => Int64 -> a +fromInt = fromIntegral + +instance MessagePack Int64 where + toObject = ObjectInt + fromObject = \case + ObjectInt n -> return n + _ -> fail "invalid encoding for integer type" + +instance MessagePack Int where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } + +instance MessagePack Word where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word64 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } + + +-- Core instances. + +instance MessagePack Object where + toObject = id + fromObject = return + +instance MessagePack () where + toObject _ = ObjectArray [] + fromObject = \case + ObjectArray [] -> return () + _ -> fail "invalid encoding for ()" + +instance MessagePack Bool where + toObject = ObjectBool + fromObject = \case + ObjectBool b -> return b + _ -> fail "invalid encoding for Bool" + +instance MessagePack Float where + toObject = ObjectFloat + fromObject = \case + ObjectInt n -> return $ fromIntegral n + ObjectFloat f -> return f + ObjectDouble d -> return $ realToFrac d + _ -> fail "invalid encoding for Float" + +instance MessagePack Double where + toObject = ObjectDouble + fromObject = \case + ObjectInt n -> return $ fromIntegral n + ObjectFloat f -> return $ realToFrac f + ObjectDouble d -> return d + _ -> fail "invalid encoding for Double" + +-- Because of overlapping instance, this must be above [a]. +-- IncoherentInstances and TypeSynonymInstances are required for this to work. +instance MessagePack String where + toObject = toObject . T.pack + fromObject obj = T.unpack <$> fromObject obj + + +-- Instances for nullable types. + +instance MessagePack a => MessagePack (Maybe a) where + toObject = \case + Just a -> toObject a + Nothing -> ObjectNil + + fromObject = \case + ObjectNil -> return Nothing + obj -> Just <$> fromObject obj + + +-- Instances for binary and UTF-8 encoded string. + +instance MessagePack S.ByteString where + toObject = ObjectBin + fromObject = \case + ObjectBin r -> return r + _ -> fail "invalid encoding for ByteString" + +instance MessagePack L.ByteString where + toObject = ObjectBin . L.toStrict + fromObject obj = L.fromStrict <$> fromObject obj + +instance MessagePack T.Text where + toObject = ObjectStr + fromObject = \case + ObjectStr s -> return s + _ -> fail "invalid encoding for Text" + +instance MessagePack LT.Text where + toObject = toObject . LT.toStrict + fromObject obj = LT.fromStrict <$> fromObject obj + + +-- Instances for array-like data structures. + +instance MessagePack a => MessagePack [a] where + toObject = ObjectArray . map toObject + fromObject = \case + ObjectArray xs -> mapM fromObject xs + _ -> fail "invalid encoding for list" + + +-- Instances for map-like data structures. + +instance (MessagePack a, MessagePack b) => MessagePack (Assoc [(a, b)]) where + toObject (Assoc xs) = ObjectMap $ map (toObject *** toObject) xs + fromObject = \case + ObjectMap xs -> + Assoc <$> mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs + _ -> + fail "invalid encoding for Assoc" + +instance (MessagePack k, MessagePack v, Ord k) => MessagePack (Map.Map k v) where + toObject = toObject . Assoc . Map.toList + fromObject obj = Map.fromList . unAssoc <$> fromObject obj + +instance MessagePack v => MessagePack (IntMap.IntMap v) where + toObject = toObject . Assoc . IntMap.toList + fromObject obj = IntMap.fromList . unAssoc <$> fromObject obj + +instance (MessagePack k, MessagePack v, Hashable k, Eq k) => MessagePack (HashMap.HashMap k v) where + toObject = toObject . Assoc . HashMap.toList + fromObject obj = HashMap.fromList . unAssoc <$> fromObject obj + + +-- Instances for various tuple arities. + +instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where + toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] + fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where + toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] + fromObject (ObjectArray [a1, a2, a3]) = (,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4) => MessagePack (a1, a2, a3, a4) where + toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4] + fromObject (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5) => MessagePack (a1, a2, a3, a4, a5) where + toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5] + fromObject (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6) => MessagePack (a1, a2, a3, a4, a5, a6) where + toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7) => MessagePack (a1, a2, a3, a4, a5, a6, a7) where + toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8, MessagePack a9) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8, a9) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 <*> fromObject a9 + fromObject _ = fail "invalid encoding for tuple" diff --git a/src/Data/MessagePack/Generic.hs b/src/Data/MessagePack/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Generic.hs @@ -0,0 +1,126 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Data.MessagePack.Generic () where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Monad ((>=>)) +import Data.Bits (shiftR) +import Data.Word (Word64) +import GHC.Generics + +import Data.MessagePack.Class +import Data.MessagePack.Object (Object (..)) + + +instance GMessagePack U1 where + gToObject U1 = ObjectNil + gFromObject ObjectNil = return U1 + gFromObject _ = fail "invalid encoding for custom unit type" + +instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where + gToObject = toObject . prodToObject + gFromObject = fromObject >=> prodFromObject + +instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where + gToObject = sumToObject 0 size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + + gFromObject = \case + ObjectInt code -> checkSumFromObject0 size (fromIntegral code) + o -> fromObject o >>= uncurry (checkSumFromObject size) + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + +instance GMessagePack a => GMessagePack (M1 t c a) where + gToObject (M1 x) = gToObject x + gFromObject x = M1 <$> gFromObject x + +instance MessagePack a => GMessagePack (K1 i a) where + gToObject (K1 x) = toObject x + gFromObject o = K1 <$> fromObject o + + +-- Product type packing. + +class GProdPack f where + prodToObject :: f a -> [Object] + prodFromObject :: (Applicative m, Monad m) => [Object] -> m (f a) + + +instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where + prodToObject (a :*: b) = gToObject a : prodToObject b + prodFromObject (a:b) = (:*:) <$> gFromObject a <*> prodFromObject b + prodFromObject _ = fail "invalid encoding for product type" + +instance GMessagePack a => GProdPack (M1 t c a) where + prodToObject (M1 x) = [gToObject x] + prodFromObject [x] = M1 <$> gFromObject x + prodFromObject _ = fail "invalid encoding for product type" + + +-- Sum type packing. + +checkSumFromObject0 :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> m (f a) +checkSumFromObject0 size code + | code < size = sumFromObject code size ObjectNil + | otherwise = fail "invalid encoding for sum type" + + +checkSumFromObject :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a) +checkSumFromObject size code x + | code < size = sumFromObject code size x + | otherwise = fail "invalid encoding for sum type" + + +class GSumPack f where + sumToObject :: Word64 -> Word64 -> f a -> Object + sumFromObject :: (Applicative m, Monad m) => Word64 -> Word64 -> Object -> m (f a) + + +instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where + sumToObject code size = \case + L1 x -> sumToObject code sizeL x + R1 x -> sumToObject (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + sumFromObject code size x + | code < sizeL = L1 <$> sumFromObject code sizeL x + | otherwise = R1 <$> sumFromObject (code - sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + +instance GSumPack (C1 c U1) where + sumToObject code _ _ = toObject code + sumFromObject _ _ = gFromObject + + +instance GMessagePack a => GSumPack (C1 c a) where + sumToObject code _ x = toObject (code, gToObject x) + sumFromObject _ _ = gFromObject + + +-- Sum size. + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged { unTagged :: b } + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/src/Data/MessagePack/Get.hs b/src/Data/MessagePack/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Get.hs @@ -0,0 +1,147 @@ +{-# 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 + ( getNil + , getBool + , getInt + , 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 (Word8) + +getNil :: Get () +getNil = tag 0xC0 + +getBool :: Get Bool +getBool = + False <$ tag 0xC2 <|> + True <$ tag 0xC3 + +getInt :: Get Int64 +getInt = + getWord8 >>= \case + c | c .&. 0x80 == 0x00 -> + return $ fromIntegral c + | c .&. 0xE0 == 0xE0 -> + return $ fromIntegral (fromIntegral c :: Int8) + 0xCC -> fromIntegral <$> getWord8 + 0xCD -> fromIntegral <$> getWord16be + 0xCE -> fromIntegral <$> getWord32be + 0xCF -> fromIntegral <$> getWord64be + 0xD0 -> fromIntegral <$> getInt8 + 0xD1 -> fromIntegral <$> getInt16be + 0xD2 -> fromIntegral <$> getInt32be + 0xD3 -> fromIntegral <$> getInt64be + _ -> 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/Object.hs b/src/Data/MessagePack/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Object.hs @@ -0,0 +1,110 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +module Data.MessagePack.Object (Object (..)) where + +import Control.Applicative ((<$), (<$>), (<*>), (<|>)) +import Control.DeepSeq (NFData (..)) +import Data.Binary (Binary (get, put), Get, Put) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int (Int64) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Typeable (Typeable) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Prelude hiding (putStr) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) +import qualified Test.QuickCheck.Gen as Gen + +import Data.MessagePack.Get +import Data.MessagePack.Put + + +-- | Object Representation of MessagePack data. +data Object + = ObjectNil + -- ^ represents nil + | ObjectBool !Bool + -- ^ represents true or false + | ObjectInt {-# UNPACK #-} !Int64 + -- ^ represents an integer + | ObjectFloat {-# UNPACK #-} !Float + -- ^ represents a floating point number + | ObjectDouble {-# UNPACK #-} !Double + -- ^ represents a floating point number + | ObjectStr !T.Text + -- ^ extending Raw type represents a UTF-8 string + | ObjectBin !S.ByteString + -- ^ extending Raw type represents a byte array + | ObjectArray ![Object] + -- ^ represents a sequence of objects + | ObjectMap ![(Object, Object)] + -- ^ represents key-value pairs of objects + | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString + -- ^ represents a tuple of an integer and a byte array where + -- the integer represents type information and the byte array represents data. + deriving (Read, Show, Eq, Ord, Typeable, Generic) + +instance NFData Object + +instance Binary Object where + get = getObject + put = putObject + + +getObject :: Get Object +getObject = + ObjectNil <$ getNil + <|> ObjectBool <$> getBool + <|> ObjectInt <$> getInt + <|> ObjectFloat <$> getFloat + <|> ObjectDouble <$> getDouble + <|> ObjectStr <$> getStr + <|> ObjectBin <$> getBin + <|> ObjectArray <$> getArray getObject + <|> ObjectMap <$> getMap getObject getObject + <|> uncurry ObjectExt <$> getExt + +putObject :: Object -> Put +putObject = \case + ObjectNil -> putNil + ObjectBool b -> putBool b + ObjectInt n -> putInt 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 + + +instance Arbitrary Object where + arbitrary = Gen.sized $ \n -> Gen.oneof + [ return ObjectNil + , ObjectBool <$> arbitrary + , ObjectInt <$> arbitrary + , ObjectFloat <$> arbitrary + , ObjectDouble <$> arbitrary + , ObjectStr <$> arbitrary + , ObjectBin <$> arbitrary + , ObjectArray <$> Gen.resize (n `div` 2) arbitrary + , ObjectMap <$> Gen.resize (n `div` 4) arbitrary + , ObjectExt <$> arbitrary <*> arbitrary + ] + +instance Arbitrary S.ByteString where + arbitrary = S.pack <$> arbitrary + +instance Arbitrary L.ByteString where + arbitrary = L.pack <$> arbitrary + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary LT.Text where + arbitrary = LT.pack <$> arbitrary 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,139 @@ +{-# 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 + ( putNil + , putBool + , putInt + , 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 (Word8) + +import Prelude hiding (putStr) + +putNil :: Put +putNil = putWord8 0xC0 + +putBool :: Bool -> Put +putBool False = putWord8 0xC2 +putBool True = putWord8 0xC3 + +putInt :: Int64 -> Put +putInt n + | -32 <= n && n <= 127 = + 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) + +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/src/Data/MessagePack/Result.hs b/src/Data/MessagePack/Result.hs new file mode 100644 --- /dev/null +++ b/src/Data/MessagePack/Result.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE Safe #-} +module Data.MessagePack.Result where + +import Control.Applicative (Applicative, pure, (<$>), (<*>)) +import Test.QuickCheck.Arbitrary (Arbitrary (..)) +import qualified Test.QuickCheck.Gen as Gen + + +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 = pure + fail = Failure + + Success x >>= f = f x + Failure msg >>= _ = Failure msg + + +instance Arbitrary a => Arbitrary (Result a) where + arbitrary = Gen.oneof + [ Success <$> arbitrary + , Failure <$> arbitrary + ] 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 #-}