diff --git a/.gitignore b/.gitignore index 4460397..bb4e4ab 100644 --- a/.gitignore +++ b/.gitignore @@ -1,15 +1,15 @@ -*~ -*# -*.o -*.hi -*.a -*.exe -cabal-dev/ -dist/ -attic/ -tmp/ -*.aes -/msgpack/.cabal-sandbox/ -/msgpack/cabal.sandbox.config -/msgpack-rpc/.cabal-sandbox/ -/msgpack-rpc/cabal.sandbox.config +*~ +*# +*.o +*.hi +*.a +*.exe +cabal-dev/ +/dist/ +attic/ +tmp/ +*.aes +/.stack-work/ +/dist-newstyle/ +/.ghc.environment.* +/cabal.project.local diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..8e241f1 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,37 @@ +# simplified haskell-ci Travis setup +# see also https://github.com/haskell-CI/haskell-ci + +language: haskell +sudo: enabled + +cache: + directories: + - $HOME/.cabal/store + +cabal: 2.4 + +matrix: + include: + - ghc: "8.6.4" + - ghc: "8.4.4" + - ghc: "8.2.2" + - ghc: "8.0.2" + - ghc: "7.10.3" + - ghc: "7.8.4" + + # configuration for testing with lower bounds + - ghc: "7.8.4" + env: 'PROJCONF=floor-ghc-7.8.4' + +install: + - cabal --version + - ghc --version + +script: + - '[ -z "$PROJCONF" ] || cp -v "cabal.project.$PROJCONF" cabal.project.local' + + - cabal v2-update + - cabal v2-build all + - cabal v2-test all +#- cabal check + - cabal v2-sdist all diff --git a/README.md b/README.md index f65a573..8addc1e 100644 --- a/README.md +++ b/README.md @@ -1,29 +1,28 @@ -MessagePack for Haskell +MessagePack for Haskell [![Build Status](https://travis-ci.org/msgpack/msgpack-haskell.svg?branch=master)](https://travis-ci.org/msgpack/msgpack-haskell) ======================= -This is a msgpack implementation of Haskell. +This is an implementation of [MessagePack](https://en.wikipedia.org/wiki/MessagePack) for [Haskell](https://www.haskell.org). -It containes +It contains: * Serializer/Deserializer * RPC -* IDL -# Install +# Installation -To install this, execute following instructions. +Execute following instructions: ~~~ {.bash} $ cabal update $ cabal install msgpack $ cabal install msgpack-rpc -$ cabal install msgpack-idl ~~~ -# Document +# Documentation -There are Haddoc documents on Hackage Database. +[Haddock](https://www.haskell.org/haddock) documentation can be found on Hackage: * * +* * diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..dc73f9d --- /dev/null +++ b/cabal.project @@ -0,0 +1,8 @@ +tests: True + +packages: + msgpack + msgpack-aeson + msgpack-rpc +-- msgpack-idl +-- msgpack-idl-web diff --git a/cabal.project.floor-ghc-7.8.4 b/cabal.project.floor-ghc-7.8.4 new file mode 100644 index 0000000..b61c623 --- /dev/null +++ b/cabal.project.floor-ghc-7.8.4 @@ -0,0 +1,22 @@ +-- freeze file for validating lower bounds + +-- with-compiler: ghc-7.8.4 +constraints: bytestring installed + , deepseq installed + , binary installed + , containers installed + + , mtl == 2.2.1 + , vector == 0.10.11.0 + , data-binary-ieee754 == 0.4.4 + , unordered-containers == 0.2.5.0 + , hashable == 1.1.2.4 + , text == 1.2.3.0 + , scientific == 0.3.2.0 + , aeson == 0.8.0.2 + , exceptions == 0.8 + , network == 2.6.0.0 + , monad-control == 1.0.0.0 + , conduit == 1.2.3.1 + , conduit-extra == 1.1.3.4 + , binary-conduit == 1.2.3 diff --git a/msgpack-aeson/LICENSE b/msgpack-aeson/LICENSE new file mode 100644 index 0000000..b31edfd --- /dev/null +++ b/msgpack-aeson/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, 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 Hideyuki Tanaka nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/msgpack-aeson/Setup.hs b/msgpack-aeson/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/msgpack-aeson/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal new file mode 100644 index 0000000..063ebd4 --- /dev/null +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -0,0 +1,54 @@ +cabal-version: 1.12 +name: msgpack-aeson +version: 0.2.0.0 + +synopsis: Aeson adapter for MessagePack +description: Aeson adapter for MessagePack +homepage: http://msgpack.org/ +bug-reports: https://github.com/msgpack/msgpack-haskell/issues +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Herbert Valerio Riedel +copyright: (c) 2015 Hideyuki Tanaka +category: Data +build-type: Simple + +source-repository head + type: git + location: http://github.com/msgpack/msgpack-haskell.git + subdir: msgpack-aeson + +library + hs-source-dirs: src + exposed-modules: Data.MessagePack.Aeson + + build-depends: base >= 4.7 && < 4.14 + , aeson >= 0.8.0.2 && < 0.12 + || >= 1.0 && < 1.5 + , bytestring >= 0.10.4 && < 0.11 + , msgpack >= 1.1.0 && < 1.2 + , scientific >= 0.3.2 && < 0.4 + , text >= 1.2.3 && < 1.3 + , unordered-containers >= 0.2.5 && < 0.3 + , vector >= 0.10.11 && < 0.13 + , deepseq >= 1.3 && < 1.5 + + default-language: Haskell2010 + + +test-suite msgpack-aeson-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + + build-depends: msgpack-aeson + -- inherited constraints via `msgpack-aeson` + , base + , aeson + , msgpack + -- test-specific dependencies + , tasty == 1.2.* + , tasty-hunit == 0.10.* + + default-language: Haskell2010 diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs new file mode 100644 index 0000000..d97ecc1 --- /dev/null +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Aeson bridge for MessagePack +module Data.MessagePack.Aeson ( + -- * Conversion functions + toAeson, fromAeson, + unsafeViaToJSON, viaFromJSON, + + -- * Wrapper instances + AsMessagePack(..), + AsAeson(..), + MessagePackAesonError(..), + + -- * Utility functions + packAeson, unpackAeson, + decodeMessagePack, encodeMessagePack, + ) where + +import Control.Applicative +import Control.Arrow +import Control.DeepSeq +import Control.Exception +import Data.Aeson as A +import qualified Data.ByteString.Lazy as L (ByteString) +import Data.Data +import qualified Data.HashMap.Strict as HM +import Data.Int +import Data.Maybe +import Data.MessagePack as MP +import Data.MessagePack.Integer +import Data.Scientific +import qualified Data.Text.Encoding as T +import Data.Traversable (traverse) +import qualified Data.Vector as V +import Data.Word + +-- | Convert 'MP.Object' to JSON 'Value' +toAeson :: MP.Object -> A.Result Value +toAeson = \case + ObjectNil -> pure Null + ObjectBool b -> pure (Bool b) + ObjectInt n -> pure $! Number $! fromIntegral n + ObjectFloat f -> pure $! Number $! realToFrac f + ObjectDouble d -> pure $! Number $! realToFrac d + ObjectStr t -> pure (String t) + ObjectBin b -> fail $ "ObjectBin is not supported by JSON" + ObjectArray v -> Array <$> V.mapM toAeson v + ObjectMap m -> + A.Object . HM.fromList . V.toList + <$> V.mapM (\(k, v) -> (,) <$> from k <*> toAeson v) m + where from = mpResult fail pure . MP.fromObject + ObjectExt _ _ -> fail "ObjectExt is not supported by JSON" + +-- | Convert JSON 'Value' to 'MP.Object' +fromAeson :: Value -> MP.Result MP.Object +fromAeson = \case + Null -> pure ObjectNil + Bool b -> pure $ ObjectBool b + Number s -> + -- NOTE floatingOrInteger can OOM on untrusted input + case floatingOrInteger s of + Left n -> pure $ ObjectDouble n + Right (fromIntegerTry -> Right n) -> pure $ ObjectInt n + Right _ -> fail "number out of bounds" + String t -> pure $ ObjectStr t + Array v -> ObjectArray <$> traverse fromAeson v + A.Object o -> (ObjectMap . V.fromList) <$> traverse fromEntry (HM.toList o) + where + fromEntry (k, v) = (\a -> (ObjectStr k, a)) <$> fromAeson v + +-- Helpers to piggyback off a JSON encoder / decoder when creating a MessagePack +-- instance. +-- +-- Not as efficient as a direct encoder. +viaFromJSON :: FromJSON a => MP.Object -> MP.Result a +viaFromJSON o = case toAeson o >>= fromJSON of + A.Success a -> MP.Success a + A.Error e -> MP.Error e + +-- WARNING: not total for JSON numbers outside the 64 bit range +unsafeViaToJSON :: ToJSON a => a -> MP.Object +unsafeViaToJSON a = case fromAeson $ toJSON a of + MP.Error e -> throw $ MessagePackAesonError e + MP.Success a -> a + +data MessagePackAesonError = MessagePackAesonError String + deriving (Eq, Show, Typeable) +instance Exception MessagePackAesonError + +-- | Wrapper for using Aeson values as MessagePack value. +newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } + deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) + +instance (FromJSON a, ToJSON a) => MessagePack (AsMessagePack a) where + fromObject o = AsMessagePack <$> (aResult fail pure (fromJSON =<< toAeson o)) + toObject = unsafeViaToJSON . getAsMessagePack + +-- | Wrapper for using MessagePack values as Aeson value. +newtype AsAeson a = AsAeson { getAsAeson :: a } + deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) + +instance MessagePack a => ToJSON (AsAeson a) where + toJSON = aResult (const Null) id . toAeson . toObject . getAsAeson + +instance MessagePack a => FromJSON (AsAeson a) where + parseJSON j = case fromAeson j of + MP.Error e -> fail e + MP.Success a -> mpResult fail (pure . AsAeson) $ fromObject a + +-- | Encode to MessagePack via "Data.Aeson"'s 'ToJSON' instances +packAeson :: ToJSON a => a -> MP.Result L.ByteString +packAeson a = pack <$> (fromAeson $ toJSON a) + +-- | Decode from MessagePack via "Data.Aeson"'s 'FromJSON' instances +unpackAeson :: FromJSON a => L.ByteString -> A.Result a +unpackAeson b = fromJSON =<< toAeson =<< either fail pure (unpack b) + +-- | Encode MessagePack value to JSON document +encodeMessagePack :: MessagePack a => a -> L.ByteString +encodeMessagePack = encode . toJSON . AsAeson + +-- | Decode MessagePack value from JSON document +decodeMessagePack :: MessagePack a => L.ByteString -> A.Result a +decodeMessagePack b = getAsAeson <$> (fromJSON =<< either A.Error A.Success (eitherDecode b)) + +aResult f s = \case + A.Success a -> s a + A.Error e -> f e + +mpResult f s = \case + MP.Success a -> s a + MP.Error e -> f e diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs new file mode 100644 index 0000000..e58462d --- /dev/null +++ b/msgpack-aeson/test/test.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Applicative +import Control.Monad +import Data.Aeson as A +import Data.Aeson.TH +import Data.Int +import Data.MessagePack as MP +import Data.MessagePack.Aeson +import Data.Word +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +data T + = A Int String + | B Double + deriving (Show, Eq, Generic) + +instance FromJSON T; instance ToJSON T + +data U + = C { c1 :: Int, c2 :: String } + | D { z1 :: Double } + deriving (Show, Eq, Generic) + +instance FromJSON U; instance ToJSON U + +data V + = E String | F + deriving (Show, Eq, Generic) + +instance FromJSON V; instance ToJSON V + +data W a + = G a String + | H { hHoge :: Int, h_age :: a } + deriving (Show, Eq, Generic) + +instance FromJSON a => FromJSON (W a); instance ToJSON a => ToJSON (W a) + +instance (FromJSON a, ToJSON a) => MessagePack (W a) where + toObject = unsafeViaToJSON + fromObject = viaFromJSON + +test :: (MessagePack a, Show a, Eq a) => a -> IO () +test v = do + let bs = pack v + print bs + print (unpack bs == Right v) + + let oa = toObject v + print oa + print (fromObject oa == MP.Success v) + +roundTrip :: (Show a, Eq a, ToJSON a, FromJSON a) => a -> IO () +roundTrip v = do + let mp = packAeson v + v' = case mp of + MP.Error e -> A.Error e + MP.Success a -> unpackAeson a + v' @?= pure v + +roundTrip' :: (Show a, Eq a, MessagePack a) => a -> IO () +roundTrip' v = (unpack . pack $ v) @?= pure v + +main :: IO () +main = + defaultMain $ + testGroup "test case" + [ testCase "unnamed 1" $ + roundTrip $ A 123 "hoge" + , testCase "unnamed 2" $ + roundTrip $ B 3.14 + , testCase "named 1" $ + roundTrip $ C 123 "hoge" + , testCase "named 2" $ + roundTrip $ D 3.14 + , testCase "unit 1" $ + roundTrip $ E "hello" + , testCase "unit 2" $ + roundTrip F + , testCase "parameterized 1" $ + roundTrip' $ G (E "hello") "world" + , testCase "parameterized 2" $ + roundTrip' $ H 123 F + , testCase "negative numbers" $ + roundTrip $ Number $ fromIntegral (minBound :: Int64) + , testCase "positive numbers" $ + roundTrip $ Number $ fromIntegral (maxBound :: Word64) + , testCase "big negative" $ + (fromAeson . Number $ -9223372036854775936) @?= (MP.Error "number out of bounds") + , testCase "big positive" $ + (fromAeson . Number $ 999223372036854775936) @?= (MP.Error "number out of bounds") + , testCase "double precision" $ + roundTrip . Number $ 10.0 + , testCase "really big integer" $ + (fromAeson . Number $ read "1.0e999999") @?= (MP.Error "number out of bounds") + -- high precision decimals silently lose precision + ] diff --git a/msgpack-idl-web/mpidl-web.cabal b/msgpack-idl-web/mpidl-web.cabal index c54676a..f55b172 100644 --- a/msgpack-idl-web/mpidl-web.cabal +++ b/msgpack-idl-web/mpidl-web.cabal @@ -84,8 +84,8 @@ executable mpidl-web if flag(library-only) Buildable: False - main-is: ../main.hs - hs-source-dirs: dist + main-is: main.hs + hs-source-dirs: src build-depends: base , mpidl-web , yesod-default diff --git a/msgpack-idl-web/Application.hs b/msgpack-idl-web/src/Application.hs similarity index 100% rename from msgpack-idl-web/Application.hs rename to msgpack-idl-web/src/Application.hs diff --git a/msgpack-idl-web/Foundation.hs b/msgpack-idl-web/src/Foundation.hs similarity index 100% rename from msgpack-idl-web/Foundation.hs rename to msgpack-idl-web/src/Foundation.hs diff --git a/msgpack-idl-web/Handler/Home.hs b/msgpack-idl-web/src/Handler/Home.hs similarity index 100% rename from msgpack-idl-web/Handler/Home.hs rename to msgpack-idl-web/src/Handler/Home.hs diff --git a/msgpack-idl-web/Import.hs b/msgpack-idl-web/src/Import.hs similarity index 100% rename from msgpack-idl-web/Import.hs rename to msgpack-idl-web/src/Import.hs diff --git a/msgpack-idl-web/Model.hs b/msgpack-idl-web/src/Model.hs similarity index 100% rename from msgpack-idl-web/Model.hs rename to msgpack-idl-web/src/Model.hs diff --git a/msgpack-idl-web/Settings.hs b/msgpack-idl-web/src/Settings.hs similarity index 100% rename from msgpack-idl-web/Settings.hs rename to msgpack-idl-web/src/Settings.hs diff --git a/msgpack-idl-web/Settings/Development.hs b/msgpack-idl-web/src/Settings/Development.hs similarity index 100% rename from msgpack-idl-web/Settings/Development.hs rename to msgpack-idl-web/src/Settings/Development.hs diff --git a/msgpack-idl-web/Settings/StaticFiles.hs b/msgpack-idl-web/src/Settings/StaticFiles.hs similarity index 100% rename from msgpack-idl-web/Settings/StaticFiles.hs rename to msgpack-idl-web/src/Settings/StaticFiles.hs diff --git a/msgpack-idl-web/devel.hs b/msgpack-idl-web/src/devel.hs similarity index 100% rename from msgpack-idl-web/devel.hs rename to msgpack-idl-web/src/devel.hs diff --git a/msgpack-idl-web/main.hs b/msgpack-idl-web/src/main.hs similarity index 100% rename from msgpack-idl-web/main.hs rename to msgpack-idl-web/src/main.hs diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index a7757c3..0acf909 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -1,42 +1,44 @@ +cabal-version: 1.12 name: msgpack-rpc -version: 0.9.0 +version: 1.0.0 + synopsis: A MessagePack-RPC Implementation description: A MessagePack-RPC Implementation homepage: http://msgpack.org/ +bug-reports: https://github.com/msgpack/msgpack-haskell/issues license: BSD3 license-file: LICENSE author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka +maintainer: Herbert Valerio Riedel copyright: (c) 2010-2015, Hideyuki Tanaka category: Network -stability: Experimental -cabal-version: >=1.18 build-type: Simple source-repository head type: git - location: git://github.com/msgpack/msgpack-haskell.git + location: http://github.com/msgpack/msgpack-haskell.git + subdir: msgpack-rpc library default-language: Haskell2010 hs-source-dirs: src - exposed-modules: Network.MessagePackRpc.Server - Network.MessagePackRpc.Client + exposed-modules: Network.MessagePack.Server + Network.MessagePack.Client - build-depends: base >= 4.5 - , bytestring >= 0.10 - , text >= 1.2 - , network >= 2.6 - , random >= 1.1 - , mtl >= 2.2 - , monad-control >= 1.0 - , conduit >= 1.2 - , conduit-extra >= 1.1 - , binary-conduit >= 1.2 - , exceptions >= 0.8 - , binary >= 0.7 - , msgpack >= 0.8 + build-depends: base >= 4.5 && < 4.13 + , bytestring >= 0.10.4 && < 0.11 + , text >= 1.2.3 && < 1.3 + , network >= 2.6 && < 2.9 + || >= 3.0 && < 3.1 + , mtl >= 2.2.1 && < 2.3 + , monad-control >= 1.0.0.0 && < 1.1 + , conduit >= 1.2.3.1 && < 1.3 + , conduit-extra >= 1.1.3.4 && < 1.3 + , binary-conduit >= 1.2.3 && < 1.3 + , exceptions >= 0.8 && < 0.11 + , binary >= 0.7.1 && < 0.9 + , msgpack >= 1.1.0 && < 1.2 test-suite msgpack-rpc-test default-language: Haskell2010 @@ -44,10 +46,12 @@ test-suite msgpack-rpc-test hs-source-dirs: test main-is: test.hs - build-depends: base + build-depends: msgpack-rpc + -- inherited constraints via `msgpack-rpc` + , base , mtl , network - , async >= 2.0 - , tasty >= 0.10 - , tasty-hunit >= 0.9 - , msgpack-rpc + -- test-specific dependencies + , async == 2.2.* + , tasty == 1.2.* + , tasty-hunit == 0.10.* diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs similarity index 78% rename from msgpack-rpc/src/Network/MessagePackRpc/Client.hs rename to msgpack-rpc/src/Network/MessagePack/Client.hs index 6801ce7..e7a8edb 100644 --- a/msgpack-rpc/src/Network/MessagePackRpc/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -17,18 +17,18 @@ -- -- A simple example: -- --- > import Network.MessagePackRpc.Client +-- > import Network.MessagePack.Client -- > -- > add :: Int -> Int -> Client Int -- > add = call "add" -- > --- > main = runClient "localhost" 5000 $ do +-- > main = execClient "localhost" 5000 $ do -- > ret <- add 123 456 -- > liftIO $ print ret -- -------------------------------------------------------------------- -module Network.MessagePackRpc.Client ( +module Network.MessagePack.Client ( -- * MessagePack Client type Client, execClient, @@ -52,6 +52,7 @@ import Data.Conduit.Network import Data.Conduit.Serialization.Binary import Data.MessagePack import Data.Typeable +import System.IO newtype Client a = ClientT { runClient :: StateT Connection IO a } @@ -86,8 +87,8 @@ instance MessagePack o => RpcType (Client o) where rpcc m args = do res <- rpcCall m (reverse args) case fromObject res of - Just r -> return r - Nothing -> throwM $ ResultTypeError "type mismatch" + Success r -> return r + Error e -> throwM $ ResultTypeError e instance (MessagePack o, RpcType r) => RpcType (o -> r) where rpcc m args arg = rpcc m (toObject arg:args) @@ -95,24 +96,28 @@ instance (MessagePack o, RpcType r) => RpcType (o -> r) where rpcCall :: String -> [Object] -> Client Object rpcCall methodName args = ClientT $ do Connection rsrc sink msgid <- CMS.get - (rsrc', (rtype, rmsgid, rerror, rresult)) <- lift $ do + (rsrc', res) <- lift $ do CB.sourceLbs (pack (0 :: Int, msgid, methodName, args)) $$ sink rsrc $$++ sinkGet Binary.get CMS.put $ Connection rsrc' sink (msgid + 1) - when (rtype /= (1 :: Int)) $ - throwM $ ProtocolError $ - "invalid response type (expect 1, but got " ++ show rtype ++ ")" + case fromObject res of + Error e -> throwM $ ProtocolError e + Success (rtype, rmsgid, rerror, rresult) -> do - when (rmsgid /= msgid) $ - throwM $ ProtocolError $ - "message id mismatch: expect " - ++ show msgid ++ ", but got " - ++ show rmsgid + when (rtype /= (1 :: Int)) $ + throwM $ ProtocolError $ + "invalid response type (expect 1, but got " ++ show rtype ++ ")" - case fromObject rerror of - Nothing -> throwM $ ServerError rerror - Just () -> return rresult + when (rmsgid /= msgid) $ + throwM $ ProtocolError $ + "message id mismatch: expect " + ++ show msgid ++ ", but got " + ++ show rmsgid + + case fromObject rerror of + Error e -> throwM $ ServerError rerror + Success () -> return rresult -- | Call an RPC Method call :: RpcType a diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs new file mode 100644 index 0000000..f525e4d --- /dev/null +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +------------------------------------------------------------------- +-- | +-- Module : Network.MessagePackRpc.Server +-- Copyright : (c) Hideyuki Tanaka, 2010-2015 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- This module is server library of MessagePack-RPC. +-- The specification of MessagePack-RPC is at +-- . +-- +-- A simple example: +-- +-- > import Network.MessagePack.Server +-- > +-- > add :: Int -> Int -> Server Int +-- > add x y = return $ x + y +-- > +-- > main = serve 1234 [ method "add" add ] +-- +-------------------------------------------------------------------- + +module Network.MessagePack.Server ( + -- * RPC method types + Method, MethodType(..), + ServerT(..), Server, + -- * Build a method + method, + -- * Start RPC server + serve, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans +import Control.Monad.Trans.Control +import Data.Binary +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Network +import Data.Conduit.Serialization.Binary +import Data.List +import Data.MessagePack +import Data.Typeable + +-- ^ MessagePack RPC method +data Method m + = Method + { methodName :: String + , methodBody :: [Object] -> m Object + } + +type Request = (Int, Int, String, [Object]) +type Response = (Int, Int, Object, Object) + +data ServerError = ServerError String + deriving (Show, Typeable) + +instance Exception ServerError + +newtype ServerT m a = ServerT { runServerT :: m a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance MonadTrans ServerT where + lift = ServerT + +type Server = ServerT IO + +class Monad m => MethodType m f where + -- | Create a RPC method from a Hakell function + toBody :: f -> [Object] -> m Object + +instance (Functor m, MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where + toBody m ls = case ls of + [] -> toObject <$> runServerT m + _ -> throwM $ ServerError "argument number error" + +instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where + toBody f (x: xs) = + case fromObject x of + Error e -> throwM $ ServerError e + Success r -> toBody (f r) xs + +-- | Build a method +method :: MethodType m f + => String -- ^ Method name + -> f -- ^ Method body + -> Method m +method name body = Method name $ toBody body + +-- | Start RPC server with a set of RPC methods. +serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) + => Int -- ^ Port number + -> [Method m] -- ^ list of methods + -> m () +serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do + (rsrc, _) <- appSource ad $$+ return () + (_ :: Either ParseError ()) <- try $ processRequests rsrc (appSink ad) + return () + where + processRequests rsrc sink = do + (rsrc', res) <- rsrc $$++ do + obj <- sinkGet get + case fromObject obj of + Error e -> throwM $ ServerError e + Success req -> lift $ getResponse (req :: Request) + _ <- CB.sourceLbs (pack res) $$ sink + processRequests rsrc' sink + + getResponse (rtype, msgid, methodName, args) = do + when (rtype /= 0) $ + throwM $ ServerError $ "request type is not 0, got " ++ show rtype + ret <- callMethod methodName args + return ((1, msgid, toObject (), ret) :: Response) + + callMethod name args = + case find ((== name) . methodName) methods of + Nothing -> + throwM $ ServerError $ "method '" ++ name ++ "' not found" + Just m -> + methodBody m args diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs b/msgpack-rpc/src/Network/MessagePackRpc/Server.hs deleted file mode 100644 index 0f82607..0000000 --- a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -------------------------------------------------------------------- --- | --- Module : Network.MessagePackRpc.Server --- Copyright : (c) Hideyuki Tanaka, 2010-2015 --- License : BSD3 --- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- This module is server library of MessagePack-RPC. --- The specification of MessagePack-RPC is at --- . --- --- A simple example: --- --- > import Network.MessagePackRpc.Server --- > --- > add :: Int -> Int -> Method Int --- > add x y = return $ x + y --- > --- > main = serve 1234 [("add", toMethod add)] --- --------------------------------------------------------------------- - -module Network.MessagePackRpc.Server ( - -- * RPC method types - RpcMethod, MethodType(..), - Method(..), - -- * Start RPC server - serve, - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Trans -import Data.Binary -import Data.Conduit -import qualified Data.Conduit.Binary as CB -import Data.Conduit.Network -import Data.Conduit.Serialization.Binary -import Data.MessagePack -import Data.Typeable - -type RpcMethod = [Object] -> IO Object - -type Request = (Int, Int, String, [Object]) -type Response = (Int, Int, Object, Object) - -data ServerError = ServerError String - deriving (Show, Typeable) - -instance Exception ServerError - -newtype Method a = Method { runMethod :: IO a } - deriving (Functor, Applicative, Monad, MonadIO) - -class MethodType f where - -- | Create a RPC method from a Hakell function - toMethod :: f -> RpcMethod - -instance MessagePack o => MethodType (Method o) where - toMethod m ls = case ls of - [] -> toObject <$> runMethod m - _ -> throwM $ ServerError "argument number error" - -instance (MessagePack o, MethodType r) => MethodType (o -> r) where - toMethod f (x: xs) = - case fromObject x of - Nothing -> throwM $ ServerError "argument type error" - Just r -> toMethod (f r) xs - --- | Start RPC server with a set of RPC methods. -serve :: Int -- ^ Port number - -> [(String, RpcMethod)] -- ^ list of (method name, RPC method) - -> IO () -serve port methods = runTCPServer (serverSettings port "*") $ \ad -> do - (rsrc, _) <- appSource ad $$+ return () - processRequests rsrc (appSink ad) - where - processRequests rsrc sink = do - (rsrc', res) <- rsrc $$++ do - req <- sinkGet get - lift $ getResponse req - _ <- CB.sourceLbs (pack res) $$ sink - processRequests rsrc' sink - - getResponse :: Request -> IO Response - getResponse (rtype, msgid, methodName, args) = do - when (rtype /= 0) $ - throwM $ ServerError $ "request type is not 0, got " ++ show rtype - ret <- callMethod methodName args - return (1, msgid, toObject (), ret) - - callMethod :: String -> [Object] -> IO Object - callMethod methodName args = - case lookup methodName methods of - Nothing -> - throwM $ ServerError $ "method '" ++ methodName ++ "' not found" - Just method -> - method args diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/test.hs index 0dd5263..be4f51b 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -6,29 +6,29 @@ import Control.Monad.Trans import Test.Tasty import Test.Tasty.HUnit -import Network (withSocketsDo) -import Network.MessagePackRpc.Client -import Network.MessagePackRpc.Server +import Network.MessagePack.Client +import Network.MessagePack.Server +import Network.Socket (withSocketsDo) port :: Int port = 5000 main :: IO () main = withSocketsDo $ defaultMain $ - testGroup "add service" - [ testCase "correct" $ server `race_` (threadDelay 1000 >> client) ] + testGroup "simple service" + [ testCase "test" $ server `race_` (threadDelay 1000 >> client) ] server :: IO () server = serve port - [ ("add", toMethod add) - , ("echo", toMethod echo) + [ method "add" add + , method "echo" echo ] where - add :: Int -> Int -> Method Int + add :: Int -> Int -> Server Int add x y = return $ x + y - echo :: String -> Method String + echo :: String -> Server String echo s = return $ "***" ++ s ++ "***" client :: IO () diff --git a/msgpack/CHANGES.md b/msgpack/CHANGES.md new file mode 100644 index 0000000..a10162e --- /dev/null +++ b/msgpack/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/msgpack/LICENSE b/msgpack/LICENSE index 3cb4d8c..bc3373f 100644 --- a/msgpack/LICENSE +++ b/msgpack/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 @@ modification, are permitted provided that the following conditions are met: 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/msgpack/Setup.hs b/msgpack/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/msgpack/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/msgpack/Setup.lhs b/msgpack/Setup.lhs deleted file mode 100644 index 5bde0de..0000000 --- a/msgpack/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 888dde9..9283e9e 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -1,44 +1,99 @@ +cabal-version: 1.12 name: msgpack -version: 0.8.0.0 +version: 1.1.0.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.18 build-type: Simple +extra-source-files: + CHANGES.md + test/data/README.md + test/data/10.nil.yaml + test/data/11.bool.yaml + test/data/12.binary.yaml + test/data/20.number-positive.yaml + test/data/21.number-negative.yaml + test/data/22.number-float.yaml + test/data/23.number-bignum.yaml + test/data/30.string-ascii.yaml + test/data/31.string-utf8.yaml + test/data/32.string-emoji.yaml + test/data/40.array.yaml + test/data/41.map.yaml + test/data/42.nested.yaml + test/data/50.timestamp.yaml + test/data/60.ext.yaml + 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 Data.MessagePack.Assoc + Data.MessagePack.Generic + Data.MessagePack.Integer + Data.MessagePack.Timestamp Data.MessagePack.Object 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 + other-modules: Data.MessagePack.Tags + Data.MessagePack.Result + Data.MessagePack.Get.Internal + Compat.Binary + Compat.Prelude + + build-depends: base >= 4.7 && < 4.14 + , mtl >= 2.2.1 && < 2.3 + , bytestring >= 0.10.4 && < 0.11 + , text >= 1.2.3 && < 1.3 + , containers >= 0.5.5 && < 0.7 + , unordered-containers >= 0.2.5 && < 0.3 + , hashable >= 1.1.2.4 && < 1.4 + , vector >= 0.10.11 && < 0.13 + , deepseq >= 1.3 && < 1.5 + , binary >= 0.7.1 && < 0.9 + , semigroups >= 0.5.0 && < 0.20 + , time >= 1.4.2 && < 1.10 + , int-cast >= 0.1.1 && < 0.3 + , array >= 0.5.0 && < 0.6 + + if !impl(ghc > 8.0) + build-depends: fail == 4.9.* + + ghc-options: -Wall + + if impl(ghc >= 7.10) + ghc-options: -fno-warn-trustworthy-safe + test-suite msgpack-tests type: exitcode-stdio-1.0 @@ -46,10 +101,24 @@ test-suite msgpack-tests hs-source-dirs: test main-is: test.hs + other-modules: Properties + DataCases + + ghc-options: -Wall - build-depends: base + build-depends: msgpack + -- inherited constraints via `msgpack` + , base + , binary , bytestring - , QuickCheck >= 2.8 - , tasty >= 0.10 - , tasty-quickcheck >= 0.8 - , msgpack + , containers + , text + , time + -- test-specific dependencies + , async == 2.2.* + , filepath == 1.3.* || == 1.4.* + , HsYAML >= 0.1.1 && < 0.2 + , tasty == 1.2.* + , tasty-quickcheck == 0.10.* + , tasty-hunit == 0.10.* + , QuickCheck == 2.13.* diff --git a/msgpack/src/Compat/Binary.hs b/msgpack/src/Compat/Binary.hs new file mode 100644 index 0000000..eb2f983 --- /dev/null +++ b/msgpack/src/Compat/Binary.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Compat layer for "Data.Binary" +-- +-- Supports @binary-0.7.1@ and later +module Compat.Binary + ( Binary(put, get) + + , runPut', Bin.runPut, Bin.PutM, Put + , runGet', runGet, Get + + , Bin.getWord64be, Bin.putWord64be + , Bin.getWord32be, Bin.putWord32be + , Bin.getWord16be, Bin.putWord16be + , Bin.getWord8 , Bin.putWord8 + + , getInt64be, putInt64be + , getInt32be, putInt32be + , getInt16be, putInt16be + , getInt8 , putInt8 + + , getFloat32be, putFloat32be + , getFloat64be, putFloat64be + + , Bin.getByteString, Bin.putByteString + ) where + +import Compat.Prelude + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +import Data.Array.ST (MArray, STUArray, newArray, readArray) +import Data.Array.Unsafe (castSTUArray) +import Data.Binary (Binary (get, put), Get, Put) +import qualified Data.Binary.Get as Bin +import qualified Data.Binary.Put as Bin +import GHC.ST (ST, runST) + + +runGet' :: BS.ByteString -> Get a -> Either String a +runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of + Bin.Done bs ofs x + | BS.null bs -> Right x + | otherwise -> Left ("unexpected trailing data (ofs="++show ofs++")") + Bin.Partial _ -> Left "truncated data" + Bin.Fail _ ofs e -> Left (e ++ " (ofs=" ++ show ofs ++ ")") + +runPut' :: Put -> BS.ByteString +runPut' = BL.toStrict . Bin.runPut + +runGet :: BL.ByteString -> Get a -> Either String a +runGet bs0 g = case Bin.runGetOrFail g bs0 of + Left (_,ofs,e) -> Left (e ++ " (ofs=" ++ show ofs ++ ")") + Right (bs,ofs,x) + | BL.null bs -> Right x + | otherwise -> Left ("unexpected trailing data (ofs="++show ofs++")") + +-- NB: once we drop support for binary < 0.8.1 we can drop the ops below + +{-# INLINE getInt8 #-} +getInt8 :: Get Int8 +getInt8 = intCastIso <$> Bin.getWord8 + +{-# INLINE getInt16be #-} +getInt16be :: Get Int16 +getInt16be = intCastIso <$> Bin.getWord16be + +{-# INLINE getInt32be #-} +getInt32be :: Get Int32 +getInt32be = intCastIso <$> Bin.getWord32be + +{-# INLINE getInt64be #-} +getInt64be :: Get Int64 +getInt64be = intCastIso <$> Bin.getWord64be + +{-# INLINE putInt8 #-} +putInt8 :: Int8 -> Put +putInt8 x = Bin.putWord8 (intCastIso x) + +{-# INLINE putInt16be #-} +putInt16be :: Int16 -> Put +putInt16be x = Bin.putWord16be (intCastIso x) + +{-# INLINE putInt32be #-} +putInt32be :: Int32 -> Put +putInt32be x = Bin.putWord32be (intCastIso x) + +{-# INLINE putInt64be #-} +putInt64be :: Int64 -> Put +putInt64be x = Bin.putWord64be (intCastIso x) + +-- NB: Once we drop support for binary < 0.8.4 we can use @binary@'s own {get,put}{Double,Float}be operations + +putFloat32be :: Float -> Put +putFloat32be x = Bin.putWord32be (runST (cast x)) + +putFloat64be :: Double -> Put +putFloat64be x = Bin.putWord64be (runST (cast x)) + +getFloat32be :: Get Float +getFloat32be = do + x <- Bin.getWord32be + return (runST (cast x)) + +getFloat64be :: Get Double +getFloat64be = do + x <- Bin.getWord64be + return (runST (cast x)) + +-- See https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa/7002812#7002812 + +{-# INLINE cast #-} +cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b +cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 diff --git a/msgpack/src/Compat/Prelude.hs b/msgpack/src/Compat/Prelude.hs new file mode 100644 index 0000000..e6607c5 --- /dev/null +++ b/msgpack/src/Compat/Prelude.hs @@ -0,0 +1,17 @@ +-- | Common Prelude-ish module +module Compat.Prelude + ( module X + ) where + +import Control.Applicative as X +import Control.DeepSeq as X (NFData (rnf)) +import Control.Monad as X +import Data.Bits as X (complement, shiftL, shiftR, (.&.), + (.|.)) +import Data.Foldable as X (Foldable) +import Data.Int as X +import Data.IntCast as X +import Data.Traversable as X (Traversable) +import Data.Typeable as X (Typeable) +import Data.Word as X +import GHC.Generics as X (Generic) diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index 6140698..416ed00 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -1,34 +1,66 @@ -------------------------------------------------------------------- -- | -- 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. -- -------------------------------------------------------------------- module Data.MessagePack ( - module X, - -- * Simple interface to pack and unpack msgpack binary + -- ** Lazy 'L.ByteString' pack, unpack, + + -- ** Strict 'L.ByteString' + pack', unpack', + + -- * Re-export modules + module Data.MessagePack.Assoc, + module Data.MessagePack.Get, + module Data.MessagePack.Object, + module Data.MessagePack.Put, ) where -import Data.Binary +import Compat.Binary (get, runGet, runGet', runPut, runPut') +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.MessagePack.Assoc as X -import Data.MessagePack.Get as X -import Data.MessagePack.Object as X -import Data.MessagePack.Put as X +import Data.MessagePack.Assoc +import Data.MessagePack.Get +import Data.MessagePack.Object +import Data.MessagePack.Put +-- | Pack a Haskell value to MessagePack binary. pack :: MessagePack a => a -> L.ByteString -pack = encode . toObject +pack = runPut . toBinary + +-- | Unpack MessagePack binary to a Haskell value. If it fails, it returns 'Left' with an error message. +-- +-- @since 1.1.0.0 +unpack :: MessagePack a => L.ByteString -> Either String a +unpack bs = do + obj <- runGet bs get + case fromObject obj of + Success a -> Right a + Error e -> Left e -unpack :: MessagePack a => L.ByteString -> Maybe a -unpack = fromObject . decode + +-- | Variant of 'pack' serializing to a strict 'ByteString' +-- +-- @since 1.1.0.0 +pack' :: MessagePack a => a -> S.ByteString +pack' = runPut' . toBinary + +-- | Variant of 'unpack' serializing to a strict 'ByteString' +-- +-- @since 1.1.0.0 +unpack' :: MessagePack a => S.ByteString -> Either String a +unpack' bs = do + obj <- runGet' bs get + case fromObject obj of + Success a -> Right a + Error e -> Left e diff --git a/msgpack/src/Data/MessagePack/Assoc.hs b/msgpack/src/Data/MessagePack/Assoc.hs index 53f30c4..0146b71 100644 --- a/msgpack/src/Data/MessagePack/Assoc.hs +++ b/msgpack/src/Data/MessagePack/Assoc.hs @@ -19,11 +19,10 @@ module Data.MessagePack.Assoc ( Assoc(..) ) where -import Control.DeepSeq -import Data.Typeable +import Compat.Prelude -- 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, Eq, Ord, Typeable, NFData) + deriving (Show, Read, Eq, Ord, Typeable, NFData) diff --git a/msgpack/src/Data/MessagePack/Derive.hs b/msgpack/src/Data/MessagePack/Derive.hs deleted file mode 100644 index fca73b8..0000000 --- a/msgpack/src/Data/MessagePack/Derive.hs +++ /dev/null @@ -1,145 +0,0 @@ -module Data.MessagePack.Derive () where - -{- -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.MessagePack.Derive ( - -- | deriving OBJECT - derivePack, - deriveUnpack, - deriveObject, - ) where - -import Control.Monad -import Control.Monad.Except () -import Data.Char -import Data.List -import qualified Data.Text as T -import Language.Haskell.TH - -import Data.MessagePack.Assoc -import Data.MessagePack.Object -import Data.MessagePack.Pack -import Data.MessagePack.Unpack - -derivePack :: Bool -> Name -> Q [Dec] -derivePack asObject tyName = do - info <- reify tyName - d <- case info of - TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> - instanceD (cx tyVars) (ct ''Packable name tyVars) $ - [ funD 'from [ clause [] (normalB [e| \v -> $(caseE [| v |] (map alt cons)) |]) []] - ] - - _ -> error $ "cant derive Packable: " ++ show tyName - return [d] - - where - alt (NormalC conName elms) = do - vars <- replicateM (length elms) (newName "v") - match (conP conName $ map varP vars) - (normalB [| from $(tupE $ map varE vars) |]) - [] - - alt (RecC conName elms) = do - vars <- replicateM (length elms) (newName "v") - if asObject - then - match (conP conName $ map varP vars) - (normalB - [| from $ Assoc - $(listE [ [| ( $(return $ LitE $ StringL $ key conName fname) :: T.Text - , toObject $(varE v)) |] - | (v, (fname, _, _)) <- zip vars elms]) - |]) - [] - else - match (conP conName $ map varP vars) - (normalB [| from $(tupE $ map varE vars) |]) - [] - - alt c = error $ "unsupported constructor: " ++ pprint c - -deriveUnpack :: Bool -> Name -> Q [Dec] -deriveUnpack asObject tyName = do - info <- reify tyName - d <- case info of - TyConI (DataD _ {- cxt -} name tyVars cons _ {- derivings -}) -> - instanceD (cx tyVars) (ct ''Unpackable name tyVars) $ - [ funD 'get [ clause [] (normalB (foldl1 (\x y -> [| $x `mplus` $y |]) $ map alt cons)) []] - ] - - _ -> error $ "cant derive Unpackable: " ++ show tyName - return [d] - - where - alt (NormalC conName elms) = do - vars <- replicateM (length elms) (newName "v") - doE [ bindS (tupP $ map varP vars) [| get |] - , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] - ] - - alt (RecC conName elms) = do - var <- newName "v" - vars <- replicateM (length elms) (newName "w") - if asObject - then - doE $ [ bindS (conP 'Assoc [varP var]) [| get |] ] - ++ zipWith (binds conName var) vars elms ++ - [ noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] ] - else - doE [ bindS (tupP $ map varP vars) [| get |] - , noBindS [| return $(foldl appE (conE conName) $ map varE vars) |] - ] - - alt c = error $ "unsupported constructor: " ++ pprint c - - binds conName var res (fname, _, _) = - bindS (varP res) - [| failN $ lookup ($(return $ LitE $ StringL $ key conName fname) :: T.Text) - $(varE var) |] - -deriveObject :: Bool -> Name -> Q [Dec] -deriveObject asObject tyName = do - g <- derivePack asObject tyName - p <- deriveUnpack asObject tyName - info <- reify tyName - o <- case info of - TyConI (DataD _ {- cxt -} name tyVars _ _ {- derivings -}) -> - -- use default implement - instanceD (cx tyVars) (ct ''OBJECT name tyVars) [] - _ -> error $ "cant derive Object: " ++ show tyName - return $ g ++ p ++ [o] - -failN :: (MonadPlus m, OBJECT a) => Maybe Object -> m a -failN Nothing = mzero -failN (Just a) = - case tryFromObject a of - Left _ -> mzero - Right v -> return v - -cx :: [TyVarBndr] -> CxtQ -cx tyVars = - cxt [ classP cl [varT tv] - | cl <- [''Packable, ''Unpackable, ''OBJECT] - , PlainTV tv <- tyVars ] - -ct :: Name -> Name -> [TyVarBndr] -> TypeQ -ct tc tyName tyVars = - appT (conT tc) $ foldl appT (conT tyName) $ - map (\(PlainTV n) -> varT n) tyVars - -key :: Name -> Name -> [Char] -key conName fname - | (prefix ++ "_") `isPrefixOf` sFname && length sFname > length prefix + 1 = - drop (length prefix + 1) sFname - | prefix `isPrefixOf` sFname && length sFname > length prefix = - uncapital $ drop (length prefix) sFname - | otherwise = sFname - where - prefix = map toLower $ nameBase conName - sFname = nameBase fname - uncapital (c:cs) | isUpper c = toLower c : cs - uncapital cs = cs --} diff --git a/msgpack/src/Data/MessagePack/Generic.hs b/msgpack/src/Data/MessagePack/Generic.hs new file mode 100644 index 0000000..78fa432 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Generic.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.MessagePack.Generic + ( GMessagePack + , genericToObject + , genericFromObject + , GenericMsgPack(..) + ) where + +import Compat.Prelude + +import GHC.Generics + +import Data.MessagePack.Object + +genericToObject :: (Generic a, GMessagePack (Rep a)) => a -> Object +genericToObject = gToObject . from + +genericFromObject :: (Generic a, GMessagePack (Rep a)) => Object -> Result a +genericFromObject x = to <$> gFromObject x + +newtype GenericMsgPack a = GenericMsgPack a + +instance (Generic a, GMessagePack (Rep a)) => MessagePack (GenericMsgPack a) where + toObject (GenericMsgPack a) = genericToObject a + fromObject a = GenericMsgPack <$> genericFromObject a + +class GMessagePack f where + gToObject :: f a -> Object + gFromObject :: Object -> Result (f a) + +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 :: [Object] -> Result (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 :: GSumPack f => Word64 -> Word64 -> Result (f a) +checkSumFromObject0 size code + | code < size = sumFromObject code size ObjectNil + | otherwise = fail "invalid encoding for sum type" + + +checkSumFromObject :: (GSumPack f) => Word64 -> Word64 -> Object -> Result (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 :: Word64 -> Word64 -> Object -> Result (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 {-# OVERLAPPING #-} GSumPack (C1 c U1) where + sumToObject code _ _ = toObject code + sumFromObject _ _ = gFromObject + + +instance {-# OVERLAPPABLE #-} 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/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 8b8d735..73a0b6d 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -1,108 +1,73 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} -------------------------------------------------------------------- -- | -- 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, - getRAW, getArray, getMap, - ) where - -import Control.Applicative -import Control.Monad -import Data.Binary -import Data.Binary.Get -import Data.Binary.IEEE754 -import Data.Bits -import qualified Data.ByteString as S -import Data.Int -import qualified Data.Vector as V - -getNil :: Get () -getNil = tag 0xC0 +module Data.MessagePack.Get + ( getNil + , getBool -getBool :: Get Bool -getBool = - False <$ tag 0xC2 <|> - True <$ tag 0xC3 + , getFloat + , getDouble -getInt :: Get Int -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 + , getInt + , getWord + , getInt64 + , getWord64 -getDouble :: Get Double -getDouble = tag 0xCB >> getFloat64be + , getStr + , getBin -getRAW :: Get S.ByteString -getRAW = do - len <- getWord8 >>= \case - t | t .&. 0xE0 == 0xA0 -> - return $ fromIntegral $ t .&. 0x1F - 0xDA -> fromIntegral <$> getWord16be - 0xDB -> fromIntegral <$> getWord32be - _ -> empty - getByteString len + , getArray + , getMap -getArray :: Get a -> Get (V.Vector a) -getArray g = do - len <- getWord8 >>= \case - t | t .&. 0xF0 == 0x90 -> - return $ fromIntegral $ t .&. 0x0F - 0xDC -> fromIntegral <$> getWord16be - 0xDD -> fromIntegral <$> getWord32be - _ -> empty - V.replicateM len g + , getExt + , getExt' + ) where -getMap :: Get a -> Get b -> Get (V.Vector (a, b)) -getMap k v = do - len <- getWord8 >>= \case - t | t .&. 0xF0 == 0x80 -> - return $ fromIntegral $ t .&. 0x0F - 0xDE -> fromIntegral <$> getWord16be - 0xDF -> fromIntegral <$> getWord32be - _ -> empty - V.replicateM len $ (,) <$> k <*> v +import Compat.Binary +import Compat.Prelude +import Data.MessagePack.Get.Internal +import Data.MessagePack.Integer -getInt8 :: Get Int8 -getInt8 = fromIntegral <$> getWord8 +-- | Deserialize an integer into an 'Int' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int' type. +-- +-- @since 1.1.0.0 +getInt :: Get Int +getInt = maybe empty pure =<< fromMPInteger <$> get -getInt16be :: Get Int16 -getInt16be = fromIntegral <$> getWord16be +-- | 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 = maybe empty pure =<< fromMPInteger <$> get -getInt32be :: Get Int32 -getInt32be = fromIntegral <$> getWord32be +-- | 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 = maybe empty pure =<< fromMPInteger <$> get -getInt64be :: Get Int64 -getInt64be = fromIntegral <$> getWord64be +-- | 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 = maybe empty pure =<< fromMPInteger <$> get -tag :: Word8 -> Get () -tag t = do - b <- getWord8 - guard $ t == b diff --git a/msgpack/src/Data/MessagePack/Get/Internal.hs b/msgpack/src/Data/MessagePack/Get/Internal.hs new file mode 100644 index 0000000..59fe1ee --- /dev/null +++ b/msgpack/src/Data/MessagePack/Get/Internal.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Get +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 +-- License : BSD3 +-- +-- MessagePack Deserializer using "Data.Binary" +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Get.Internal + ( getNil, tryNil + , getBool, tryBool + + , getFloat, tryFloat + , getDouble, tryDouble + + , getStr, tryStr + , getBin, tryBin + + , getArray, tryArray + , getMap, tryMap + + , getExt, tryExt + , getExt', tryExt' + ) where + +import Compat.Prelude + +import qualified Data.ByteString as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V + +import Compat.Binary +import Data.MessagePack.Tags + +mkGet :: (Word8 -> t -> Get a -> Get b) -> t -> String -> Get b +mkGet tryT f n = do { tag <- getWord8; tryT tag f empty } <|> fail n + +getNil :: Get () +getNil = mkGet tryNil id "expected MessagePack nil" + +getBool :: Get Bool +getBool = mkGet tryBool id "expected MessagePack bool" + +getFloat :: Get Float +getFloat = mkGet tryFloat id "expected MessagePack float32" + +getDouble :: Get Double +getDouble = mkGet tryDouble id "expected MessagePack float64" + +getStr :: Get T.Text +getStr = mkGet tryStr id "expected MessagePack str" + +getBin :: Get S.ByteString +getBin = mkGet tryBin id "expected MessagePack bin" + +getArray :: Get a -> Get (V.Vector a) +getArray g = mkGet (tryArray g) id "expected MessagePack array" + +getMap :: Get a -> Get b -> Get (V.Vector (a, b)) +getMap k v = mkGet (tryMap k v) id "Map" + +getExt :: Get (Int8, S.ByteString) +getExt = mkGet tryExt id "expected MessagePack ext" + +-- | @since 1.1.0.0 +getExt' :: (Int8 -> Word32 -> Get a) -> Get a +getExt' getdat = mkGet (tryExt' getdat) id "expected MessagePack ext" + +---------------------------------------------------------------------------- +-- primitives that take a tag as first argument + +{-# INLINE tryNil #-} +tryNil :: Word8 -> (() -> a) -> Get a -> Get a +tryNil tag f cont = case tag of + TAG_nil -> pure $! f () + _ -> cont + +{-# INLINE tryBool #-} +tryBool :: Word8 -> (Bool -> a) -> Get a -> Get a +tryBool tag f cont = case tag of + TAG_false -> pure $! f False + TAG_true -> pure $! f True + _ -> cont + +{-# INLINE tryFloat #-} +tryFloat :: Word8 -> (Float -> a) -> Get a -> Get a +tryFloat tag f cont = case tag of + TAG_float32 -> f <$> getFloat32be + _ -> cont + +{-# INLINE tryDouble #-} +tryDouble :: Word8 -> (Double -> a) -> Get a -> Get a +tryDouble tag f cont = case tag of + TAG_float64 -> f <$> getFloat64be + _ -> cont + +{-# INLINE tryStr #-} +tryStr :: Word8 -> (T.Text -> a) -> Get a -> Get a +tryStr tag f cont = case tag of + t | Just sz <- is_TAG_fixstr t -> cont' sz + TAG_str8 -> cont' . intCast =<< getWord8 + TAG_str16 -> cont' . intCast =<< getWord16be + TAG_str32 -> cont' =<< getWord32be + _ -> cont + where + cont' len = do + len' <- fromSizeM "getStr: data exceeds capacity of ByteString/Text" len + bs <- getByteString len' + case T.decodeUtf8' bs of + Left _ -> fail "getStr: invalid UTF-8 encoding" + Right v -> pure $! f v + +{-# INLINE tryBin #-} +tryBin :: Word8 -> (S.ByteString -> a) -> Get a -> Get a +tryBin tag f cont = case tag of + TAG_bin8 -> cont' . intCast =<< getWord8 + TAG_bin16 -> cont' . intCast =<< getWord16be + TAG_bin32 -> cont' =<< getWord32be + _ -> cont + where + cont' len = do + len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len + f <$> getByteString len' + +{-# INLINE tryArray #-} +tryArray :: Get b -> Word8 -> (V.Vector b -> a) -> Get a -> Get a +tryArray g tag f cont = case tag of + t | Just sz <- is_TAG_fixarray t -> cont' sz + TAG_array16 -> cont' . intCast =<< getWord16be + TAG_array32 -> cont' =<< getWord32be + _ -> cont + where + cont' len = do + len' <- fromSizeM "getArray: data exceeds capacity of Vector" len + f <$> V.replicateM len' g + +{-# INLINE tryMap #-} +tryMap :: Get k -> Get v -> Word8 -> (V.Vector (k,v) -> a) -> Get a -> Get a +tryMap k v tag f cont = case tag of + t | Just sz <- is_TAG_fixmap t -> cont' sz + TAG_map16 -> cont' . intCast =<< getWord16be + TAG_map32 -> cont' =<< getWord32be + _ -> cont + where + cont' len = do + len' <- fromSizeM "getMap: data exceeds capacity of Vector" len + f <$> V.replicateM len' ((,) <$> k <*> v) + +{-# INLINE tryExt #-} +tryExt :: Word8 -> ((Int8,S.ByteString) -> a) -> Get a -> Get a +tryExt tag f cont = tryExt' go tag f cont + where + go :: Int8 -> Word32 -> Get (Int8,S.ByteString) + go typ len = do + len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len + (,) typ <$> getByteString len' + + +{-# INLINE tryExt' #-} +tryExt' :: (Int8 -> Word32 -> Get b) -> Word8 -> (b -> a) -> Get a -> Get a +tryExt' g tag f cont = case tag of + TAG_fixext1 -> cont' 1 + TAG_fixext2 -> cont' 2 + TAG_fixext4 -> cont' 4 + TAG_fixext8 -> cont' 8 + TAG_fixext16 -> cont' 16 + TAG_ext8 -> cont' . intCast =<< getWord8 + TAG_ext16 -> cont' . intCast =<< getWord16be + TAG_ext32 -> cont' =<< getWord32be + _ -> cont + + where + cont' len = do + typ <- getInt8 + f <$> g typ len + + +fromSizeM :: String -> Word32 -> Get Int +fromSizeM label sz = maybe (fail label) pure (intCastMaybe sz) diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs new file mode 100644 index 0000000..dc5d308 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Data.MessagePack.Integer +-- Copyright : © Herbert Valerio Riedel 2019 +-- License : BSD3 +-- +-- Type representing MessagePack integers +-- +module Data.MessagePack.Integer + ( MPInteger + , ToMPInteger(..) + , FromMPInteger(..) + , fromIntegerTry + + -- ** Internal helper + , tryMPInteger + ) where + +import Compat.Prelude + +import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), + throw) + +import Compat.Binary +import Data.MessagePack.Tags + +-- | Integer type that represents the value range of integral numbers in MessagePack; i.e. \( \left[ -2^{63}, 2^{64}-1 \right] \). +-- In other words, `MPInteger` provides the union of the value ranges of `Word64` and `Int64`. +-- +-- This type can be unboxed (i.e. via @{-# UNPACK #-}@). +data MPInteger = MPInteger {- isW64 -} !Bool + {- value -} {-# UNPACK #-} !Int64 + deriving (Eq,Ord,Typeable) + +-- NOTE: Internal invariant of 'MPInteger' +-- +-- 'isW64' MUST be true IFF the value range of `Int64` cannot represent the semantic value of 'value' +-- +-- Consequently, when 'isW64' is true, 'value :: Int64' must be negative. + +-- NB: only valid if isW64 is true +toW64 :: Int64 -> Word64 +toW64 = intCastIso + +class ToMPInteger a where + toMPInteger :: a -> MPInteger + +instance ToMPInteger Int8 where toMPInteger i = MPInteger False (intCast i) +instance ToMPInteger Int16 where toMPInteger i = MPInteger False (intCast i) +instance ToMPInteger Int32 where toMPInteger i = MPInteger False (intCast i) +instance ToMPInteger Int64 where toMPInteger = MPInteger False +instance ToMPInteger Int where toMPInteger i = MPInteger False (intCast i) + +instance ToMPInteger Word8 where toMPInteger w = MPInteger False (intCast w) +instance ToMPInteger Word16 where toMPInteger w = MPInteger False (intCast w) +instance ToMPInteger Word32 where toMPInteger w = MPInteger False (intCast w) +instance ToMPInteger Word64 where toMPInteger w = MPInteger (i<0) i where i = fromIntegral w +instance ToMPInteger Word where toMPInteger w = MPInteger (i<0) i where i = fromIntegral w + +-- | Convert a 'MPInteger' value to something else if possible +-- +-- The instances for 'FromMPInteger' are supposed to be consistent with the respective instances for 'ToMPInteger', e.g. +-- +-- > fromMPInteger . toMPInteger == Just +-- +class FromMPInteger a where + fromMPInteger :: MPInteger -> Maybe a + +instance FromMPInteger Word where + fromMPInteger (MPInteger True w) = intCastMaybe (toW64 w) + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Word64 where + fromMPInteger (MPInteger True w) = Just $! toW64 w + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Word32 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Word16 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Word8 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +----- + +instance FromMPInteger Int where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Int64 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = Just i + +instance FromMPInteger Int32 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Int16 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +instance FromMPInteger Int8 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = intCastMaybe i + +---------------------------------------------------------------------------- + +instance Bounded MPInteger where + minBound = MPInteger False minBound + maxBound = MPInteger True (-1) -- this is why we can't autoderive + +instance Enum MPInteger where + toEnum i = MPInteger False (toEnum i) + fromEnum (MPInteger True i) = fromEnum (toW64 i) + fromEnum (MPInteger False i) = fromEnum i + +instance Show MPInteger where + showsPrec p (MPInteger False v) = showsPrec p v + showsPrec p (MPInteger True v) = showsPrec p (toW64 v) + +instance Read MPInteger where + readsPrec p s = [ (i, rest) | (j, rest) <- readsPrec p s, Right i <- [fromIntegerTry j] ] + +instance NFData MPInteger where + rnf (MPInteger _ _) = () + +-- | Try to convert 'Integer' into 'MPInteger' +-- +-- Will return @'Left' 'Underflow'@ or @'Left' 'Overflow'@ respectively if out of range +fromIntegerTry :: Integer -> Either ArithException MPInteger +fromIntegerTry i + | i < toInteger (minBound :: Int64) = Left Underflow + | i <= toInteger (maxBound :: Int64) = Right $! MPInteger False (fromInteger i) + | i <= toInteger (maxBound :: Word64) = Right $! MPInteger True (fromInteger i) + | otherwise = Left Overflow + +-- | This instance will throw the respective arithmetic 'Underflow' and 'Overflow' exception if the range of 'MPInteger' is exceeded. +instance Num MPInteger where + fromInteger i = either throw id (fromIntegerTry i) + + negate (MPInteger False v) + | v == minBound = MPInteger True v -- NB: for the usual twos complement integers, `negate minBound == minBound` + | otherwise = MPInteger False (negate v) + negate (MPInteger True v) + | v == minBound = MPInteger False v + | otherwise = throw Underflow + + -- addition + MPInteger False 0 + x = x + x + MPInteger False 0 = x + + MPInteger True _ + MPInteger True _ = throw Overflow + + x@(MPInteger True _) + y@(MPInteger False _) = y + x + MPInteger False y + MPInteger True x + | y > 0 = if z<0 then MPInteger True z else throw Overflow + | otherwise = MPInteger (z<0) z + where + z = x+y + + MPInteger False y + MPInteger False x + | x > 0, y > 0, z < 0 = MPInteger True z + | x < 0, y < 0, z > 0 = throw Underflow + | otherwise = MPInteger False z + where + z = x+y + + signum (MPInteger True _) = MPInteger False 1 + signum (MPInteger False v) = MPInteger False (signum v) + + abs v@(MPInteger True _) = v + abs v0@(MPInteger False v) + | v >= 0 = v0 + | v == minBound = MPInteger True v + | otherwise = MPInteger False (negate v) + + + MPInteger True _ * MPInteger True _ = throw Overflow + MPInteger False 0 * MPInteger _ _ = MPInteger False 0 + MPInteger False 1 * x = x + MPInteger _ _ * MPInteger False 0 = MPInteger False 0 + x * MPInteger False 1 = x + + -- cheat + x * y = fromInteger (toInteger x * toInteger y) + +instance Real MPInteger where + toRational (MPInteger False i) = toRational i + toRational (MPInteger True u) = toRational (toW64 u) + +instance Integral MPInteger where + toInteger (MPInteger False i) = toInteger i + toInteger (MPInteger True u) = toInteger (toW64 u) + + quotRem _ (MPInteger False 0) = throw DivideByZero + quotRem x (MPInteger False 1) = (x, MPInteger False 0) + quotRem x (MPInteger False (-1)) = (negate x, MPInteger False 0) + + quotRem (MPInteger False x) (MPInteger False y) + | (x',y') <- quotRem x y = (MPInteger False x', MPInteger False y') + + -- cheat + quotRem x y + | (x',y') <- quotRem (toInteger x) (toInteger y) = (fromInteger x', fromInteger y') + +---------------------------------------------------------------------------- + +-- | This 'Binary' instance encodes\/decodes to\/from MessagePack format +-- +-- When serializing 'MPInteger's via 'get' the shortest encoding is +-- used. Moreoever, for non-negative integers the unsigned encoding is +-- always used. +-- +-- Deserialization via 'get' will only fail if a non-integer MessagePack tag is encountered. +-- +instance Binary MPInteger where + get = getMPInteger + put = putMPInteger + +-- | Serializes 'MPInteger' to MessagePack +-- +-- The shortest encoding is used to serialize +-- 'MPInteger's. Moreoever, for non-negative integers the unsigned +-- encoding is always used. +putMPInteger :: MPInteger -> Put +putMPInteger (MPInteger False i) + -- positive fixnum stores 7-bit positive integer + -- negative fixnum stores 5-bit negative integer + | -32 <= i && i <= 127 = putInt8 (fromIntegral i) + + -- unsigned int encoding + | i >= 0 = case () of + _ | i < 0x100 -> putWord8 TAG_uint8 >> putWord8 (fromIntegral i) + | i < 0x10000 -> putWord8 TAG_uint16 >> putWord16be (fromIntegral i) + | i < 0x100000000 -> putWord8 TAG_uint32 >> putWord32be (fromIntegral i) + | otherwise -> putWord8 TAG_uint64 >> putWord64be (intCastIso i) -- equivalent to 'putInt64be i' + + -- signed int encoding + | -0x80 <= i = putWord8 TAG_int8 >> putInt8 (fromIntegral i) + | -0x8000 <= i = putWord8 TAG_int16 >> putInt16be (fromIntegral i) + | -0x80000000 <= i = putWord8 TAG_int32 >> putInt32be (fromIntegral i) + | otherwise = putWord8 TAG_int64 >> putInt64be i +putMPInteger (MPInteger True w) = putWord8 TAG_uint64 >> putWord64be (toW64 w) + +-- | Deserializes 'MPInteger' from MessagePack +-- +-- This operation will only fail if a non-integer MessagePack tag is encountered. +getMPInteger :: Get MPInteger +getMPInteger = do { tag <- getWord8; tryMPInteger tag id empty } <|> fail "expected MessagePack int" + +-- | @since 1.1.0.0 +{-# INLINE tryMPInteger #-} +tryMPInteger :: Word8 -> (MPInteger -> a) -> Get a -> Get a +tryMPInteger tag' f cont = case tag' of + -- positive fixnum stores 7-bit positive integer + -- negative fixnum stores 5-bit negative integer + c | is_TAG_fixint c -> pure $! f $! toMPInteger (intCastIso c :: Int8) + TAG_int8 -> f . toMPInteger <$> getInt8 + TAG_int16 -> f . toMPInteger <$> getInt16be + TAG_int32 -> f . toMPInteger <$> getInt32be + TAG_int64 -> f . toMPInteger <$> getInt64be + TAG_uint8 -> f . toMPInteger <$> getWord8 + TAG_uint16 -> f . toMPInteger <$> getWord16be + TAG_uint32 -> f . toMPInteger <$> getWord32be + TAG_uint64 -> f . toMPInteger <$> getWord64be + _ -> cont diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 13c2037..311bf74 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -1,66 +1,116 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------- -- | -- 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 -- -------------------------------------------------------------------- -module Data.MessagePack.Object( +module Data.MessagePack.Object ( -- * MessagePack Object Object(..), + -- * MessagePack conveniences + (.:), (.=), + + withNil, withBool, withInt, + withFloat, withDouble, withBin, withStr, + withArray, withMap, + -- * MessagePack Serializable Types - MessagePack(..), + MessagePack(..), typeMismatch, Result(..) ) where -import Control.Applicative +import Compat.Prelude +import Prelude hiding (putStr) + import Control.Arrow -import Control.DeepSeq -import Data.Binary -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Hashable -import qualified Data.HashMap.Strict as HashMap -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +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 Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT import Data.Typeable -import qualified Data.Vector as V +import qualified Data.Vector as V import Data.MessagePack.Assoc -import Data.MessagePack.Get +import Data.MessagePack.Get.Internal +import Data.MessagePack.Integer import Data.MessagePack.Put +import Data.MessagePack.Result +import Data.MessagePack.Tags + +import Compat.Binary + -- | Object Representation of MessagePack data. +-- +-- @since 1.1.0.0 data Object = ObjectNil + -- ^ represents nil | ObjectBool !Bool - | ObjectInt {-# UNPACK #-} !Int + -- ^ represents true or false + | ObjectInt {-# UNPACK #-} !MPInteger + -- ^ represents an integer (__NOTE__: Changed from 'Int' to 'MPInteger' in @msgpack-1.1.0.0@) | ObjectFloat {-# UNPACK #-} !Float + -- ^ represents a floating point number | ObjectDouble {-# UNPACK #-} !Double - | ObjectRAW !S.ByteString + -- ^ represents a floating point number + | ObjectStr !T.Text + -- ^ represents an UTF-8 string + -- + -- __NOTE__: MessagePack is limited to maximum UTF-8 encoded size of \( 2^{32}-1 \) octets. + | ObjectBin !S.ByteString + -- ^ represents opaque binary data + -- + -- __NOTE__: MessagePack is limited to maximum data size of \( 2^{32}-1 \) bytes. | ObjectArray !(V.Vector Object) + -- ^ represents a sequence of objects + -- + -- __NOTE__: MessagePack is limited to maximum of \( 2^{32}-1 \) array items. | ObjectMap !(V.Vector (Object, Object)) - deriving (Show, Eq, Ord, Typeable) + -- ^ represents key-value pairs of objects + -- + -- __NOTE__: MessagePack is limited to maximum of \( 2^{32}-1 \) map entries. + | ObjectExt {-# UNPACK #-} !Int8 !S.ByteString + -- ^ represents a tuple of an integer and a byte array where + -- the signed 8-bit represents type information and the byte array represents data. + -- Negative type-ids are reserved for use by the MessagePack specification; in other words, only the use of the type values @[ 0 .. 127 ]@ is allowed for custom extension data. + -- + -- See "Data.MessagePack.Timestamp" for dealing with the MessagePack defined extension type @-1@. + -- + -- __NOTE__: MessagePack is limited to maximum extension data size of up to \( 2^{32}-1 \) bytes. + deriving (Show, Read, Eq, Ord, Typeable, Generic) + +(.:) :: MessagePack a => Object -> T.Text -> Result a +(ObjectMap m) .: key = + let finder ((ObjectStr k), _) | k == key = True + finder _ = False + in case V.find finder m of + Just (_, a) -> fromObject a + _ -> Error $ "missing key " ++ T.unpack key +m .: _ = Error $ "expected Objectmap got " ++ (show . typeOf $ m) + +(.=) :: MessagePack a => T.Text -> a -> (Object, Object) +k .= a = (ObjectStr k, toObject a) instance NFData Object where rnf obj = case obj of @@ -69,192 +119,355 @@ instance NFData Object where _ -> () getObject :: Get Object -getObject = - ObjectNil <$ getNil - <|> ObjectBool <$> getBool - <|> ObjectInt <$> getInt - <|> ObjectFloat <$> getFloat - <|> ObjectDouble <$> getDouble - <|> ObjectRAW <$> getRAW - <|> ObjectArray <$> getArray getObject - <|> ObjectMap <$> getMap getObject getObject +getObject = do + -- NB: <|> has the side-effect of un-consuming on failure + tag <- do { t <- getWord8; guard (t /= TAG_reserved_C1); pure t } + <|> (fail "encountered reserved MessagePack tag 0xC1") + + tryNil tag (const ObjectNil) $ + tryBool tag ObjectBool $ + tryMPInteger tag ObjectInt $ + tryFloat tag ObjectFloat $ + tryDouble tag ObjectDouble $ + tryStr tag ObjectStr $ + tryBin tag ObjectBin $ + tryArray getObject tag ObjectArray $ + tryMap getObject getObject tag ObjectMap $ + tryExt tag (uncurry ObjectExt) $ + fail ("getObject: internal error " ++ show tag) -- should never happen putObject :: Object -> Put putObject = \case ObjectNil -> putNil ObjectBool b -> putBool b - ObjectInt n -> putInt n + ObjectInt n -> put n ObjectFloat f -> putFloat f ObjectDouble d -> putDouble d - ObjectRAW r -> putRAW r + 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 +-- | 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 + + -- | Encodes directly to 'Put' monad bypassing the intermediate 'Object' AST + -- + -- @since 1.1.0.0 + toBinary :: a -> Put + toBinary = putObject . toObject + + fromObject :: Object -> Result a -- core instances +-- | The trivial identity 'MessagePack' instance instance MessagePack Object where toObject = id - fromObject = Just + toBinary = putObject + fromObject = pure +-- | Encodes as 'ObjectNil' instance MessagePack () where toObject _ = ObjectNil - fromObject = \case - ObjectNil -> Just () - _ -> Nothing - -instance MessagePack Int where - toObject = ObjectInt - fromObject = \case - ObjectInt n -> Just n - _ -> Nothing + toBinary _ = putNil + fromObject = withNil "()" (pure ()) instance MessagePack Bool where toObject = ObjectBool - fromObject = \case - ObjectBool b -> Just b - _ -> Nothing + toBinary = putBool + fromObject = withBool "Bool" pure + +---------------------------------------------------------------------------- +-- | @since 1.1.0.0 +instance MessagePack MPInteger where + toObject = ObjectInt + toBinary = put + fromObject = withInt "MPInteger" pure + +fromObjectInt :: FromMPInteger i => String -> Object -> Result i +fromObjectInt expected = withInt expected go + where + go j = case fromMPInteger j of + Just j' -> pure j' + Nothing -> fail ("MessagePack integer " ++ show j ++ " cannot be decoded into " ++ expected) + +-- | @since 1.1.0.0 +instance MessagePack Word64 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Word64" + +-- | @since 1.1.0.0 +instance MessagePack Word32 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Word32" + +-- | @since 1.1.0.0 +instance MessagePack Word16 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Word16" + +-- | @since 1.1.0.0 +instance MessagePack Word8 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Word8" + +-- | @since 1.1.0.0 +instance MessagePack Word where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Word" + +-- | @since 1.1.0.0 +instance MessagePack Int64 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Int64" + +-- | @since 1.1.0.0 +instance MessagePack Int32 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Int32" + +-- | @since 1.1.0.0 +instance MessagePack Int16 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Int16" + +-- | @since 1.1.0.0 +instance MessagePack Int8 where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Int8" + +instance MessagePack Int where + toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger + fromObject = fromObjectInt "Int" + +---------------------------------------------------------------------------- + +-- | This instance decodes only 32bit floats and will fail to decode 64bit floats from MessagePack streams instance MessagePack Float where toObject = ObjectFloat - fromObject = \case - ObjectInt n -> Just $ fromIntegral n - ObjectFloat f -> Just f - ObjectDouble d -> Just $ realToFrac d - _ -> Nothing + toBinary = putFloat + fromObject = withFloat "Float" pure +-- | This instance decodes 64bit and 32bit floats from MessagePack streams into a 'Double' instance MessagePack Double where toObject = ObjectDouble - fromObject = \case - ObjectInt n -> Just $ fromIntegral n - ObjectFloat f -> Just $ realToFrac f - ObjectDouble d -> Just d - _ -> Nothing + toBinary = putDouble + fromObject = withDouble "Double" pure instance MessagePack S.ByteString where - toObject = ObjectRAW - fromObject = \case - ObjectRAW r -> Just r - _ -> Nothing + toObject = ObjectBin + toBinary = putBin + fromObject = withBin "ByteString" pure -- Because of overlapping instance, this must be above [a] instance MessagePack String where - toObject = toObject . T.encodeUtf8 . T.pack - fromObject obj = T.unpack . T.decodeUtf8 <$> fromObject obj + toObject = toObject . T.pack + toBinary = putStr . T.pack + fromObject obj = T.unpack <$> fromObject obj instance MessagePack a => MessagePack (V.Vector a) where toObject = ObjectArray . V.map toObject - fromObject = \case - ObjectArray xs -> V.mapM fromObject xs - _ -> Nothing + toBinary = putArray toBinary + fromObject = withArray "Vector" (V.mapM fromObject) instance (MessagePack a, MessagePack b) => MessagePack (Assoc (V.Vector (a, b))) where toObject (Assoc xs) = ObjectMap $ V.map (toObject *** toObject) xs - fromObject = \case - ObjectMap xs -> - Assoc <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs - _ -> - Nothing - --- util instances - --- nullable + toBinary (Assoc xs) = putMap toBinary toBinary xs + fromObject = withMap "Assoc" (fmap Assoc . (V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v))) +-- | '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 Nothing -> ObjectNil + toBinary = \case + Just a -> toBinary a + Nothing -> putNil fromObject = \case - ObjectNil -> Just Nothing - obj -> fromObject obj + ObjectNil -> pure Nothing + obj -> Just <$> fromObject obj -- UTF8 string like instance MessagePack L.ByteString where - toObject = ObjectRAW . L.toStrict + toObject = ObjectBin . L.toStrict + toBinary = putBin . L.toStrict fromObject obj = L.fromStrict <$> fromObject obj +-- | @since 1.0.1.0 +instance MessagePack SBS.ShortByteString where + toObject = ObjectBin . SBS.fromShort + toBinary = putBin . SBS.fromShort + fromObject obj = SBS.toShort <$> fromObject obj + instance MessagePack T.Text where - toObject = toObject . T.encodeUtf8 - fromObject obj = T.decodeUtf8With skipChar <$> fromObject obj + toObject = ObjectStr + toBinary = putStr + fromObject = withStr "Text" pure instance MessagePack LT.Text where - toObject = ObjectRAW . L.toStrict . LT.encodeUtf8 - fromObject obj = LT.decodeUtf8With skipChar <$> fromObject obj - -skipChar :: T.OnDecodeError -skipChar _ _ = Nothing + toObject = toObject . LT.toStrict + toBinary = putStr . LT.toStrict + fromObject obj = LT.fromStrict <$> fromObject obj -- array like instance MessagePack a => MessagePack [a] where toObject = toObject . V.fromList + toBinary = putArray toBinary . V.fromList fromObject obj = V.toList <$> fromObject obj +instance MessagePack a => MessagePack (NonEmpty a) where + toObject = toObject . NEL.toList + toBinary = toBinary . NEL.toList + fromObject o = do + lst <- fromObject o + case NEL.nonEmpty lst of + Just as -> Success as + Nothing -> Error "empty list" + -- map like instance (MessagePack k, MessagePack v) => MessagePack (Assoc [(k, v)]) where toObject = toObject . Assoc . V.fromList . unAssoc + toBinary = putMap toBinary toBinary . V.fromList . unAssoc fromObject obj = Assoc . V.toList . unAssoc <$> fromObject obj instance (MessagePack k, MessagePack v, Ord k) => MessagePack (Map.Map k v) where toObject = toObject . Assoc . Map.toList + toBinary = putMap toBinary toBinary . V.fromList . Map.toList fromObject obj = Map.fromList . unAssoc <$> fromObject obj instance MessagePack v => MessagePack (IntMap.IntMap v) where toObject = toObject . Assoc . IntMap.toList + toBinary = putMap toBinary toBinary . V.fromList . 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 + toBinary = putMap toBinary toBinary . V.fromList . HashMap.toList fromObject obj = HashMap.fromList . unAssoc <$> fromObject obj -- tuples instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] + toBinary (a1, a2) = putArray' 2 $ do { toBinary a1; toBinary a2 } fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2 - fromObject _ = Nothing + fromObject obj = typeMismatch "2-tuple" obj instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] + toBinary (a1, a2, a3) = putArray' 3 $ do { toBinary a1; toBinary a2; toBinary a3 } fromObject (ObjectArray [a1, a2, a3]) = (,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 - fromObject _ = Nothing + fromObject obj = typeMismatch "3-tuple" obj 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] + toBinary (a1, a2, a3, a4) = putArray' 4 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4 } fromObject (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 - fromObject _ = Nothing + fromObject obj = typeMismatch "4-tuple" obj 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] + toBinary (a1, a2, a3, a4, a5) = putArray' 5 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5 } fromObject (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 - fromObject _ = Nothing + fromObject obj = typeMismatch "5-tuple" obj 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] + toBinary (a1, a2, a3, a4, a5, a6) = putArray' 6 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6 } fromObject (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 - fromObject _ = Nothing + fromObject obj = typeMismatch "6-tuple" obj 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] + toBinary (a1, a2, a3, a4, a5, a6, a7) = putArray' 7 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6; toBinary 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 _ = Nothing + fromObject obj = typeMismatch "7-tuple" obj 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] + toBinary (a1, a2, a3, a4, a5, a6, a7, a8) = putArray' 8 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6; toBinary a7; toBinary 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 _ = Nothing + fromObject obj = typeMismatch "8-tuple" obj 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] + toBinary (a1, a2, a3, a4, a5, a6, a7, a8, a9) = putArray' 8 $ do { toBinary a1; toBinary a2; toBinary a3; toBinary a4; toBinary a5; toBinary a6; toBinary a7; toBinary a8; toBinary 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 _ = Nothing + fromObject obj = typeMismatch "9-tuple" obj + +typeMismatch :: String -> Object -> Result a +typeMismatch expected obj = fail ("MessagePack " ++ got ++ " type cannot be decoded into " ++ expected) + where + got = case obj of + ObjectNil -> "nil" + ObjectArray v -> "array["++show (V.length v)++"]" + ObjectMap v -> "map["++show (V.length v)++"]" + ObjectStr _ -> "str" + ObjectBool _ -> "bool" + ObjectInt _ -> "int" + ObjectFloat _ -> "float32" + ObjectDouble _ -> "float64" + ObjectBin _ -> "bin" + ObjectExt ty _ -> "ext["++show ty++"]" + +withNil :: String -> Result a -> Object -> Result a +withNil _ f ObjectNil = f +withNil expected _ got = typeMismatch expected got + +withBool :: String -> (Bool -> Result a) -> Object -> Result a +withBool _ f (ObjectBool b) = f b +withBool expected _ got = typeMismatch expected got + +withInt :: String -> (MPInteger -> Result a) -> Object -> Result a +withInt _ f (ObjectInt i) = f i +withInt expected _ got = typeMismatch expected got + +withFloat :: String -> (Float -> Result a) -> Object -> Result a +withFloat _ f (ObjectFloat x) = f x +withFloat expected _ got = typeMismatch expected got + +withDouble :: String -> (Double -> Result a) -> Object -> Result a +withDouble _ f (ObjectFloat x) = f $! (realToFrac x) +withDouble _ f (ObjectDouble x) = f x +withDouble expected _ got = typeMismatch expected got + +withBin :: String -> (S.ByteString -> Result a) -> Object -> Result a +withBin _ f (ObjectBin i) = f i +withBin expected _ got = typeMismatch expected got + +withStr :: String -> (T.Text -> Result a) -> Object -> Result a +withStr _ f (ObjectStr i) = f i +withStr expected _ got = typeMismatch expected got + +withArray :: String -> (V.Vector Object -> Result a) -> Object -> Result a +withArray _ f (ObjectArray xs) = f xs +withArray expected _ got = typeMismatch expected got + +withMap :: String -> (V.Vector (Object,Object) -> Result a) -> Object -> Result a +withMap _ f (ObjectMap xs) = f xs +withMap expected _ got = typeMismatch expected got diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 7879aec..56d98ef 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -1,96 +1,131 @@ +{-# LANGUAGE LambdaCase #-} + -------------------------------------------------------------------- -- | -- 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, - putRAW, putArray, putMap, + putNil, putBool, putFloat, putDouble, + putInt, putWord, putInt64, putWord64, + putStr, putBin, putArray, putArray', putMap, putExt, putExt' ) where -import Data.Binary -import Data.Binary.IEEE754 -import Data.Binary.Put -import Data.Bits -import qualified Data.ByteString as S -import qualified Data.Vector as V +import Compat.Prelude +import Prelude hiding (putStr) + +import qualified Data.ByteString as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V + +import Compat.Binary +import Data.MessagePack.Integer +import Data.MessagePack.Tags putNil :: Put -putNil = putWord8 0xC0 +putNil = putWord8 TAG_nil putBool :: Bool -> Put -putBool False = putWord8 0xC2 -putBool True = putWord8 0xC3 +putBool False = putWord8 TAG_false +putBool True = putWord8 TAG_true +-- | Encodes an 'Int' to MessagePack +-- +-- See also 'MPInteger' and its 'Binary' instance. 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 = put . toMPInteger + +-- | @since 1.0.1.0 +putWord :: Word -> Put +putWord = put . toMPInteger + +-- | @since 1.0.1.0 +putInt64 :: Int64 -> Put +putInt64 = put . toMPInteger + +-- | @since 1.0.1.0 +putWord64 :: Word64 -> Put +putWord64 = put . toMPInteger putFloat :: Float -> Put -putFloat f = do - putWord8 0xCB - putFloat32be f +putFloat f = putWord8 TAG_float32 >> putFloat32be f putDouble :: Double -> Put -putDouble d = do - putWord8 0xCB - putFloat64be d - -putRAW :: S.ByteString -> Put -putRAW bs = do - case S.length bs of - len | len <= 31 -> - putWord8 $ 0xA0 .|. fromIntegral len - | len < 0x10000 -> - putWord8 0xDA >> putWord16be (fromIntegral len) - | otherwise -> - putWord8 0xDB >> putWord32be (fromIntegral len) +putDouble d = putWord8 TAG_float64 >> putFloat64be d + +putStr :: T.Text -> Put +putStr t = do + let bs = T.encodeUtf8 t + toSizeM ("putStr: data exceeds 2^32-1 byte limit of MessagePack") (S.length bs) >>= \case + len | len < 32 -> putWord8 (TAG_fixstr .|. fromIntegral len) + | len < 0x100 -> putWord8 TAG_str8 >> putWord8 (fromIntegral len) + | len < 0x10000 -> putWord8 TAG_str16 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 TAG_str32 >> putWord32be (fromIntegral len) + putByteString bs + +putBin :: S.ByteString -> Put +putBin bs = do + toSizeM ("putBin: data exceeds 2^32-1 byte limit of MessagePack") (S.length bs) >>= \case + len | len < 0x100 -> putWord8 TAG_bin8 >> putWord8 (fromIntegral len) + | len < 0x10000 -> putWord8 TAG_bin16 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 TAG_bin32 >> putWord32be (fromIntegral len) putByteString bs putArray :: (a -> Put) -> V.Vector a -> Put putArray p xs = do - case V.length xs of - len | len <= 15 -> - putWord8 $ 0x90 .|. fromIntegral len - | len < 0x10000 -> - putWord8 0xDC >> putWord16be (fromIntegral len) - | otherwise -> - putWord8 0xDD >> putWord32be (fromIntegral len) - V.mapM_ p xs + len <- toSizeM ("putArray: data exceeds 2^32-1 element limit of MessagePack") (V.length xs) + putArray' len (V.mapM_ p xs) + +-- | @since 1.1.0.0 +putArray' :: Word32 -- ^ number of array elements + -> Put -- ^ 'Put' action emitting array elements (__NOTE__: it's the responsibility of the caller to ensure that the declared array length matches exactly the data generated by the 'Put' action) + -> Put +putArray' len putter = do + case () of + _ | len < 16 -> putWord8 (TAG_fixarray .|. fromIntegral len) + | len < 0x10000 -> putWord8 TAG_array16 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 TAG_array32 >> putWord32be (fromIntegral len) + putter putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put putMap p q xs = do - case V.length xs of - len | len <= 15 -> - putWord8 $ 0x80 .|. fromIntegral len - | len < 0x10000 -> - putWord8 0xDE >> putWord16be (fromIntegral len) - | otherwise -> - putWord8 0xDF >> putWord32be (fromIntegral len) - V.mapM_ (\(a, b) -> p a >> q b ) xs + toSizeM ("putMap: data exceeds 2^32-1 element limit of MessagePack") (V.length xs) >>= \case + len | len < 16 -> putWord8 (TAG_fixmap .|. fromIntegral len) + | len < 0x10000 -> putWord8 TAG_map16 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 TAG_map32 >> putWord32be (fromIntegral len) + V.mapM_ (\(a, b) -> p a >> q b) xs + +-- | __NOTE__: MessagePack is limited to maximum extended data payload size of \( 2^{32}-1 \) bytes. +putExt :: Int8 -> S.ByteString -> Put +putExt typ dat = do + sz <- toSizeM "putExt: data exceeds 2^32-1 byte limit of MessagePack" (S.length dat) + putExt' typ (sz, putByteString dat) + +-- | @since 1.1.0.0 +putExt' :: Int8 -- ^ type-id of extension data (__NOTE__: The values @[ -128 .. -2 ]@ are reserved for future use by the MessagePack specification). + -> (Word32,Put) -- ^ @(size-of-data, data-'Put'-action)@ (__NOTE__: it's the responsibility of the caller to ensure that the declared size matches exactly the data generated by the 'Put' action) + -> Put +putExt' typ (sz,putdat) = do + case sz of + 1 -> putWord8 TAG_fixext1 + 2 -> putWord8 TAG_fixext2 + 4 -> putWord8 TAG_fixext4 + 8 -> putWord8 TAG_fixext8 + 16 -> putWord8 TAG_fixext16 + len | len < 0x100 -> putWord8 TAG_ext8 >> putWord8 (fromIntegral len) + | len < 0x10000 -> putWord8 TAG_ext16 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 TAG_ext32 >> putWord32be (fromIntegral len) + putInt8 typ + putdat + +---------------------------------------------------------------------------- + +toSizeM :: String -> Int -> PutM Word32 +toSizeM label len0 = maybe (error label) pure (intCastMaybe len0) diff --git a/msgpack/src/Data/MessagePack/Result.hs b/msgpack/src/Data/MessagePack/Result.hs new file mode 100644 index 0000000..1819156 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Result.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +-- | +-- Module : Data.MessagePack.Integer +-- Copyright : © Herbert Valerio Riedel 2019 +-- License : BSD3 +-- +-- Type representing MessagePack integers +-- +-- @since 1.1.0.0 +module Data.MessagePack.Result + ( Result(..) + ) where + +import Compat.Prelude +import qualified Control.Monad.Fail as Fail + +-- | The result of decoding from MessagePack +-- +-- @since 1.1.0.0 +data Result a = Error String + | Success a + deriving (Eq, Show, Functor, Typeable, Generic, Foldable, Traversable) + +instance NFData a => NFData (Result a) where + rnf (Error e) = rnf e + rnf (Success a) = rnf a + +instance Applicative Result where + pure = Success + (<*>) = ap + +instance Monad Result where + Success a >>= m = m a + Error err >>= _ = Error err + +#if !MIN_VERSION_base(4,13,0) + return = pure + fail = Fail.fail +#endif + +instance Fail.MonadFail Result where + fail = Error + +instance Alternative Result where + empty = fail "Alternative(empty)" + a@(Success _) <|> _ = a + _ <|> b = b diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs new file mode 100644 index 0000000..7183fa3 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +#endif + +-- | +-- Module : Data.MessagePack.Tags +-- Copyright : © Herbert Valerio Riedel 2019 +-- License : BSD3 +-- +-- The tag constants in this module were carefully copied from the table at +-- +-- https://github.com/msgpack/msgpack/blob/master/spec.md#formats +-- +module Data.MessagePack.Tags where + +import Compat.Prelude + +-- | Test whether tag is a fixint +is_TAG_fixint :: Word8 -> Bool +is_TAG_fixint tag = (tag .&. TAG_MASK_fixintp == TAG_fixintp) + || (tag .&. TAG_MASK_fixintn == TAG_fixintn) +{-# INLINE is_TAG_fixint #-} + +pattern TAG_fixintn = 0xe0 -- 0b111xxxxx [0xe0 .. 0xff] / [-32 .. -1] +pattern TAG_MASK_fixintn = 0xe0 -- 0b11100000 + +pattern TAG_fixintp = 0x00 -- 0b0xxxxxxx [0x00 .. 0x7f] / [0 .. 127] +pattern TAG_MASK_fixintp = 0x80 -- 0b10000000 + +-- | Test whether tag is a fixmap and return embedded-size if it is +is_TAG_fixmap :: Word8 -> Maybe Word32 +is_TAG_fixmap t + | t .&. TAG_MASK_fixmap == TAG_fixmap = Just $! intCast (t .&. complement TAG_MASK_fixmap) + | otherwise = Nothing +{-# INLINE is_TAG_fixmap #-} + +pattern TAG_fixmap = 0x80 -- 0b1000xxxx [0x80 .. 0x8f] +pattern TAG_MASK_fixmap = 0xf0 -- 0b11110000 + +-- | Test whether tag is a fixarray and return embedded-size if it is +is_TAG_fixarray :: Word8 -> Maybe Word32 +is_TAG_fixarray t + | t .&. TAG_MASK_fixarray == TAG_fixarray = Just $! intCast (t .&. complement TAG_MASK_fixarray) + | otherwise = Nothing +{-# INLINE is_TAG_fixarray #-} + +pattern TAG_fixarray = 0x90 -- 0b1001xxxx [0x90 .. 0x9f] +pattern TAG_MASK_fixarray = 0xf0 -- 0b11110000 + +-- | Test whether tag is a fixstr and return embedded-size if it is +is_TAG_fixstr :: Word8 -> Maybe Word32 +is_TAG_fixstr t + | t .&. TAG_MASK_fixstr == TAG_fixstr = Just $! intCast (t .&. complement TAG_MASK_fixstr) + | otherwise = Nothing +{-# INLINE is_TAG_fixstr #-} + +pattern TAG_fixstr = 0xa0 -- 0b101xxxxx [0xa0 .. 0xbf] +pattern TAG_MASK_fixstr = 0xe0 -- 0b11100000 + +pattern TAG_nil = 0xc0 -- 0b11000000 +pattern TAG_reserved_C1 = 0xc1 -- 0b11000001 +pattern TAG_false = 0xc2 -- 0b11000010 +pattern TAG_true = 0xc3 -- 0b11000011 + +pattern TAG_bin8 = 0xc4 -- 0b11000100 +pattern TAG_bin16 = 0xc5 -- 0b11000101 +pattern TAG_bin32 = 0xc6 -- 0b11000110 + +pattern TAG_ext8 = 0xc7 -- 0b11000111 +pattern TAG_ext16 = 0xc8 -- 0b11001000 +pattern TAG_ext32 = 0xc9 -- 0b11001001 + +pattern TAG_float32 = 0xca -- 0b11001010 +pattern TAG_float64 = 0xcb -- 0b11001011 + +pattern TAG_uint8 = 0xcc -- 0b11001100 +pattern TAG_uint16 = 0xcd -- 0b11001101 +pattern TAG_uint32 = 0xce -- 0b11001110 +pattern TAG_uint64 = 0xcf -- 0b11001111 + +pattern TAG_int8 = 0xd0 -- 0b11010000 +pattern TAG_int16 = 0xd1 -- 0b11010001 +pattern TAG_int32 = 0xd2 -- 0b11010010 +pattern TAG_int64 = 0xd3 -- 0b11010011 + +pattern TAG_fixext1 = 0xd4 -- 0b11010100 +pattern TAG_fixext2 = 0xd5 -- 0b11010101 +pattern TAG_fixext4 = 0xd6 -- 0b11010110 +pattern TAG_fixext8 = 0xd7 -- 0b11010111 +pattern TAG_fixext16 = 0xd8 -- 0b11011000 + +pattern TAG_str8 = 0xd9 -- 0b11011001 +pattern TAG_str16 = 0xda -- 0b11011010 +pattern TAG_str32 = 0xdb -- 0b11011011 + +pattern TAG_array16 = 0xdc -- 0b11011100 +pattern TAG_array32 = 0xdd -- 0b11011101 + +pattern TAG_map16 = 0xde -- 0b11011110 +pattern TAG_map32 = 0xdf -- 0b11011111 + +-- NOTE: Currently the MessagePack specification only defines the @-1@ +-- extension type (for timestamps). All remaining negative Int8 +-- type-ids are reserved for future use by the MessagePack. + +-- Used by "Data.MessagePack.Timestamp" +pattern XTAG_Timestamp = -1 :: Int8 diff --git a/msgpack/src/Data/MessagePack/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs new file mode 100644 index 0000000..7c78309 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Data.MessagePack.Integer +-- Copyright : © Herbert Valerio Riedel 2019 +-- License : BSD3 +-- +-- The 'MPTimestamp' type for representing MessagePack Timestamps +-- +-- @since 1.1.0.0 +module Data.MessagePack.Timestamp + ( MPTimestamp + + , mptsFromPosixSeconds + , mptsFromPosixSeconds2 + , mptsToPosixSeconds2 + + , mptsFromPosixNanoseconds + , mptsToPosixNanoseconds + + , mptsToUTCTime + , mptsFromUTCTime + , mptsFromUTCTimeLossy + ) where + +import Compat.Prelude + +import qualified Data.ByteString as S +import Data.Fixed +import qualified Data.Time.Clock as Time +import qualified Data.Time.Clock.POSIX as Time + +import Compat.Binary as Bin +import Data.MessagePack.Get +import Data.MessagePack.Object +import Data.MessagePack.Put +import Data.MessagePack.Tags + +-- | A MessagePack timestamp +-- +-- The representable range is @[-292277022657-01-27 08:29:52 UTC .. 292277026596-12-04 15:30:07.999999999 UTC]@ with nanosecond precision. +-- +-- @since 1.1.0.0 +data MPTimestamp = MPTimestamp !Int64 !Word32 + deriving (Eq,Ord,Show,Read,Typeable) + +instance Bounded MPTimestamp where + minBound = MPTimestamp minBound 0 + maxBound = MPTimestamp maxBound 999999999 + +instance NFData MPTimestamp where rnf (MPTimestamp _ _) = () + +-- | Construct 'MPTimestamp' from amount of integral seconds since Unix epoch +mptsFromPosixSeconds :: Int64 -> MPTimestamp +mptsFromPosixSeconds s = MPTimestamp s 0 + +-- | Construct 'MPTimestamp' from amount of seconds and nanoseconds (must be \( \leq 10^9 \) ) passed since Unix epoch +mptsFromPosixSeconds2 :: Int64 -> Word32 -> Maybe MPTimestamp +mptsFromPosixSeconds2 s ns + | ns <= 999999999 = Just $! MPTimestamp s ns + | otherwise = Nothing + +-- | Deconstruct 'MPTimestamp' into amount of seconds and nanoseconds passed since Unix epoch +mptsToPosixSeconds2 :: MPTimestamp -> (Int64, Word32) +mptsToPosixSeconds2 (MPTimestamp s ns) = (s, ns) + +-- | Construct 'MPTimestamp' from total amount of nanoseconds passed since Unix epoch +mptsFromPosixNanoseconds :: Integer -> Maybe MPTimestamp +mptsFromPosixNanoseconds ns0 + | minI <= ns0, ns0 <= maxI = Just $! MPTimestamp (fromInteger s) (fromInteger ns) + | otherwise = Nothing + where + (s,ns) = divMod ns0 1000000000 + maxI = mptsToPosixNanoseconds maxBound + minI = mptsToPosixNanoseconds minBound + +-- | Deconstruct 'MPTimestamp' into total amount of nanoseconds passed since Unix epoch +mptsToPosixNanoseconds :: MPTimestamp -> Integer +mptsToPosixNanoseconds (MPTimestamp s ns) = (toInteger s * 1000000000) + toInteger ns + +-- >>> mptsToUTCTime minBound +-- -292277022657-01-27 08:29:52 UTC + +-- >>> mptsToUTCTime maxBound +-- 292277026596-12-04 15:30:07.999999999 UTC + +-- >>> mptsToUTCTime (MPTimestamp 0 0) +-- 1970-01-01 00:00:00 UTC + +-- >>> mptsToUTCTime (MPTimestamp 0xffffffff 0) +-- 2106-02-07 06:28:15 UTC + +-- >>> mptsToUTCTime (MPTimestamp 0x3ffffffff 999999999) +-- 2514-05-30 01:53:03.999999999 UTC + +-- | Convert 'MPTimestamp' into 'Time.UTCTime' +mptsToUTCTime :: MPTimestamp -> Time.UTCTime +mptsToUTCTime = picoseconds2utc . (*1000) . mptsToPosixNanoseconds + +-- >>> mptsFromUTCTime (mptsToUTCTime minBound) == Just minBound +-- True + +-- >>> mptsFromUTCTime (mptsToUTCTime maxBound) == Just maxBound +-- True + +utc2picoseconds :: Time.UTCTime -> Integer +utc2picoseconds utc = ps + where -- NB: this exploits the RULE from time: + -- "realToFrac/NominalDiffTime->Pico" realToFrac = \(MkNominalDiffTime ps) -> ps + MkFixed ps = realToFrac (Time.utcTimeToPOSIXSeconds utc) :: Pico + +-- NB: exploits the RULE +-- "realToFrac/Pico->NominalDiffTime" realToFrac = MkNominalDiffTime +picoseconds2utc :: Integer -> Time.UTCTime +picoseconds2utc ps = Time.posixSecondsToUTCTime (realToFrac (MkFixed ps :: Pico)) + +-- | Convert 'Time.UTCTime' into 'MPTimestamp' +-- +-- This conversion can fail (i.e. result in 'Nothing') if either the conversion cannot be performed lossless, either because the range of 'MPTimestamp' was exceeded or because of sub-nanosecond fractions. +-- +-- See also 'mptsFromUTCTimeLossy' +mptsFromUTCTime :: Time.UTCTime -> Maybe MPTimestamp +mptsFromUTCTime t + | rest /= 0 = Nothing + | otherwise = mptsFromPosixNanoseconds ns0 + where + (ns0,rest) = divMod (utc2picoseconds t) 1000 + +-- | Version of 'mptsFromUTCTime' which performs a lossy conversion into 'MPTimestamp' +-- +-- * sub-nanosecond precision is silently truncated (in the sense of 'floor') to nanosecond precision +-- +-- * time values exceeding the range of 'MPTimestamp' are clamped to 'minBound' and 'maxBound' respectively +-- +mptsFromUTCTimeLossy :: Time.UTCTime -> MPTimestamp +mptsFromUTCTimeLossy t + | Just mpts <- mptsFromPosixNanoseconds ns0 = mpts + | ns0 < 0 = minBound + | otherwise = maxBound + where + ns0 = div (utc2picoseconds t) 1000 + +---------------------------------------------------------------------------- + +instance MessagePack MPTimestamp where + toObject = ObjectExt XTAG_Timestamp . mptsEncode + + fromObject = \case + ObjectExt XTAG_Timestamp bs -> mptsDecode bs + obj -> typeMismatch "MPTimestamp" obj + +-- helpers for 'MessagePack' instance +mptsEncode :: MPTimestamp -> S.ByteString +mptsEncode = runPut' . snd . mptsPutExtData + +mptsDecode :: S.ByteString -> Result MPTimestamp +mptsDecode bs = do + len <- maybe (fail "invalid data-length for Timestamp") pure $ intCastMaybe (S.length bs) + either fail pure $ runGet' bs (mptsGetExtData len) + +-- | This 'Binary' instance encodes\/decodes to\/from MessagePack format +instance Bin.Binary MPTimestamp where + get = getExt' $ \typ sz -> do + unless (typ == XTAG_Timestamp) $ fail "invalid extended type-tag for Timestamp" + mptsGetExtData sz + + put = putExt' XTAG_Timestamp . mptsPutExtData + +mptsPutExtData :: MPTimestamp -> (Word32,Bin.Put) +mptsPutExtData (MPTimestamp sec ns) + | ns == 0, Just sec' <- intCastMaybe sec = (4, Bin.putWord32be sec') + | 0 <= sec, sec <= 0x3ffffffff = (8, do + let s' = ((intCast ns :: Word64) `shiftL` 34) .|. (fromIntegral sec) + Bin.putWord64be s') + | otherwise = (12, do + Bin.putWord32be ns + Bin.putInt64be sec) + +mptsGetExtData :: Word32 -> Bin.Get MPTimestamp +mptsGetExtData = \case + 4 -> do + s <- Bin.getWord32be + pure $! MPTimestamp (intCast s) 0 + + 8 -> do + dat <- Bin.getWord64be + let s = fromIntegral (dat .&. 0x3ffffffff) + ns = fromIntegral (dat `shiftR` 34) + when (ns > 999999999) $ fail "invalid nanosecond value" + pure $! MPTimestamp s ns + + 12 -> do + ns <- Bin.getWord32be + s <- Bin.getInt64be + when (ns > 999999999) $ fail "invalid nanosecond value" + pure $! MPTimestamp s ns + + _ -> fail "unsupported timestamp encoding (length)" diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs new file mode 100644 index 0000000..f41db7c --- /dev/null +++ b/msgpack/test/DataCases.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +module DataCases (genDataCases) where + +import Control.Applicative as App +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Char +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word +import Data.YAML as Y +import qualified GHC.Exts as Lst (fromList) +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit + +import Data.MessagePack hiding ((.:), (.=)) +import Data.MessagePack.Timestamp + +genDataCases :: [FilePath] -> IO TestTree +genDataCases fns = testGroup "Reference Tests" <$> forM fns doFile + where + doFile fn = do + let fn' = "test" "data" fn <.> "yaml" + raw <- S.readFile fn' + let Right [cases] = Y.decodeStrict raw + + tcs <- forM (zip [1..] cases) $ \(i,tc) -> do + -- print (tc :: DataCase) + App.pure $ testCase ("testcase #" ++ show (i::Int)) $ do + -- test forward direction + let b0 = L.toStrict $ pack obj + obj = dcObject tc + assertBool ("pack " ++ show obj) (b0 `elem` dcMsgPack tc) + + forM_ (zip [0..] (dcMsgPack tc)) $ \(j,b) -> do + let Right decoded = unpack (L.fromStrict b) + + packLbl = "pack #" ++ (show (j::Int)) + unpackLbl = "un" ++ packLbl + + -- the `number` test-cases conflate integers and floats + case (obj, decoded) of + (ObjectDouble x, ObjectFloat _) -> do + let obj' = ObjectFloat (realToFrac x) + assertEqual packLbl b (L.toStrict $ pack obj') + assertEqual unpackLbl obj' decoded + + (ObjectInt x, ObjectFloat _) -> do + let obj' = ObjectFloat (fromIntegral x) + assertEqual packLbl b (L.toStrict $ pack obj') + assertEqual unpackLbl obj' decoded + + (ObjectInt x, ObjectDouble _) -> do + let obj' = ObjectDouble (fromIntegral x) + assertEqual packLbl b (L.toStrict $ pack obj') + assertEqual unpackLbl obj' decoded + + _ -> assertEqual unpackLbl obj decoded + + pure () + + pure (testGroup fn tcs) + + +data DataCase = DataCase + { dcMsgPack :: [BS.ByteString] + , dcObject :: Object + } deriving Show + +instance FromYAML DataCase where + parseYAML = Y.withMap "DataCase" $ \m -> do + msgpack <- m .: "msgpack" + + obj <- do { Just (Y.Scalar Y.SNull) <- m .:! "nil" ; pure ObjectNil } + <|> do { Just b <- m .:! "bool" ; pure (ObjectBool b) } + <|> do { Just i <- m .:! "number" ; pure (ObjectInt (fromInteger i)) } + <|> do { Just s <- m .:! "bignum" ; pure (ObjectInt (read . T.unpack $ s)) } + <|> do { Just d <- m .:! "number" ; pure (ObjectDouble d) } + <|> do { Just t <- m .:! "string" ; pure (ObjectStr t) } + <|> do { Just t <- m .:! "binary" ; pure (ObjectBin (hex2bin t)) } + <|> do { Just v@(Y.Sequence _ _) <- m .:! "array" ; pure (nodeToObj v) } + <|> do { Just m'@(Y.Mapping _ _) <- m .:! "map" ; pure (nodeToObj m') } + <|> do { Just (n,t) <- m .:! "ext" ; pure (ObjectExt n (hex2bin t)) } + <|> do { Just (s,ns) <- m .:! "timestamp"; pure (toObject $ mptsFromPosixSeconds2 s ns) } + + pure (DataCase { dcMsgPack = map hex2bin msgpack, dcObject = obj }) + + +nodeToObj :: Y.Node -> Object +nodeToObj (Y.Scalar sca) = scalarToObj sca +nodeToObj (Y.Sequence _ ns) = ObjectArray (Lst.fromList (map nodeToObj ns)) +nodeToObj (Y.Mapping _ ns) = ObjectMap (Lst.fromList $ map (\(k,v) -> (nodeToObj k, nodeToObj v)) $ Map.toList ns) +nodeToObj (Y.Anchor _ n) = nodeToObj n + +scalarToObj :: Y.Scalar -> Object +scalarToObj Y.SNull = ObjectNil +scalarToObj (Y.SBool b) = ObjectBool b +scalarToObj (Y.SFloat x) = ObjectDouble x +scalarToObj (Y.SInt i) = ObjectInt (fromInteger i) +scalarToObj (SStr t) = ObjectStr t +scalarToObj (SUnknown _ _) = error "scalarToValue" + +hex2bin :: Text -> S.ByteString +hex2bin t + | T.null t = BS.empty + | otherwise = BS.pack (map f $ T.split (=='-') t) + where + f :: T.Text -> Word8 + f x | T.all isHexDigit x, [d1,d2] <- T.unpack x = read (['0','x',d1,d2]) + | otherwise = error ("hex2bin: " ++ show x) diff --git a/msgpack/test/Monad.hs b/msgpack/test/Monad.hs deleted file mode 100644 index 2ec4093..0000000 --- a/msgpack/test/Monad.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# Language OverloadedStrings #-} - -import Control.Monad.IO.Class -import qualified Data.ByteString as B -import Data.MessagePack - -main = do - sb <- return $ packToString $ do - put [1,2,3::Int] - put (3.14 :: Double) - put ("Hoge" :: B.ByteString) - - print sb - - r <- unpackFromString sb $ do - arr <- get - dbl <- get - str <- get - return (arr :: [Int], dbl :: Double, str :: B.ByteString) - - print r diff --git a/msgpack/test/Properties.hs b/msgpack/test/Properties.hs new file mode 100644 index 0000000..f7b4770 --- /dev/null +++ b/msgpack/test/Properties.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Properties (idPropTests) where + +import Control.Applicative as App +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Int +import Data.Maybe +import Data.Word +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Data.MessagePack +import Data.MessagePack.Timestamp + +instance Arbitrary a => Arbitrary (Assoc a) where + arbitrary = Assoc App.<$> arbitrary + +instance Arbitrary S.ByteString where + arbitrary = S.pack <$> arbitrary + +instance Arbitrary L.ByteString where + arbitrary = L.pack <$> arbitrary + +instance Arbitrary MPTimestamp where + arbitrary = frequency + [ (1, fromJust . mptsFromPosixNanoseconds <$> choose (mptsToPosixNanoseconds minBound, mptsToPosixNanoseconds maxBound)) + , (1, mptsFromPosixSeconds <$> arbitrary) + , (1, fromJust . mptsFromPosixNanoseconds <$> choose (0, 0x400000000 * 1000000000)) + ] + +mid :: MessagePack a => a -> a +mid = either error id . unpack . pack + +idPropTests :: TestTree +idPropTests = testGroup "Identity Properties" + [ testProperty "int" $ + \(a :: Int) -> a == mid a + , testProperty "word" $ + \(a :: Word) -> a == mid a + , testProperty "nil" $ + \(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" $ + \(a :: String) -> a == mid a + , testProperty "bytestring" $ + \(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)" $ + \(a :: (Int, Int)) -> a == mid a + , testProperty "(int, int, int)" $ + \(a :: (Int, Int, Int)) -> a == mid a + , testProperty "(int, int, int, int)" $ + \(a :: (Int, Int, Int, Int)) -> a == mid a + , testProperty "(int8, int16, int32, int64)" $ + \(a :: (Int8, Int16, Int32, Int64)) -> a == mid a + , testProperty "(word,word8, word16, word32, word64)" $ + \(a :: (Word, Word8, Word16, Word32, Word64)) -> a == mid a + , testProperty "(int, int, int, int, int)" $ + \(a :: (Int, Int, Int, Int, Int)) -> a == mid a + , testProperty "[(int, double)]" $ + \(a :: [(Int, Double)]) -> a == mid a + , testProperty "[(string, string)]" $ + \(a :: [(String, String)]) -> a == mid a + , testProperty "Assoc [(string, int)]" $ + \(a :: Assoc [(String, Int)]) -> a == mid a + , testProperty "MPTimestamp" $ + \(a :: MPTimestamp) -> a == mid a + , testProperty "maybe (Int,Bool,String)" $ + \(a :: (Maybe ((),Maybe Int,Maybe Float,Maybe Bool,Maybe Double,Maybe String))) -> a == mid a + ] diff --git a/msgpack/test/UserData.hs b/msgpack/test/UserData.hs deleted file mode 100644 index 55e1d61..0000000 --- a/msgpack/test/UserData.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} - -import Data.MessagePack - -data T - = A Int String - | B Double - deriving (Show, Eq) - -deriveObject True ''T - -data U - = C { c1 :: Int, c2 :: String } - | D { z1 :: Double } - deriving (Show, Eq) - -deriveObject True ''U - -data V - = E String | F - deriving (Show, Eq) - -deriveObject True ''V - -data W a - = G a String - | H { hHoge :: Int, h_age :: a } - deriving (Show, Eq) - -deriveObject True ''W - -test :: (OBJECT a, Show a, Eq a) => a -> IO () -test v = do - let bs = pack v - print bs - print (unpack bs == v) - - let oa = toObject v - print oa - print (fromObject oa == v) - -main :: IO () -main = do - test $ A 123 "hoge" - test $ B 3.14 - test $ C 123 "hoge" - test $ D 3.14 - test $ E "hello" - test $ F - test $ G (E "hello") "world" - test $ H 123 F - return () diff --git a/msgpack/test/data/10.nil.yaml b/msgpack/test/data/10.nil.yaml new file mode 100644 index 0000000..5d75b3a --- /dev/null +++ b/msgpack/test/data/10.nil.yaml @@ -0,0 +1,6 @@ +# nil + +# nil +- nil: null + msgpack: + - "c0" diff --git a/msgpack/test/data/11.bool.yaml b/msgpack/test/data/11.bool.yaml new file mode 100644 index 0000000..7621641 --- /dev/null +++ b/msgpack/test/data/11.bool.yaml @@ -0,0 +1,11 @@ +# bool + +# false +- bool: false + msgpack: + - "c2" + +# true +- bool: true + msgpack: + - "c3" diff --git a/msgpack/test/data/12.binary.yaml b/msgpack/test/data/12.binary.yaml new file mode 100644 index 0000000..61e8970 --- /dev/null +++ b/msgpack/test/data/12.binary.yaml @@ -0,0 +1,22 @@ +# binary + +# [] // empty +- binary: "" + msgpack: + - "c4-00" + - "c5-00-00" + - "c6-00-00-00-00" + +# [1] +- binary: "01" + msgpack: + - "c4-01-01" + - "c5-00-01-01" + - "c6-00-00-00-01-01" + +# [0, 255] +- binary: "00-ff" + msgpack: + - "c4-02-00-ff" + - "c5-00-02-00-ff" + - "c6-00-00-00-02-00-ff" diff --git a/msgpack/test/data/20.number-positive.yaml b/msgpack/test/data/20.number-positive.yaml new file mode 100644 index 0000000..28d739e --- /dev/null +++ b/msgpack/test/data/20.number-positive.yaml @@ -0,0 +1,120 @@ +# number-positive +# +# unsigned 32bit integer + +# 0x0000 +- number: 0 + msgpack: + - "00" # 0 ... 127 + - "cc-00" # unsigned int8 + - "cd-00-00" # unsigned int16 + - "ce-00-00-00-00" # unsigned int32 + - "cf-00-00-00-00-00-00-00-00" # unsigned int64 + - "d0-00" # signed int8 + - "d1-00-00" # signed int16 + - "d2-00-00-00-00" # signed int32 + - "d3-00-00-00-00-00-00-00-00" # signed int64 + - "ca-00-00-00-00" # float + - "cb-00-00-00-00-00-00-00-00" # double + +# 0x0001 +- number: 1 + msgpack: + - "01" + - "cc-01" + - "cd-00-01" + - "ce-00-00-00-01" + - "cf-00-00-00-00-00-00-00-01" + - "d0-01" + - "d1-00-01" + - "d2-00-00-00-01" + - "d3-00-00-00-00-00-00-00-01" + - "ca-3f-80-00-00" + - "cb-3f-f0-00-00-00-00-00-00" + +# 0x007F +- number: 127 + msgpack: + - "7f" + - "cc-7f" + - "cd-00-7f" + - "ce-00-00-00-7f" + - "cf-00-00-00-00-00-00-00-7f" + - "d0-7f" + - "d1-00-7f" + - "d2-00-00-00-7f" + - "d3-00-00-00-00-00-00-00-7f" + +# 0x0080 +- number: 128 + msgpack: + - "cc-80" + - "cd-00-80" + - "ce-00-00-00-80" + - "cf-00-00-00-00-00-00-00-80" + - "d1-00-80" + - "d2-00-00-00-80" + - "d3-00-00-00-00-00-00-00-80" + +# 0x00FF +- number: 255 + msgpack: + - "cc-ff" + - "cd-00-ff" + - "ce-00-00-00-ff" + - "cf-00-00-00-00-00-00-00-ff" + - "d1-00-ff" + - "d2-00-00-00-ff" + - "d3-00-00-00-00-00-00-00-ff" + +# 0x0100 +- number: 256 + msgpack: + - "cd-01-00" + - "ce-00-00-01-00" + - "cf-00-00-00-00-00-00-01-00" + - "d1-01-00" + - "d2-00-00-01-00" + - "d3-00-00-00-00-00-00-01-00" + +# 0xFFFF +- number: 65535 + msgpack: + - "cd-ff-ff" + - "ce-00-00-ff-ff" + - "cf-00-00-00-00-00-00-ff-ff" + - "d2-00-00-ff-ff" + - "d3-00-00-00-00-00-00-ff-ff" + +# 0x000100000 +- number: 65536 + msgpack: + - "ce-00-01-00-00" + - "cf-00-00-00-00-00-01-00-00" + - "d2-00-01-00-00" + - "d3-00-00-00-00-00-01-00-00" + +# 0x7FFFFFFF +- number: 2147483647 + msgpack: + - "ce-7f-ff-ff-ff" + - "cf-00-00-00-00-7f-ff-ff-ff" + - "d2-7f-ff-ff-ff" + - "d3-00-00-00-00-7f-ff-ff-ff" + +# 0x80000000 +- number: 2147483648 + msgpack: + - "ce-80-00-00-00" # unsigned int32 + - "cf-00-00-00-00-80-00-00-00" # unsigned int64 + - "d3-00-00-00-00-80-00-00-00" # signed int64 + - "ca-4f-00-00-00" # float + - "cb-41-e0-00-00-00-00-00-00" # double + +# 0xFFFFFFFF +- number: 4294967295 + msgpack: + - "ce-ff-ff-ff-ff" + - "cf-00-00-00-00-ff-ff-ff-ff" + - "d3-00-00-00-00-ff-ff-ff-ff" + - "cb-41-ef-ff-ff-ff-e0-00-00" diff --git a/msgpack/test/data/21.number-negative.yaml b/msgpack/test/data/21.number-negative.yaml new file mode 100644 index 0000000..6663c0f --- /dev/null +++ b/msgpack/test/data/21.number-negative.yaml @@ -0,0 +1,68 @@ +# number-negative +# +# signed 32bit integer + +# 0xFFFFFFFF +- number: -1 + msgpack: + - "ff" # -1 ... -32 + - "d0-ff" # signed int8 + - "d1-ff-ff" # signed int16 + - "d2-ff-ff-ff-ff" # signed int32 + - "d3-ff-ff-ff-ff-ff-ff-ff-ff" # signed int64 + - "ca-bf-80-00-00" # float + - "cb-bf-f0-00-00-00-00-00-00" # double + +# 0xFFFFFFE0 +- number: -32 + msgpack: + - "e0" + - "d0-e0" + - "d1-ff-e0" + - "d2-ff-ff-ff-e0" + - "d3-ff-ff-ff-ff-ff-ff-ff-e0" + - "ca-c2-00-00-00" + - "cb-c0-40-00-00-00-00-00-00" + +# 0xFFFFFFDF +- number: -33 + msgpack: + - "d0-df" + - "d1-ff-df" + - "d2-ff-ff-ff-df" + - "d3-ff-ff-ff-ff-ff-ff-ff-df" + +# 0xFFFFFF80 +- number: -128 + msgpack: + - "d0-80" + - "d1-ff-80" + - "d2-ff-ff-ff-80" + - "d3-ff-ff-ff-ff-ff-ff-ff-80" + +# 0xFFFFFF00 +- number: -256 + msgpack: + - "d1-ff-00" + - "d2-ff-ff-ff-00" + - "d3-ff-ff-ff-ff-ff-ff-ff-00" + +# 0xFFFF8000 +- number: -32768 + msgpack: + - "d1-80-00" + - "d2-ff-ff-80-00" + - "d3-ff-ff-ff-ff-ff-ff-80-00" + +# 0xFFFF0000 +- number: -65536 + msgpack: + - "d2-ff-ff-00-00" + - "d3-ff-ff-ff-ff-ff-ff-00-00" + +# 0x80000000 +- number: -2147483648 + msgpack: + - "d2-80-00-00-00" + - "d3-ff-ff-ff-ff-80-00-00-00" + - "cb-c1-e0-00-00-00-00-00-00" diff --git a/msgpack/test/data/22.number-float.yaml b/msgpack/test/data/22.number-float.yaml new file mode 100644 index 0000000..8b06ed3 --- /dev/null +++ b/msgpack/test/data/22.number-float.yaml @@ -0,0 +1,15 @@ +# number-float +# +# decimal fraction + +# +0.5 +- number: 0.5 + msgpack: + - "ca-3f-00-00-00" + - "cb-3f-e0-00-00-00-00-00-00" + +# -0.5 +- number: -0.5 + msgpack: + - "ca-bf-00-00-00" + - "cb-bf-e0-00-00-00-00-00-00" diff --git a/msgpack/test/data/23.number-bignum.yaml b/msgpack/test/data/23.number-bignum.yaml new file mode 100644 index 0000000..cdd5024 --- /dev/null +++ b/msgpack/test/data/23.number-bignum.yaml @@ -0,0 +1,64 @@ +# number-bignum +# +# 64bit integer + +# +0x0000000100000000 = +4294967296 +- number: 4294967296 + bignum: "4294967296" + msgpack: + - "cf-00-00-00-01-00-00-00-00" # unsigned int64 + - "d3-00-00-00-01-00-00-00-00" # signed int64 + - "ca-4f-80-00-00" # float + - "cb-41-f0-00-00-00-00-00-00" # double + +# -0x0000000100000000 = -4294967296 +- number: -4294967296 + bignum: "-4294967296" + msgpack: + - "d3-ff-ff-ff-ff-00-00-00-00" # signed int64 + - "cb-c1-f0-00-00-00-00-00-00" # double + +# +0x0001000000000000 = +281474976710656 +- number: 281474976710656 + bignum: "281474976710656" + msgpack: + - "cf-00-01-00-00-00-00-00-00" # unsigned int64 + - "d3-00-01-00-00-00-00-00-00" # signed int64 + - "ca-57-80-00-00" # float + - "cb-42-f0-00-00-00-00-00-00" # double + +# -0x0001000000000000 = -281474976710656 +- number: -281474976710656 + bignum: "-281474976710656" + msgpack: + - "d3-ff-ff-00-00-00-00-00-00" # signed int64 + - "ca-d7-80-00-00" # float + - "cb-c2-f0-00-00-00-00-00-00" # double + +# JSON could not hold big numbers below + +# +0x7FFFFFFFFFFFFFFF = +9223372036854775807 +- bignum: "9223372036854775807" + msgpack: + - "d3-7f-ff-ff-ff-ff-ff-ff-ff" # signed int64 + - "cf-7f-ff-ff-ff-ff-ff-ff-ff" # unsigned int64 + +# -0x7FFFFFFFFFFFFFFF = -9223372036854775807 +- bignum: "-9223372036854775807" + msgpack: + - "d3-80-00-00-00-00-00-00-01" # signed int64 + +# +0x8000000000000000 = +9223372036854775808 +- bignum: "9223372036854775808" + msgpack: + - "cf-80-00-00-00-00-00-00-00" # unsigned int64 + +# -0x8000000000000000 = -9223372036854775808 +- bignum: "-9223372036854775808" + msgpack: + - "d3-80-00-00-00-00-00-00-00" # signed int64 + +# +0xFFFFFFFFFFFFFFFF = +18446744073709551615 +- bignum: "18446744073709551615" + msgpack: + - "cf-ff-ff-ff-ff-ff-ff-ff-ff" # unsigned int64 diff --git a/msgpack/test/data/30.string-ascii.yaml b/msgpack/test/data/30.string-ascii.yaml new file mode 100644 index 0000000..52aecf5 --- /dev/null +++ b/msgpack/test/data/30.string-ascii.yaml @@ -0,0 +1,30 @@ +# string-ascii + +# '' // empty string +- string: "" + msgpack: + - "a0" + - "d9-00" + - "da-00-00" + - "db-00-00-00-00" + +# "a" +- string: "a" + msgpack: + - "a1-61" + - "d9-01-61" + - "da-00-01-61" + - "db-00-00-00-01-61" + +# "1234567890123456789012345678901" +- string: "1234567890123456789012345678901" + msgpack: + - "bf-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31" + - "d9-1f-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31" + - "da-00-1f-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31" + +# "12345678901234567890123456789012" +- string: "12345678901234567890123456789012" + msgpack: + - "d9-20-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32" + - "da-00-20-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32" diff --git a/msgpack/test/data/31.string-utf8.yaml b/msgpack/test/data/31.string-utf8.yaml new file mode 100644 index 0000000..266983a --- /dev/null +++ b/msgpack/test/data/31.string-utf8.yaml @@ -0,0 +1,31 @@ +# string-utf8 + +# "Кириллица" // Russian Cyrillic alphabet +- string: "Кириллица" + msgpack: + - "b2-d0-9a-d0-b8-d1-80-d0-b8-d0-bb-d0-bb-d0-b8-d1-86-d0-b0" + - "d9-12-d0-9a-d0-b8-d1-80-d0-b8-d0-bb-d0-bb-d0-b8-d1-86-d0-b0" + +# "ひらがな" // Japanese Hiragana character +- string: "ひらがな" + msgpack: + - "ac-e3-81-b2-e3-82-89-e3-81-8c-e3-81-aa" + - "d9-0c-e3-81-b2-e3-82-89-e3-81-8c-e3-81-aa" + +# "한글" // Korean Hangul character +- string: "한글" + msgpack: + - "a6-ed-95-9c-ea-b8-80" + - "d9-06-ed-95-9c-ea-b8-80" + +# "汉字" // Simplified Chinese character +- string: "汉字" + msgpack: + - "a6-e6-b1-89-e5-ad-97" + - "d9-06-e6-b1-89-e5-ad-97" + +# "漢字" // Traditional Chinese character +- string: "漢字" + msgpack: + - "a6-e6-bc-a2-e5-ad-97" + - "d9-06-e6-bc-a2-e5-ad-97" diff --git a/msgpack/test/data/32.string-emoji.yaml b/msgpack/test/data/32.string-emoji.yaml new file mode 100644 index 0000000..5daa8c2 --- /dev/null +++ b/msgpack/test/data/32.string-emoji.yaml @@ -0,0 +1,13 @@ +# string-emoji + +# "❤" // U+2764 HEAVY BLACK HEART +- string: "❤" + msgpack: + - "a3-e2-9d-a4" + - "d9-03-e2-9d-a4" + +# "🍺" // U+1F37A BEER MUG +- string: "🍺" + msgpack: + - "a4-f0-9f-8d-ba" + - "d9-04-f0-9f-8d-ba" diff --git a/msgpack/test/data/40.array.yaml b/msgpack/test/data/40.array.yaml new file mode 100644 index 0000000..918c7ff --- /dev/null +++ b/msgpack/test/data/40.array.yaml @@ -0,0 +1,35 @@ +# array + +# [] // empty +- array: [] + msgpack: + - "90" + - "dc-00-00" + - "dd-00-00-00-00" + +# [1] +- array: [1] + msgpack: + - "91-01" + - "dc-00-01-01" + - "dd-00-00-00-01-01" + +# [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] +- array: [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + msgpack: + - "9f-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f" + - "dc-00-0f-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f" + - "dd-00-00-00-0f-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f" + +# [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16] +- array: [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16] + msgpack: + - "dc-00-10-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f-10" + - "dd-00-00-00-10-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f-10" + +# ['a'] +- array: ["a"] + msgpack: + - "91-a1-61" + - "dc-00-01-a1-61" + - "dd-00-00-00-01-a1-61" diff --git a/msgpack/test/data/41.map.yaml b/msgpack/test/data/41.map.yaml new file mode 100644 index 0000000..e6762e5 --- /dev/null +++ b/msgpack/test/data/41.map.yaml @@ -0,0 +1,22 @@ +# map + +# {} // empty +- map: {} + msgpack: + - "80" + - "de-00-00" + - "df-00-00-00-00" + +# {a: 1} +- map: {"a": 1} + msgpack: + - "81-a1-61-01" + - "de-00-01-a1-61-01" + - "df-00-00-00-01-a1-61-01" + +# {a: 'A'} +- map: {"a": "A"} + msgpack: + - "81-a1-61-a1-41" + - "de-00-01-a1-61-a1-41" + - "df-00-00-00-01-a1-61-a1-41" diff --git a/msgpack/test/data/42.nested.yaml b/msgpack/test/data/42.nested.yaml new file mode 100644 index 0000000..c5dbe16 --- /dev/null +++ b/msgpack/test/data/42.nested.yaml @@ -0,0 +1,29 @@ +# nested + +# array of array +- array: [[]] + msgpack: + - "91-90" + - "dc-00-01-dc-00-00" + - "dd-00-00-00-01-dd-00-00-00-00" + +# array of map +- array: [{}] + msgpack: + - "91-80" + - "dc-00-01-80" + - "dd-00-00-00-01-80" + +# map of map +- map: {"a": {}} + msgpack: + - "81-a1-61-80" + - "de-00-01-a1-61-de-00-00" + - "df-00-00-00-01-a1-61-df-00-00-00-00" + +# map of array +- map: {"a": []} + msgpack: + - "81-a1-61-90" + - "de-00-01-a1-61-90" + - "df-00-00-00-01-a1-61-90" diff --git a/msgpack/test/data/50.timestamp.yaml b/msgpack/test/data/50.timestamp.yaml new file mode 100644 index 0000000..7abbb9e --- /dev/null +++ b/msgpack/test/data/50.timestamp.yaml @@ -0,0 +1,98 @@ +# timestamp +# +# nanoseconds between 0000-00-00 and 9999-12-31 + +# 2018-01-02T03:04:05.000000000Z +- timestamp: [1514862245, 0] + msgpack: + - "d6-ff-5a-4a-f6-a5" + +# 2018-01-02T03:04:05.678901234Z +- timestamp: [1514862245, 678901234] + msgpack: + - "d7-ff-a1-dc-d7-c8-5a-4a-f6-a5" + +# 2038-01-19T03:14:07.999999999Z +- timestamp: [2147483647, 999999999] + msgpack: + - "d7-ff-ee-6b-27-fc-7f-ff-ff-ff" + +# 2038-01-19T03:14:08.000000000Z +- timestamp: [2147483648, 0] + msgpack: + - "d6-ff-80-00-00-00" + +# 2038-01-19T03:14:08.000000001Z +- timestamp: [2147483648, 1] + msgpack: + - "d7-ff-00-00-00-04-80-00-00-00" + +# 2106-02-07T06:28:15.000000000Z +- timestamp: [4294967295, 0] + msgpack: + - "d6-ff-ff-ff-ff-ff" + +# 2106-02-07T06:28:15.999999999Z +- timestamp: [4294967295, 999999999] + msgpack: + - "d7-ff-ee-6b-27-fc-ff-ff-ff-ff" + +# 2106-02-07T06:28:16.000000000Z +- timestamp: [4294967296, 0] + msgpack: + - "d7-ff-00-00-00-01-00-00-00-00" + +# 2514-05-30T01:53:03.999999999Z +- timestamp: [17179869183, 999999999] + msgpack: + - "d7-ff-ee-6b-27-ff-ff-ff-ff-ff" + +# 2514-05-30T01:53:04.000000000Z +- timestamp: [17179869184, 0] + msgpack: + - "c7-0c-ff-00-00-00-00-00-00-00-04-00-00-00-00" + +# 1969-12-31T23:59:59.000000000Z +- timestamp: [-1, 0] + msgpack: + - "c7-0c-ff-00-00-00-00-ff-ff-ff-ff-ff-ff-ff-ff" + +# 1969-12-31T23:59:59.999999999Z +- timestamp: [-1, 999999999] + msgpack: + - "c7-0c-ff-3b-9a-c9-ff-ff-ff-ff-ff-ff-ff-ff-ff" + +# 1970-01-01T00:00:00.000000000Z +- timestamp: [0, 0] + msgpack: + - "d6-ff-00-00-00-00" + +# 1970-01-01T00:00:00.000000001Z +- timestamp: [0, 1] + msgpack: + - "d7-ff-00-00-00-04-00-00-00-00" + +# 1970-01-01T00:00:01.000000000Z +- timestamp: [1, 0] + msgpack: + - "d6-ff-00-00-00-01" + +# 1899-12-31T23:59:59.999999999Z +- timestamp: [-2208988801, 999999999] + msgpack: + - "c7-0c-ff-3b-9a-c9-ff-ff-ff-ff-ff-7c-55-81-7f" + +# 1900-01-01T00:00:00.000000000Z +- timestamp: [-2208988800, 0] + msgpack: + - "c7-0c-ff-00-00-00-00-ff-ff-ff-ff-7c-55-81-80" + +# 0000-01-01T00:00:00.000000000Z +- timestamp: [-62167219200, 0] + msgpack: + - "c7-0c-ff-00-00-00-00-ff-ff-ff-f1-86-8b-84-00" + +# 9999-12-31T23:59:59.999999999Z +- timestamp: [253402300799, 999999999] + msgpack: + - "c7-0c-ff-3b-9a-c9-ff-00-00-00-3a-ff-f4-41-7f" diff --git a/msgpack/test/data/60.ext.yaml b/msgpack/test/data/60.ext.yaml new file mode 100644 index 0000000..3f1f835 --- /dev/null +++ b/msgpack/test/data/60.ext.yaml @@ -0,0 +1,40 @@ +# ext + +# fixext 1 +- ext: [1, "10"] + msgpack: + - "d4-01-10" + +# fixext 2 +- ext: [2, "20-21"] + msgpack: + - "d5-02-20-21" + +# fixext 4 +- ext: [3, "30-31-32-33"] + msgpack: + - "d6-03-30-31-32-33" + +# fixext 8 +- ext: [4, "40-41-42-43-44-45-46-47"] + msgpack: + - "d7-04-40-41-42-43-44-45-46-47" + +# fixext 16 +- ext: [5, "50-51-52-53-54-55-56-57-58-59-5a-5b-5c-5d-5e-5f"] + msgpack: + - "d8-05-50-51-52-53-54-55-56-57-58-59-5a-5b-5c-5d-5e-5f" + +# ext size=0 +- ext: [6, ""] + msgpack: + - "c7-00-06" # ext 8 + - "c8-00-00-06" # ext 16 + - "c9-00-00-00-00-06" # ext 32 + +# ext size=3 +- ext: [7, "70-71-72"] + msgpack: + - "c7-03-07-70-71-72" # ext 8 + - "c8-00-03-07-70-71-72" # ext 16 + - "c9-00-00-00-03-07-70-71-72" # ext 32 diff --git a/msgpack/test/data/README.md b/msgpack/test/data/README.md new file mode 100644 index 0000000..24a0f44 --- /dev/null +++ b/msgpack/test/data/README.md @@ -0,0 +1,31 @@ +The test datasets in this folder have been downloaded from + +https://github.com/kawanet/msgpack-test-suite + +(version 1.0.0 / e04f6edeaae589c768d6b70fcce80aa786b7800e) + +and are subject to the license below + +``` +MIT License + +Copyright (c) 2017-2018 Yusuke Kawasaki + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. +``` diff --git a/msgpack/test/test.hs b/msgpack/test/test.hs index f6d62f2..159ea6f 100644 --- a/msgpack/test/test.hs +++ b/msgpack/test/test.hs @@ -1,64 +1,28 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Main (main) where -import Control.Applicative -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Maybe -import Data.MessagePack -import Test.QuickCheck import Test.Tasty -import Test.Tasty.QuickCheck - -main :: IO () -main = defaultMain tests - -instance Arbitrary a => Arbitrary (Assoc a) where - arbitrary = Assoc <$> arbitrary -instance Arbitrary S.ByteString where - arbitrary = S.pack <$> arbitrary +import DataCases +import Properties -instance Arbitrary L.ByteString where - arbitrary = L.pack <$> arbitrary - -mid :: MessagePack a => a -> a -mid = fromJust . unpack . pack - -tests :: TestTree -tests = - testGroup "Identity Properties" - [ testProperty "int" $ - \(a :: Int) -> a == mid a - , testProperty "nil" $ - \(a :: ()) -> a == mid a - , testProperty "bool" $ - \(a :: Bool) -> a == mid a - , testProperty "double" $ - \(a :: Double) -> a == mid a - , testProperty "string" $ - \(a :: String) -> a == mid a - , testProperty "bytestring" $ - \(a :: S.ByteString) -> a == mid a - , testProperty "lazy-bytestring" $ - \(a :: L.ByteString) -> a == mid a - , testProperty "[int]" $ - \(a :: [Int]) -> a == mid a - , testProperty "[string]" $ - \(a :: [String]) -> a == mid a - , testProperty "(int, int)" $ - \(a :: (Int, Int)) -> a == mid a - , testProperty "(int, int, int)" $ - \(a :: (Int, Int, Int)) -> a == mid a - , testProperty "(int, int, int, int)" $ - \(a :: (Int, Int, Int, Int)) -> a == mid a - , testProperty "(int, int, int, int, int)" $ - \(a :: (Int, Int, Int, Int, Int)) -> a == mid a - , testProperty "[(int, double)]" $ - \(a :: [(Int, Double)]) -> a == mid a - , testProperty "[(string, string)]" $ - \(a :: [(String, String)]) -> a == mid a - , testProperty "Assoc [(string, int)]" $ - \(a :: Assoc [(String, Int)]) -> a == mid a +main :: IO () +main = do + testDataCases <- genDataCases + [ "10.nil" + , "11.bool" + , "12.binary" + , "20.number-positive" + , "21.number-negative" + , "22.number-float" + , "23.number-bignum" + , "30.string-ascii" + , "31.string-utf8" + , "32.string-emoji" + , "40.array" + , "41.map" + , "42.nested" + , "50.timestamp" + , "60.ext" ] + + defaultMain (testGroup "Tests" [ idPropTests, testDataCases ])