diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,13 @@ +## 1.0.1.0 + +- Fix incorrect MessagePack tag when encoding single-precision `Float`s +- Fix looping/hanging `MessagePack (Maybe a)` instance +- Add support for `binary-0.8` API +- Drop dependency on `blaze-builder` +- Add new operations + - `getWord`, `getWord64`, `getInt64` + - `putWord`, `putWord64`, `putInt64` +- Add `Read` instance for `Object` and `Assoc` +- Add `Generic` instance for `Object` +- Add `Object` instance `ShortByteString` +- Declare API `Trustworthy` for SafeHaskell diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,6 @@ -Copyright (c) 2009-2010, Hideyuki Tanaka +Copyright (c) Hideyuki Tanaka 2009-2010 + (c) Herbert Valerio Riedel 2019 + All rights reserved. Redistribution and use in source and binary forms, with or without @@ -12,7 +14,7 @@ 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 +THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka AND CONTRIBUTORS ''AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/msgpack.cabal b/msgpack.cabal --- a/msgpack.cabal +++ b/msgpack.cabal @@ -1,24 +1,42 @@ +cabal-version: 1.12 name: msgpack -version: 1.0.0 +version: 1.0.1.0 + synopsis: A Haskell implementation of MessagePack -description: A Haskell implementation of MessagePack +description: + A Haskell implementation of the data interchange format. + MessagePack is a binary format which aims to be compact and supports encoding a superset of the data-model. + . + == Related Packages + . + A JSON adapter for the library is provided by the package. + . + The package provides an implementation of the MessagePack-RPC protocol. + + homepage: http://msgpack.org/ +bug-reports: https://github.com/msgpack/msgpack-haskell/issues license: BSD3 license-file: LICENSE author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka -copyright: Copyright (c) 2009-2015, Hideyuki Tanaka +maintainer: Herbert Valerio Riedel +copyright: Copyright (c) Hideyuki Tanaka 2009-2015, + (c) Herbert Valerio Riedel 2019 + category: Data -stability: Experimental -cabal-version: >= 1.10 build-type: Simple +extra-source-files: CHANGES.md + source-repository head type: git - location: git://github.com/msgpack/msgpack-haskell.git + location: http://github.com/msgpack/msgpack-haskell.git + subdir: msgpack library default-language: Haskell2010 + other-extensions: LambdaCase, OverloadedLists + default-extensions: Trustworthy hs-source-dirs: src exposed-modules: Data.MessagePack @@ -27,19 +45,23 @@ Data.MessagePack.Get Data.MessagePack.Put - build-depends: base ==4.* - , mtl >=2.2 - , bytestring >=0.10 - , text >=1.2 - , containers >=0.5.5 - , unordered-containers >=0.2.5 - , hashable - , vector >=0.10 - , blaze-builder >=0.4 - , deepseq >=1.3 - , binary >=0.7 - , data-binary-ieee754 + build-depends: base >= 4.7 && < 4.13 + , mtl >= 2.1.3.1 && < 2.3 + , bytestring >= 0.10.4 && < 0.11 + , text >= 1.2 && < 1.3 + , containers >= 0.5.5 && < 0.7 + , unordered-containers >= 0.2.5 && < 0.3 + , hashable >= 1.1.2.4 && < 1.3 + , vector >= 0.10.11 && < 0.13 + , deepseq >= 1.3 && < 1.5 + , binary >= 0.7.1 && < 0.9 + , data-binary-ieee754 >= 0.4.4 && < 0.5 + ghc-options: -Wall + + if impl(ghc >= 7.10) + ghc-options: -fno-warn-trustworthy-safe + test-suite msgpack-tests type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -47,9 +69,12 @@ main-is: test.hs - build-depends: base + build-depends: msgpack + -- inherited constraints via `msgpack` + , base , bytestring - , QuickCheck >=2.8 - , tasty >=0.10 - , tasty-quickcheck >=0.8 - , msgpack + -- test-specific dependencies + , async == 2.2.* + , tasty == 1.2.* + , tasty-quickcheck == 0.10.* + , QuickCheck == 2.12.* diff --git a/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -1,14 +1,12 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable +-- Simple interface to encode\/decode to\/from the [MessagePack](https://msgpack.org/) format. -- --- Simple interface to pack and unpack MessagePack data. -- -------------------------------------------------------------------- @@ -18,14 +16,13 @@ -- * Re-export modules -- $reexports - -- module X, module Data.MessagePack.Assoc, module Data.MessagePack.Get, module Data.MessagePack.Object, module Data.MessagePack.Put, ) where -import Data.Binary +import Data.Binary (decode, encode) import qualified Data.ByteString.Lazy as L import Data.MessagePack.Assoc diff --git a/src/Data/MessagePack/Assoc.hs b/src/Data/MessagePack/Assoc.hs --- a/src/Data/MessagePack/Assoc.hs +++ b/src/Data/MessagePack/Assoc.hs @@ -26,4 +26,4 @@ -- (ie. you would want to write custom instances for each type using specialized mapM-like functions) newtype Assoc a = Assoc { unAssoc :: a } - deriving (Show, Eq, Ord, Typeable, NFData) + deriving (Show, Read, Eq, Ord, Typeable, NFData) diff --git a/src/Data/MessagePack/Get.hs b/src/Data/MessagePack/Get.hs --- a/src/Data/MessagePack/Get.hs +++ b/src/Data/MessagePack/Get.hs @@ -3,27 +3,26 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Get --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- MessagePack Deserializer using @Data.Binary@ +-- MessagePack Deserializer using "Data.Binary" -- -------------------------------------------------------------------- module Data.MessagePack.Get( - getNil, getBool, getInt, getFloat, getDouble, + getNil, getBool, getFloat, getDouble, + getInt, getWord, getInt64, getWord64, getStr, getBin, getArray, getMap, getExt, ) where import Control.Applicative import Control.Monad import Data.Binary -import Data.Binary.Get -import Data.Binary.IEEE754 +import Data.Binary.Get (getByteString, getWord16be, getWord32be, + getWord64be) +import Data.Binary.IEEE754 (getFloat32be, getFloat64be) import Data.Bits import qualified Data.ByteString as S import Data.Int @@ -36,26 +35,99 @@ getBool :: Get Bool getBool = - False <$ tag 0xC2 <|> - True <$ tag 0xC3 + getWord8 >>= \case + 0xC2 -> return False + 0xC3 -> return True + _ -> empty + +-- | Deserialize an integer into an 'Int' +-- +-- __WARNING__: Currently this function silently wraps around integers to make them fit into an 'Int'. This will be changed in the next major version (i.e. @msgpack-1.1.0@). getInt :: Get Int getInt = getWord8 >>= \case - c | c .&. 0x80 == 0x00 -> - return $ fromIntegral c - | c .&. 0xE0 == 0xE0 -> - return $ fromIntegral (fromIntegral c :: Int8) + 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 +-- | Deserialize an integer into a 'Word' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Word' type. +-- +-- @since 1.0.1.0 +getWord :: Get Word +getWord + | maxWord == maxBound = fromIntegral <$> getWord64 + | otherwise = do + w <- getWord64 + if w <= maxWord + then return (fromIntegral w) + else empty + where + maxWord :: Word64 + maxWord = fromIntegral (maxBound :: Word) + +-- | Deserialize an integer into an 'Int64' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int64' type. +-- +-- @since 1.0.1.0 +getInt64 :: Get Int64 +getInt64 = + 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 -> do + x <- fromIntegral <$> getWord64be + if x >= 0 then return x else empty + + 0xD0 -> fromIntegral <$> getInt8 + 0xD1 -> fromIntegral <$> getInt16be + 0xD2 -> fromIntegral <$> getInt32be + 0xD3 -> getInt64be + + _ -> empty + +-- | Deserialize an integer into a 'Word' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Word64' type. +-- +-- @since 1.0.1.0 +getWord64 :: Get Word64 +getWord64 = + 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 -> getWord64be + + 0xD0 -> do { x <- getInt8 ; if x >= 0 then return (fromIntegral x) else empty } + 0xD1 -> do { x <- getInt16be ; if x >= 0 then return (fromIntegral x) else empty } + 0xD2 -> do { x <- getInt32be ; if x >= 0 then return (fromIntegral x) else empty } + 0xD3 -> do { x <- getInt64be ; if x >= 0 then return (fromIntegral x) else empty } + + _ -> empty + + getFloat :: Get Float getFloat = tag 0xCA >> getFloat32be @@ -73,7 +145,7 @@ _ -> empty bs <- getByteString len case T.decodeUtf8' bs of - Left _ -> empty + Left _ -> empty Right v -> return v getBin :: Get S.ByteString @@ -119,6 +191,12 @@ _ -> empty (,) <$> getWord8 <*> getByteString len +tag :: Word8 -> Get () +tag t = do + b <- getWord8 + guard $ t == b + +-- internal helpers for operations missing from older `binary` versions getInt8 :: Get Int8 getInt8 = fromIntegral <$> getWord8 @@ -130,8 +208,3 @@ 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 --- a/src/Data/MessagePack/Object.hs +++ b/src/Data/MessagePack/Object.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-} @@ -8,13 +9,10 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Object --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- -- MessagePack object definition -- -------------------------------------------------------------------- @@ -33,7 +31,8 @@ import Data.Binary import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Hashable +import qualified Data.ByteString.Short as SBS +import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map @@ -41,6 +40,7 @@ import qualified Data.Text.Lazy as LT import Data.Typeable import qualified Data.Vector as V +import GHC.Generics (Generic) import Data.MessagePack.Assoc import Data.MessagePack.Get @@ -71,7 +71,7 @@ | 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 (Show, Eq, Ord, Typeable) + deriving (Show, Read, Eq, Ord, Typeable, Generic) instance NFData Object where rnf obj = case obj of @@ -105,20 +105,24 @@ ObjectMap m -> putMap putObject putObject m ObjectExt b r -> putExt b r +-- | This 'Binary' instance encodes\/decodes to\/from MessagePack format instance Binary Object where get = getObject put = putObject +-- | Class for converting between MessagePack 'Object's and native Haskell types. class MessagePack a where toObject :: a -> Object fromObject :: Object -> Maybe a -- core instances +-- | The trivial identity 'MessagePack' instance instance MessagePack Object where toObject = id fromObject = Just +-- | Encodes as 'ObjectNil' instance MessagePack () where toObject _ = ObjectNil fromObject = \case @@ -182,6 +186,9 @@ -- nullable +-- | 'Maybe's are encoded as nullable types, i.e. 'Nothing' is encoded as @nil@. +-- +-- __NOTE__: Encoding nested 'Maybe's or 'Maybe's enclosing types which encode to @nil@ (such as '()') will break round-tripping instance MessagePack a => MessagePack (Maybe a) where toObject = \case Just a -> toObject a @@ -189,7 +196,7 @@ fromObject = \case ObjectNil -> Just Nothing - obj -> fromObject obj + obj -> Just <$> fromObject obj -- UTF8 string like @@ -197,6 +204,11 @@ toObject = ObjectBin . L.toStrict fromObject obj = L.fromStrict <$> fromObject obj +-- | @since 1.0.1.0 +instance MessagePack SBS.ShortByteString where + toObject = ObjectBin . SBS.fromShort + fromObject obj = SBS.toShort <$> fromObject obj + instance MessagePack T.Text where toObject = ObjectStr fromObject = \case @@ -236,7 +248,7 @@ 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 _ = Nothing + fromObject _ = Nothing instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] diff --git a/src/Data/MessagePack/Put.hs b/src/Data/MessagePack/Put.hs --- a/src/Data/MessagePack/Put.hs +++ b/src/Data/MessagePack/Put.hs @@ -1,27 +1,26 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Put --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- MessagePack Serializer using @Data.Binary@ +-- MessagePack Serializer using "Data.Binary". -- -------------------------------------------------------------------- module Data.MessagePack.Put ( - putNil, putBool, putInt, putFloat, putDouble, + putNil, putBool, putFloat, putDouble, + putInt, putWord, putInt64, putWord64, putStr, putBin, putArray, putMap, putExt, ) where import Data.Binary -import Data.Binary.IEEE754 +import Data.Binary.IEEE754 (putFloat32be, putFloat64be) import Data.Binary.Put import Data.Bits import qualified Data.ByteString as S +import Data.Int import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V @@ -36,29 +35,43 @@ putBool True = putWord8 0xC3 putInt :: Int -> 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) +putInt n = putInt64 (fromIntegral n) +-- | @since 1.0.1.0 +putWord :: Word -> Put +putWord n = putWord64 (fromIntegral n) + +-- | @since 1.0.1.0 +putInt64 :: Int64 -> Put +putInt64 n + -- positive fixnum stores 7-bit positive integer + -- negative fixnum stores 5-bit negative integer + | -32 <= n && n <= 127 = putWord8 $ fromIntegral n + + -- unsigned int encoding + | n >= 0 = putWord64 (fromIntegral n) + + -- signed int encoding + | -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) + +-- | @since 1.0.1.0 +putWord64 :: Word64 -> Put +putWord64 n + -- positive fixnum stores 7-bit positive integer + | n < 0x80 = putWord8 $ fromIntegral n + + -- unsigned int encoding + | 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 (fromIntegral n) + putFloat :: Float -> Put putFloat f = do - putWord8 0xCB + putWord8 0xCA putFloat32be f putDouble :: Double -> Put diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -35,6 +35,8 @@ \(a :: ()) -> a == mid a , testProperty "bool" $ \(a :: Bool) -> a == mid a + , testProperty "float" $ + \(a :: Float) -> a == mid a , testProperty "double" $ \(a :: Double) -> a == mid a , testProperty "string" $ @@ -43,8 +45,12 @@ \(a :: S.ByteString) -> a == mid a , testProperty "lazy-bytestring" $ \(a :: L.ByteString) -> a == mid a + , testProperty "maybe int" $ + \(a :: (Maybe Int)) -> a == mid a , testProperty "[int]" $ \(a :: [Int]) -> a == mid a + , testProperty "[()]" $ + \(a :: [()]) -> a == mid a , testProperty "[string]" $ \(a :: [String]) -> a == mid a , testProperty "(int, int)" $ @@ -61,4 +67,6 @@ \(a :: [(String, String)]) -> a == mid a , testProperty "Assoc [(string, int)]" $ \(a :: Assoc [(String, Int)]) -> a == mid a + , testProperty "maybe (Int,Bool,String)" $ + \(a :: (Maybe ((),Maybe Int,Maybe Float,Maybe Bool,Maybe Double,Maybe String))) -> a == mid a ]