From 8073fb1e5d3014531ec5e5e5ec287ed59a6bed38 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Mon, 23 Mar 2015 03:32:37 +0900 Subject: [PATCH 01/75] add aeson bridge --- .gitignore | 2 + msgpack-aeson/LICENSE | 30 +++++++++++++ msgpack-aeson/Setup.hs | 2 + msgpack-aeson/msgpack-aeson.cabal | 32 +++++++++++++ msgpack-aeson/src/Data/MessagePack/Aeson.hs | 50 +++++++++++++++++++++ msgpack-rpc/test/test.hs | 4 +- 6 files changed, 118 insertions(+), 2 deletions(-) create mode 100644 msgpack-aeson/LICENSE create mode 100644 msgpack-aeson/Setup.hs create mode 100644 msgpack-aeson/msgpack-aeson.cabal create mode 100644 msgpack-aeson/src/Data/MessagePack/Aeson.hs diff --git a/.gitignore b/.gitignore index 4460397..ef42924 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,5 @@ tmp/ /msgpack/cabal.sandbox.config /msgpack-rpc/.cabal-sandbox/ /msgpack-rpc/cabal.sandbox.config +/msgpack-aeson/cabal.sandbox.config +/msgpack-aeson/.cabal-sandbox/ 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..51bc7d7 --- /dev/null +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -0,0 +1,32 @@ +-- Initial msgpack-aeson.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: msgpack-aeson +version: 0.1.0.0 +synopsis: Aeson adapter for MessagePack +description: Aeson adapter for MessagePack +homepage: http://msgpack.org/ +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: tanaka.hideyuki@gmail.com +copyright: (c) 2015 Hideyuki Tanaka +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.MessagePack.Aeson + -- other-modules: + -- other-extensions: + build-depends: aeson >=0.8 + , base >=4.7 && <5 + , bytestring >= 0.10 + , msgpack >=0.8 + , scientific >= 0.3 + , text >= 1.2 + , unordered-containers >= 0.2 + , vector >= 0.10 + hs-source-dirs: src + 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..8a38bc7 --- /dev/null +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +-- | Aeson adapter for MessagePack + +module Data.MessagePack.Aeson ( + ) where + +import Control.Applicative +import Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as L +import Data.Either +import qualified Data.HashMap.Strict as HM +import Data.MessagePack as MP +import Data.Scientific +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V + +fromMP :: MP.Object -> Maybe Value +fromMP = \case + ObjectNil -> Just $ Null + ObjectBool b -> Just $ Bool b + ObjectInt n -> Just $ Number $ fromIntegral n + ObjectFloat f -> Just $ Number $ realToFrac f + ObjectDouble d -> Just $ Number $ realToFrac d + ObjectRAW b -> String <$> either (const Nothing) Just (T.decodeUtf8' b) + ObjectArray v -> Array <$> V.mapM fromMP v + ObjectMap m -> + Aeson.Object . HM.fromList . V.toList + <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromMP v) m + +toMP :: Value -> MP.Object +toMP = \case + Aeson.Object o -> ObjectMap $ V.fromList $ map (\(k, v) -> (toObject k, toMP v)) $ HM.toList o + Array v -> ObjectArray $ V.map toMP v + String t -> ObjectRAW $ T.encodeUtf8 t + Number s -> + case floatingOrInteger s of + Left f -> ObjectDouble f + Right n -> ObjectInt n + Bool b -> ObjectBool b + Null -> ObjectNil + +newtype AsAeson = AsAeson { getAsAeson :: MP.Object } + +unpackMP :: FromJSON a => L.ByteString -> a +unpackMP = undefined + +packMP :: ToJSON a => a -> L.ByteString +packMP = undefined diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/test.hs index 0dd5263..3324721 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -15,8 +15,8 @@ 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 = From 8ad9ede5f75577a18b8e65d10cc7d320fc9472e9 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Mon, 23 Mar 2015 17:18:23 +0900 Subject: [PATCH 02/75] add some functions --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 101 +++++++++++++++----- 1 file changed, 77 insertions(+), 24 deletions(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index 8a38bc7..77d201f 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -1,50 +1,103 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} --- | Aeson adapter for MessagePack +-- | Aeson bridge for MessagePack module Data.MessagePack.Aeson ( + -- * Conversion functions + toAeson, fromAeson, + + -- * MessagePack instance for Aeson.Value + -- * ToJSON, FromJSON instance for MessagePack.Object + + -- * Wrapper instances + AsMessagePack(..), + AsAeson(..), + + -- * Utility functions + packAeson, unpackAeson, + decodeMessagePack, encodeMessagePack, ) where import Control.Applicative -import Data.Aeson as Aeson +import Data.Aeson as A import qualified Data.ByteString.Lazy as L import Data.Either import qualified Data.HashMap.Strict as HM +import Data.Maybe import Data.MessagePack as MP +import Data.Monoid import Data.Scientific import qualified Data.Text.Encoding as T import qualified Data.Vector as V -fromMP :: MP.Object -> Maybe Value -fromMP = \case +toAeson :: MP.Object -> Maybe Value +toAeson = \case ObjectNil -> Just $ Null ObjectBool b -> Just $ Bool b ObjectInt n -> Just $ Number $ fromIntegral n ObjectFloat f -> Just $ Number $ realToFrac f ObjectDouble d -> Just $ Number $ realToFrac d ObjectRAW b -> String <$> either (const Nothing) Just (T.decodeUtf8' b) - ObjectArray v -> Array <$> V.mapM fromMP v + ObjectArray v -> Array <$> V.mapM toAeson v ObjectMap m -> - Aeson.Object . HM.fromList . V.toList - <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromMP v) m - -toMP :: Value -> MP.Object -toMP = \case - Aeson.Object o -> ObjectMap $ V.fromList $ map (\(k, v) -> (toObject k, toMP v)) $ HM.toList o - Array v -> ObjectArray $ V.map toMP v - String t -> ObjectRAW $ T.encodeUtf8 t + A.Object . HM.fromList . V.toList + <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> toAeson v) m + +fromAeson :: Value -> MP.Object +fromAeson = \case + Null -> ObjectNil + Bool b -> ObjectBool b Number s -> case floatingOrInteger s of - Left f -> ObjectDouble f - Right n -> ObjectInt n - Bool b -> ObjectBool b - Null -> ObjectNil + Left f -> ObjectDouble f + Right n -> ObjectInt n + String t -> ObjectRAW $ T.encodeUtf8 t + Array v -> ObjectArray $ V.map fromAeson v + A.Object o -> ObjectMap $ V.fromList $ map (\(k, v) -> (toObject k, fromAeson v)) $ HM.toList o + +instance MessagePack Value where + fromObject = toAeson + toObject = fromAeson + +instance ToJSON MP.Object where + -- | When fail to convert, it returns `Null` + toJSON = fromMaybe Null .toAeson + +instance FromJSON MP.Object where + parseJSON = return . fromAeson + +newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } + +instance (FromJSON a, ToJSON a) => MessagePack (AsMessagePack a) where + fromObject o = AsMessagePack <$> (fromJSON' =<< toAeson o) + toObject = fromAeson . toJSON . getAsMessagePack + +newtype AsAeson a = AsAeson { getAsAeson :: a } + +instance MessagePack a => ToJSON (AsAeson a) where + toJSON = fromMaybe Null . toAeson . toObject . getAsAeson + +instance MessagePack a => FromJSON (AsAeson a) where + parseJSON = maybe empty (return . AsAeson) . fromObject . fromAeson + +-- | pack Aeson value to msgpack binary +packAeson :: ToJSON a => a -> L.ByteString +packAeson = pack . toJSON + +-- | unpack Aeson value from msgpack binary +unpackAeson :: FromJSON a => L.ByteString -> Maybe a +unpackAeson b = fromJSON' =<< unpack b + +encodeMessagePack :: MessagePack a => a -> L.ByteString +encodeMessagePack = encode . toJSON . AsAeson -newtype AsAeson = AsAeson { getAsAeson :: MP.Object } +decodeMessagePack :: MessagePack a => L.ByteString -> Maybe a +decodeMessagePack b = getAsAeson <$> (fromJSON' =<< decode b) -unpackMP :: FromJSON a => L.ByteString -> a -unpackMP = undefined +fromJSON' :: FromJSON a => Value -> Maybe a +fromJSON' = resultToMaybe . fromJSON -packMP :: ToJSON a => a -> L.ByteString -packMP = undefined +resultToMaybe :: Result a -> Maybe a +resultToMaybe = \case + Success a -> Just a + _ -> Nothing From 8d9f431147cc8a25f29ce54bd997185cbc4dcb84 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Tue, 24 Mar 2015 17:10:30 +0900 Subject: [PATCH 03/75] fix receiving msgpack objects --- .../src/Network/MessagePackRpc/Client.hs | 29 +++++++++++-------- .../src/Network/MessagePackRpc/Server.hs | 11 ++++--- 2 files changed, 24 insertions(+), 16 deletions(-) diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Client.hs b/msgpack-rpc/src/Network/MessagePackRpc/Client.hs index 6801ce7..77f7cdb 100644 --- a/msgpack-rpc/src/Network/MessagePackRpc/Client.hs +++ b/msgpack-rpc/src/Network/MessagePackRpc/Client.hs @@ -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 } @@ -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 + Nothing -> throwM $ ProtocolError "invalid response data" + Just (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 + Nothing -> throwM $ ServerError rerror + Just () -> return rresult -- | Call an RPC Method call :: RpcType a diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs b/msgpack-rpc/src/Network/MessagePackRpc/Server.hs index 0f82607..d6397e0 100644 --- a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs +++ b/msgpack-rpc/src/Network/MessagePackRpc/Server.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, Rank2Types #-} ------------------------------------------------------------------- -- | @@ -81,12 +81,15 @@ serve :: Int -- ^ Port number -> IO () serve port methods = runTCPServer (serverSettings port "*") $ \ad -> do (rsrc, _) <- appSource ad $$+ return () - processRequests rsrc (appSink ad) + _ <- try $ processRequests rsrc (appSink ad) :: IO (Either ParseError ()) + return () where processRequests rsrc sink = do (rsrc', res) <- rsrc $$++ do - req <- sinkGet get - lift $ getResponse req + obj <- sinkGet get + case fromObject obj of + Nothing -> throwM $ ServerError "invalid request" + Just req -> lift $ getResponse req _ <- CB.sourceLbs (pack res) $$ sink processRequests rsrc' sink From 304421c85db29018b5a2c372dd39a64bdb942437 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 27 Mar 2015 17:06:07 +0900 Subject: [PATCH 04/75] move user data example to msgpack-aeson --- msgpack-aeson/msgpack-aeson.cabal | 14 ++++++ msgpack-aeson/src/Data/MessagePack/Aeson.hs | 11 +++-- msgpack-aeson/test/test.hs | 53 +++++++++++++++++++++ msgpack/test/Monad.hs | 21 -------- msgpack/test/UserData.hs | 53 --------------------- 5 files changed, 75 insertions(+), 77 deletions(-) create mode 100644 msgpack-aeson/test/test.hs delete mode 100644 msgpack/test/Monad.hs delete mode 100644 msgpack/test/UserData.hs diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index 51bc7d7..1584bdf 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -28,5 +28,19 @@ library , text >= 1.2 , unordered-containers >= 0.2 , vector >= 0.10 + , deepseq hs-source-dirs: src default-language: Haskell2010 + + +test-suite msgpack-aeson-test + type: exitcode-stdio-1.0 + main-is: test.hs + + build-depends: base + , msgpack + , aeson + , msgpack-aeson + + hs-source-dirs: test + default-language: Haskell2010 diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index 77d201f..c678c4c 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveDataTypeable #-} -- | Aeson bridge for MessagePack @@ -29,10 +29,13 @@ import Data.Monoid import Data.Scientific import qualified Data.Text.Encoding as T import qualified Data.Vector as V +import Data.Data +import Control.DeepSeq +import Control.Arrow toAeson :: MP.Object -> Maybe Value toAeson = \case - ObjectNil -> Just $ Null + ObjectNil -> Just Null ObjectBool b -> Just $ Bool b ObjectInt n -> Just $ Number $ fromIntegral n ObjectFloat f -> Just $ Number $ realToFrac f @@ -53,7 +56,7 @@ fromAeson = \case Right n -> ObjectInt n String t -> ObjectRAW $ T.encodeUtf8 t Array v -> ObjectArray $ V.map fromAeson v - A.Object o -> ObjectMap $ V.fromList $ map (\(k, v) -> (toObject k, fromAeson v)) $ HM.toList o + A.Object o -> ObjectMap $ V.fromList $ map (toObject *** fromAeson) $ HM.toList o instance MessagePack Value where fromObject = toAeson @@ -67,12 +70,14 @@ instance FromJSON MP.Object where parseJSON = return . fromAeson 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 <$> (fromJSON' =<< toAeson o) toObject = fromAeson . toJSON . getAsMessagePack newtype AsAeson a = AsAeson { getAsAeson :: a } + deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) instance MessagePack a => ToJSON (AsAeson a) where toJSON = fromMaybe Null . toAeson . toObject . getAsAeson diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs new file mode 100644 index 0000000..940b8b3 --- /dev/null +++ b/msgpack-aeson/test/test.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings, ViewPatterns, ScopedTypeVariables, TemplateHaskell #-} + +import Data.MessagePack +import Data.MessagePack.Aeson +import Data.Aeson.TH + +data T + = A Int String + | B Double + deriving (Show, Eq) + +deriveJSON defaultOptions ''T + +data U + = C { c1 :: Int, c2 :: String } + | D { z1 :: Double } + deriving (Show, Eq) + +deriveJSON defaultOptions ''U + +data V + = E String | F + deriving (Show, Eq) + +deriveJSON defaultOptions ''V + +data W a + = G a String + | H { hHoge :: Int, h_age :: a } + deriving (Show, Eq) + +deriveJSON defaultOptions ''W + +test :: (MessagePack a, Show a, Eq a) => a -> IO () +test v = do + let bs = pack v + print bs + print (unpack bs == Just v) + + let oa = toObject v + print oa + print (fromObject oa == Just v) + +main :: IO () +main = do + test $ AsMessagePack $ A 123 "hoge" + test $ AsMessagePack $ B 3.14 + test $ AsMessagePack $ C 123 "hoge" + test $ AsMessagePack $ D 3.14 + test $ AsMessagePack $ E "hello" + test $ AsMessagePack F + test $ AsMessagePack $ G (E "hello") "world" + test $ AsMessagePack $ H 123 F 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/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 () From e5ad2f6d550fc943f0ea6575755a0c2cf1014b2f Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sat, 28 Mar 2015 15:43:01 +0900 Subject: [PATCH 05/75] remove OverlappingInstances --- msgpack/src/Data/MessagePack/Object.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 13c2037..9a46ef3 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeSynonymInstances #-} From a63f58b42dc043f9d8b4da9c463a5aa28a6ec5af Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sat, 28 Mar 2015 17:01:42 +0900 Subject: [PATCH 06/75] support recent msgpack spec --- msgpack/src/Data/MessagePack/Get.hs | 35 ++++++++++++-- msgpack/src/Data/MessagePack/Object.hs | 67 ++++++++++++++++---------- msgpack/src/Data/MessagePack/Put.hs | 38 +++++++++++++-- 3 files changed, 108 insertions(+), 32 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 8b8d735..2e36b9b 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -16,7 +16,7 @@ module Data.MessagePack.Get( getNil, getBool, getInt, getFloat, getDouble, - getRAW, getArray, getMap, + getStr, getBin, getArray, getMap, getExt, ) where import Control.Applicative @@ -27,6 +27,8 @@ import Data.Binary.IEEE754 import Data.Bits import qualified Data.ByteString as S import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Vector as V getNil :: Get () @@ -60,14 +62,27 @@ getFloat = tag 0xCA >> getFloat32be getDouble :: Get Double getDouble = tag 0xCB >> getFloat64be -getRAW :: Get S.ByteString -getRAW = do +getStr :: Get T.Text +getStr = do len <- getWord8 >>= \case t | t .&. 0xE0 == 0xA0 -> return $ fromIntegral $ t .&. 0x1F + 0xD9 -> fromIntegral <$> getWord8 0xDA -> fromIntegral <$> getWord16be 0xDB -> fromIntegral <$> getWord32be _ -> empty + bs <- getByteString len + case T.decodeUtf8' bs of + Left _ -> empty + Right v -> return v + +getBin :: Get S.ByteString +getBin = do + len <- getWord8 >>= \case + 0xC4 -> fromIntegral <$> getWord8 + 0xC5 -> fromIntegral <$> getWord16be + 0xC6 -> fromIntegral <$> getWord32be + _ -> empty getByteString len getArray :: Get a -> Get (V.Vector a) @@ -90,6 +105,20 @@ getMap k v = do _ -> empty V.replicateM len $ (,) <$> k <*> v +getExt :: Get (Word8, S.ByteString) +getExt = do + len <- getWord8 >>= \case + 0xD4 -> return 1 + 0xD5 -> return 2 + 0xD6 -> return 4 + 0xD7 -> return 8 + 0xD8 -> return 16 + 0xC7 -> fromIntegral <$> getWord8 + 0xC8 -> fromIntegral <$> getWord16be + 0xC9 -> fromIntegral <$> getWord32be + _ -> empty + (,) <$> getWord8 <*> getByteString len + getInt8 :: Get Int8 getInt8 = fromIntegral <$> getWord8 diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 9a46ef3..824e65b 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -31,34 +31,46 @@ import Control.Applicative import Control.Arrow import Control.DeepSeq import Data.Binary -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L +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.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.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.Put +import Prelude hiding (putStr) + -- | Object Representation of MessagePack data. data Object = ObjectNil + -- ^ represents nil | ObjectBool !Bool + -- ^ represents true or false | ObjectInt {-# UNPACK #-} !Int + -- ^ represents an integer | ObjectFloat {-# UNPACK #-} !Float + -- ^ represents a floating point number | ObjectDouble {-# UNPACK #-} !Double - | ObjectRAW !S.ByteString + -- ^ represents a floating point number + | ObjectStr !T.Text + -- ^ extending Raw type represents a UTF-8 string + | ObjectBin !S.ByteString + -- ^ extending Raw type represents a byte array | ObjectArray !(V.Vector Object) + -- ^ represents a sequence of objects | ObjectMap !(V.Vector (Object, Object)) + -- ^ represents key-value pairs of objects + | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString + -- ^ represents a tuple of an integer and a byte array where + -- the integer represents type information and the byte array represents data. deriving (Show, Eq, Ord, Typeable) instance NFData Object where @@ -74,9 +86,11 @@ getObject = <|> ObjectInt <$> getInt <|> ObjectFloat <$> getFloat <|> ObjectDouble <$> getDouble - <|> ObjectRAW <$> getRAW + <|> ObjectStr <$> getStr + <|> ObjectBin <$> getBin <|> ObjectArray <$> getArray getObject <|> ObjectMap <$> getMap getObject getObject + <|> uncurry ObjectExt <$> getExt putObject :: Object -> Put putObject = \case @@ -85,9 +99,11 @@ putObject = \case ObjectInt n -> putInt 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 instance Binary Object where get = getObject @@ -138,15 +154,15 @@ instance MessagePack Double where _ -> Nothing instance MessagePack S.ByteString where - toObject = ObjectRAW + toObject = ObjectBin fromObject = \case - ObjectRAW r -> Just r + ObjectBin r -> Just r _ -> Nothing -- 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 + fromObject obj = T.unpack <$> fromObject obj instance MessagePack a => MessagePack (V.Vector a) where toObject = ObjectArray . V.map toObject @@ -178,19 +194,18 @@ instance MessagePack a => MessagePack (Maybe a) where -- UTF8 string like instance MessagePack L.ByteString where - toObject = ObjectRAW . L.toStrict + toObject = ObjectBin . L.toStrict fromObject obj = L.fromStrict <$> fromObject obj instance MessagePack T.Text where - toObject = toObject . T.encodeUtf8 - fromObject obj = T.decodeUtf8With skipChar <$> fromObject obj + toObject = ObjectStr + fromObject = \case + ObjectStr s -> Just s + _ -> Nothing 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 + fromObject obj = LT.fromStrict <$> fromObject obj -- array like diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 7879aec..321e58d 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -14,7 +14,7 @@ module Data.MessagePack.Put ( putNil, putBool, putInt, putFloat, putDouble, - putRAW, putArray, putMap, + putStr, putBin, putArray, putMap, putExt, ) where import Data.Binary @@ -22,8 +22,12 @@ import Data.Binary.IEEE754 import Data.Binary.Put import Data.Bits 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 Prelude hiding (putStr) + putNil :: Put putNil = putWord8 0xC0 @@ -62,17 +66,31 @@ putDouble d = do putWord8 0xCB putFloat64be d -putRAW :: S.ByteString -> Put -putRAW bs = do +putStr :: T.Text -> Put +putStr t = do + let bs = T.encodeUtf8 t case S.length bs of len | len <= 31 -> putWord8 $ 0xA0 .|. fromIntegral len + | len < 0x100 -> + putWord8 0xD9 >> putWord8 (fromIntegral len) | len < 0x10000 -> putWord8 0xDA >> putWord16be (fromIntegral len) | otherwise -> putWord8 0xDB >> putWord32be (fromIntegral len) putByteString bs +putBin :: S.ByteString -> Put +putBin bs = do + case S.length bs of + len | len < 0x100 -> + putWord8 0xC4 >> putWord8 (fromIntegral len) + | len < 0x10000 -> + putWord8 0xC5 >> putWord16be (fromIntegral len) + | otherwise -> + putWord8 0xC6 >> putWord32be (fromIntegral len) + putByteString bs + putArray :: (a -> Put) -> V.Vector a -> Put putArray p xs = do case V.length xs of @@ -94,3 +112,17 @@ putMap p q xs = do | otherwise -> putWord8 0xDF >> putWord32be (fromIntegral len) V.mapM_ (\(a, b) -> p a >> q b ) xs + +putExt :: Word8 -> S.ByteString -> Put +putExt typ dat = do + case S.length dat of + 1 -> putWord8 0xD4 + 2 -> putWord8 0xD5 + 4 -> putWord8 0xD6 + 8 -> putWord8 0xD7 + 16 -> putWord8 0xD8 + len | len < 0x100 -> putWord8 0xC7 >> putWord8 (fromIntegral len) + | len < 0x10000 -> putWord8 0xC8 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 0xC9 >> putWord32be (fromIntegral len) + putWord8 typ + putByteString dat From 489379fa4a3d83b4d4762bd5937b775b59e60f5f Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sat, 28 Mar 2015 17:18:18 +0900 Subject: [PATCH 07/75] add document --- msgpack/src/Data/MessagePack.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index 6140698..1819172 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -13,22 +13,30 @@ -------------------------------------------------------------------- module Data.MessagePack ( - module X, - -- * Simple interface to pack and unpack msgpack binary pack, unpack, + + -- * Re-export modules + -- $reexports + -- module X, + module Data.MessagePack.Assoc, + module Data.MessagePack.Get, + module Data.MessagePack.Object, + module Data.MessagePack.Put, ) where import Data.Binary import 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 +-- | Unpack MessagePack binary to a Haskell value. If it fails, it returns Nothing. unpack :: MessagePack a => L.ByteString -> Maybe a unpack = fromObject . decode From 0f1934431d6b2a2af33b03871996aee0e6792acd Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sun, 29 Mar 2015 00:16:27 +0900 Subject: [PATCH 08/75] add document --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 42 +++++++++++++++------ 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index c678c4c..dd15d30 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} -- | Aeson bridge for MessagePack @@ -7,7 +10,10 @@ module Data.MessagePack.Aeson ( toAeson, fromAeson, -- * MessagePack instance for Aeson.Value - -- * ToJSON, FromJSON instance for MessagePack.Object + -- $msgpackInstance + + -- * ToJSON and FromJSON instance for MessagePack.Object + -- $aesonInstances -- * Wrapper instances AsMessagePack(..), @@ -19,8 +25,11 @@ module Data.MessagePack.Aeson ( ) where import Control.Applicative +import Control.Arrow +import Control.DeepSeq import Data.Aeson as A import qualified Data.ByteString.Lazy as L +import Data.Data import Data.Either import qualified Data.HashMap.Strict as HM import Data.Maybe @@ -29,10 +38,9 @@ import Data.Monoid import Data.Scientific import qualified Data.Text.Encoding as T import qualified Data.Vector as V -import Data.Data -import Control.DeepSeq -import Control.Arrow +-- | Convert MessagePack Object to Aeson Value. +-- If the value unable to convert, it returns Nothing toAeson :: MP.Object -> Maybe Value toAeson = \case ObjectNil -> Just Null @@ -40,12 +48,15 @@ toAeson = \case ObjectInt n -> Just $ Number $ fromIntegral n ObjectFloat f -> Just $ Number $ realToFrac f ObjectDouble d -> Just $ Number $ realToFrac d - ObjectRAW b -> String <$> either (const Nothing) Just (T.decodeUtf8' b) + ObjectStr t -> Just $ String t + ObjectBin b -> String <$> either (const Nothing) Just (T.decodeUtf8' b) ObjectArray v -> Array <$> V.mapM toAeson v - ObjectMap m -> + ObjectMap m -> A.Object . HM.fromList . V.toList <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> toAeson v) m + ObjectExt _ _ -> Nothing +-- | Convert Aeson Value to MessagePack Object fromAeson :: Value -> MP.Object fromAeson = \case Null -> ObjectNil @@ -54,21 +65,27 @@ fromAeson = \case case floatingOrInteger s of Left f -> ObjectDouble f Right n -> ObjectInt n - String t -> ObjectRAW $ T.encodeUtf8 t + String t -> ObjectStr t Array v -> ObjectArray $ V.map fromAeson v A.Object o -> ObjectMap $ V.fromList $ map (toObject *** fromAeson) $ HM.toList o +-- $msgpackInstance +-- > instance MessagePack Value instance MessagePack Value where fromObject = toAeson toObject = fromAeson +-- $aesonInstances +-- > instance ToJSON Object +-- > instance FromJSON Object instance ToJSON MP.Object where - -- | When fail to convert, it returns `Null` + -- When fail to convert, it returns `Null` toJSON = fromMaybe Null .toAeson instance FromJSON MP.Object where parseJSON = return . fromAeson +-- | Wrapper for using Aeson values as MessagePack value. newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) @@ -76,6 +93,7 @@ instance (FromJSON a, ToJSON a) => MessagePack (AsMessagePack a) where fromObject o = AsMessagePack <$> (fromJSON' =<< toAeson o) toObject = fromAeson . toJSON . getAsMessagePack +-- | Wrapper for using MessagePack values as Aeson value. newtype AsAeson a = AsAeson { getAsAeson :: a } deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) @@ -85,17 +103,19 @@ instance MessagePack a => ToJSON (AsAeson a) where instance MessagePack a => FromJSON (AsAeson a) where parseJSON = maybe empty (return . AsAeson) . fromObject . fromAeson --- | pack Aeson value to msgpack binary +-- | Pack Aeson value to MessagePack binary packAeson :: ToJSON a => a -> L.ByteString packAeson = pack . toJSON --- | unpack Aeson value from msgpack binary +-- | Unpack Aeson value from MessagePack binary unpackAeson :: FromJSON a => L.ByteString -> Maybe a unpackAeson b = fromJSON' =<< unpack b +-- | Encode MessagePack value to JSON encodeMessagePack :: MessagePack a => a -> L.ByteString encodeMessagePack = encode . toJSON . AsAeson +-- | Decode MessagePack value from JSON decodeMessagePack :: MessagePack a => L.ByteString -> Maybe a decodeMessagePack b = getAsAeson <$> (fromJSON' =<< decode b) From 3168060a6ef7b3ef2586dc8dbeb6b8adcd62f0fd Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sun, 29 Mar 2015 00:58:22 +0900 Subject: [PATCH 09/75] generalize Server --- .../src/Network/MessagePackRpc/Server.hs | 50 +++++++++++-------- msgpack-rpc/test/test.hs | 4 +- 2 files changed, 31 insertions(+), 23 deletions(-) diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs b/msgpack-rpc/src/Network/MessagePackRpc/Server.hs index d6397e0..62bb930 100644 --- a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs +++ b/msgpack-rpc/src/Network/MessagePackRpc/Server.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings, Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------- -- | @@ -20,7 +23,7 @@ -- -- > import Network.MessagePackRpc.Server -- > --- > add :: Int -> Int -> Method Int +-- > add :: Int -> Int -> Server Int -- > add x y = return $ x + y -- > -- > main = serve 1234 [("add", toMethod add)] @@ -29,8 +32,8 @@ module Network.MessagePackRpc.Server ( -- * RPC method types - RpcMethod, MethodType(..), - Method(..), + Method, MethodType(..), + ServerT(..), Server, -- * Start RPC server serve, ) where @@ -39,6 +42,7 @@ 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 @@ -47,7 +51,7 @@ import Data.Conduit.Serialization.Binary import Data.MessagePack import Data.Typeable -type RpcMethod = [Object] -> IO Object +type Method m = [Object] -> m Object type Request = (Int, Int, String, [Object]) type Response = (Int, Int, Object, Object) @@ -57,31 +61,37 @@ data ServerError = ServerError String instance Exception ServerError -newtype Method a = Method { runMethod :: IO a } +newtype ServerT m a = ServerT { runServerT :: m a } deriving (Functor, Applicative, Monad, MonadIO) -class MethodType f where +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 - toMethod :: f -> RpcMethod + toMethod :: f -> Method m -instance MessagePack o => MethodType (Method o) where +instance (MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where toMethod m ls = case ls of - [] -> toObject <$> runMethod m + [] -> toObject <$> runServerT m _ -> throwM $ ServerError "argument number error" -instance (MessagePack o, MethodType r) => MethodType (o -> r) where +instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (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 +serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) + => Int -- ^ Port number + -> [(String, Method m)] -- ^ list of (method name, RPC method) + -> m () +serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do (rsrc, _) <- appSource ad $$+ return () - _ <- try $ processRequests rsrc (appSink ad) :: IO (Either ParseError ()) + (_ :: Either ParseError ()) <- try $ processRequests rsrc (appSink ad) return () where processRequests rsrc sink = do @@ -89,18 +99,16 @@ serve port methods = runTCPServer (serverSettings port "*") $ \ad -> do obj <- sinkGet get case fromObject obj of Nothing -> throwM $ ServerError "invalid request" - Just req -> lift $ getResponse req + Just req -> lift $ getResponse (req :: Request) _ <- 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) + return ((1, msgid, toObject (), ret) :: Response) - callMethod :: String -> [Object] -> IO Object callMethod methodName args = case lookup methodName methods of Nothing -> diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/test.hs index 3324721..af69c8d 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -25,10 +25,10 @@ server = , ("echo", toMethod 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 () From 378c973a1fae87b6f4f8392be1cc072fce37668b Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sun, 29 Mar 2015 01:17:17 +0900 Subject: [PATCH 10/75] add document, refactoring --- msgpack-rpc/msgpack-rpc.cabal | 4 +- .../{MessagePackRpc => MessagePack}/Client.hs | 4 +- .../{MessagePackRpc => MessagePack}/Server.hs | 43 +++++++++++++------ msgpack-rpc/test/test.hs | 10 ++--- 4 files changed, 38 insertions(+), 23 deletions(-) rename msgpack-rpc/src/Network/{MessagePackRpc => MessagePack}/Client.hs (98%) rename msgpack-rpc/src/Network/{MessagePackRpc => MessagePack}/Server.hs (79%) diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index a7757c3..104de49 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -21,8 +21,8 @@ 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 diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs similarity index 98% rename from msgpack-rpc/src/Network/MessagePackRpc/Client.hs rename to msgpack-rpc/src/Network/MessagePack/Client.hs index 77f7cdb..f1caf99 100644 --- a/msgpack-rpc/src/Network/MessagePackRpc/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -28,7 +28,7 @@ -- -------------------------------------------------------------------- -module Network.MessagePackRpc.Client ( +module Network.MessagePack.Client ( -- * MessagePack Client type Client, execClient, @@ -52,7 +52,7 @@ import Data.Conduit.Network import Data.Conduit.Serialization.Binary import Data.MessagePack import Data.Typeable -import System.IO +import System.IO newtype Client a = ClientT { runClient :: StateT Connection IO a } diff --git a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs similarity index 79% rename from msgpack-rpc/src/Network/MessagePackRpc/Server.hs rename to msgpack-rpc/src/Network/MessagePack/Server.hs index 62bb930..a3514fd 100644 --- a/msgpack-rpc/src/Network/MessagePackRpc/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -26,14 +26,16 @@ -- > add :: Int -> Int -> Server Int -- > add x y = return $ x + y -- > --- > main = serve 1234 [("add", toMethod add)] +-- > main = serve 1234 [ method "add" add ] -- -------------------------------------------------------------------- -module Network.MessagePackRpc.Server ( +module Network.MessagePack.Server ( -- * RPC method types Method, MethodType(..), ServerT(..), Server, + -- * Build a method + method, -- * Start RPC server serve, ) where @@ -48,10 +50,16 @@ 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 -type Method m = [Object] -> m Object +-- ^ 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) @@ -71,23 +79,30 @@ type Server = ServerT IO class Monad m => MethodType m f where -- | Create a RPC method from a Hakell function - toMethod :: f -> Method m + toBody :: f -> [Object] -> m Object instance (MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where - toMethod m ls = case ls of + 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 - toMethod f (x: xs) = + toBody f (x: xs) = case fromObject x of Nothing -> throwM $ ServerError "argument type error" - Just r -> toMethod (f r) xs + Just 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 - -> [(String, Method m)] -- ^ list of (method name, RPC method) + => Int -- ^ Port number + -> [Method m] -- ^ list of methods -> m () serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do (rsrc, _) <- appSource ad $$+ return () @@ -109,9 +124,9 @@ serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do ret <- callMethod methodName args return ((1, msgid, toObject (), ret) :: Response) - callMethod methodName args = - case lookup methodName methods of + callMethod name args = + case find ((== name) . methodName) methods of Nothing -> - throwM $ ServerError $ "method '" ++ methodName ++ "' not found" - Just method -> - method args + throwM $ ServerError $ "method '" ++ name ++ "' not found" + Just m -> + methodBody m args diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/test.hs index af69c8d..4aa11bf 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -6,9 +6,9 @@ import Control.Monad.Trans import Test.Tasty import Test.Tasty.HUnit -import Network (withSocketsDo) -import Network.MessagePackRpc.Client -import Network.MessagePackRpc.Server +import Network (withSocketsDo) +import Network.MessagePack.Client +import Network.MessagePack.Server port :: Int port = 5000 @@ -21,8 +21,8 @@ main = withSocketsDo $ defaultMain $ server :: IO () server = serve port - [ ("add", toMethod add) - , ("echo", toMethod echo) + [ method "add" add + , method "echo" echo ] where add :: Int -> Int -> Server Int From 2d9993f5682797b5c7eb742741ecfe793c6c245e Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 3 Apr 2015 18:41:37 +0900 Subject: [PATCH 11/75] remove redundant imports --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index dd15d30..1c51262 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -30,11 +30,9 @@ import Control.DeepSeq import Data.Aeson as A import qualified Data.ByteString.Lazy as L import Data.Data -import Data.Either import qualified Data.HashMap.Strict as HM import Data.Maybe import Data.MessagePack as MP -import Data.Monoid import Data.Scientific import qualified Data.Text.Encoding as T import qualified Data.Vector as V From 4634efb9ae569af7d760aaa13e2125eae40f0bf6 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 3 Apr 2015 19:40:46 +0900 Subject: [PATCH 12/75] update README --- README.md | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index f65a573..6399329 100644 --- a/README.md +++ b/README.md @@ -1,23 +1,21 @@ MessagePack for Haskell ======================= -This is a msgpack implementation of Haskell. +This is an implementation of msgpack for Haskell. -It containes +It containes: * Serializer/Deserializer * RPC -* IDL # Install -To install this, execute following instructions. +Execute following instructions: ~~~ {.bash} $ cabal update $ cabal install msgpack $ cabal install msgpack-rpc -$ cabal install msgpack-idl ~~~ # Document @@ -26,4 +24,3 @@ There are Haddoc documents on Hackage Database. * * -* From 3c27481a6e0c6df5c34a7195fdd3b588bfb21bf0 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 3 Apr 2015 20:46:43 +0900 Subject: [PATCH 13/75] add msgpack-aeson test --- msgpack-aeson/msgpack-aeson.cabal | 2 ++ msgpack-aeson/test/test.hs | 49 +++++++++++++++++++++++-------- 2 files changed, 38 insertions(+), 13 deletions(-) diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index 1584bdf..1d91448 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -41,6 +41,8 @@ test-suite msgpack-aeson-test , msgpack , aeson , msgpack-aeson + , tasty + , tasty-hunit hs-source-dirs: test default-language: Haskell2010 diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs index 940b8b3..dea108b 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -1,8 +1,14 @@ -{-# LANGUAGE OverloadedStrings, ViewPatterns, ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} -import Data.MessagePack -import Data.MessagePack.Aeson -import Data.Aeson.TH +import Control.Monad +import Data.Aeson +import Data.Aeson.TH +import Data.MessagePack +import Data.MessagePack.Aeson +import Test.Tasty +import Test.Tasty.HUnit data T = A Int String @@ -41,13 +47,30 @@ test v = do print oa print (fromObject oa == Just v) +roundTrip :: (Show a, Eq a, ToJSON a, FromJSON a) => a -> IO () +roundTrip v = do + let mp = pack (AsMessagePack v) + v' = unpack mp + v' @?= Just (AsMessagePack v) + main :: IO () -main = do - test $ AsMessagePack $ A 123 "hoge" - test $ AsMessagePack $ B 3.14 - test $ AsMessagePack $ C 123 "hoge" - test $ AsMessagePack $ D 3.14 - test $ AsMessagePack $ E "hello" - test $ AsMessagePack F - test $ AsMessagePack $ G (E "hello") "world" - test $ AsMessagePack $ H 123 F +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 + ] From 024cd75c490b07ac430d4667fb4bdbd1b16e946d Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 3 Apr 2015 20:48:39 +0900 Subject: [PATCH 14/75] bump version --- msgpack-aeson/msgpack-aeson.cabal | 19 +++++++--------- msgpack-rpc/msgpack-rpc.cabal | 36 +++++++++++++++---------------- msgpack/msgpack.cabal | 30 +++++++++++++------------- 3 files changed, 41 insertions(+), 44 deletions(-) diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index 1d91448..4d8595e 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -1,6 +1,3 @@ --- Initial msgpack-aeson.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: msgpack-aeson version: 0.1.0.0 synopsis: Aeson adapter for MessagePack @@ -20,14 +17,14 @@ library exposed-modules: Data.MessagePack.Aeson -- other-modules: -- other-extensions: - build-depends: aeson >=0.8 - , base >=4.7 && <5 - , bytestring >= 0.10 - , msgpack >=0.8 - , scientific >= 0.3 - , text >= 1.2 - , unordered-containers >= 0.2 - , vector >= 0.10 + build-depends: base >=4.7 && <5 + , aeson >=0.8 + , bytestring >=0.10 + , msgpack >=1.0 + , scientific >=0.3 + , text >=1.2 + , unordered-containers >=0.2 + , vector >=0.10 , deepseq hs-source-dirs: src default-language: Haskell2010 diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index 104de49..78e4f7c 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -1,5 +1,5 @@ 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/ @@ -10,7 +10,7 @@ maintainer: Hideyuki Tanaka copyright: (c) 2010-2015, Hideyuki Tanaka category: Network stability: Experimental -cabal-version: >=1.18 +cabal-version: >=1.10 build-type: Simple source-repository head @@ -24,19 +24,19 @@ library 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 + , 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 >=1.0 test-suite msgpack-rpc-test default-language: Haskell2010 @@ -47,7 +47,7 @@ test-suite msgpack-rpc-test build-depends: base , mtl , network - , async >= 2.0 - , tasty >= 0.10 - , tasty-hunit >= 0.9 + , async >=2.0 + , tasty >=0.10 + , tasty-hunit >=0.9 , msgpack-rpc diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 888dde9..6f98ab7 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -1,5 +1,5 @@ name: msgpack -version: 0.8.0.0 +version: 1.0.0 synopsis: A Haskell implementation of MessagePack description: A Haskell implementation of MessagePack homepage: http://msgpack.org/ @@ -10,7 +10,7 @@ maintainer: Hideyuki Tanaka copyright: Copyright (c) 2009-2015, Hideyuki Tanaka category: Data stability: Experimental -cabal-version: >= 1.18 +cabal-version: >= 1.10 build-type: Simple source-repository head @@ -27,17 +27,17 @@ library 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 + 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 + , vector >=0.10 + , blaze-builder >=0.4 + , deepseq >=1.3 + , binary >=0.7 , data-binary-ieee754 test-suite msgpack-tests @@ -49,7 +49,7 @@ test-suite msgpack-tests build-depends: base , bytestring - , QuickCheck >= 2.8 - , tasty >= 0.10 - , tasty-quickcheck >= 0.8 + , QuickCheck >=2.8 + , tasty >=0.10 + , tasty-quickcheck >=0.8 , msgpack From b91205ca740dc71e19722020912361faece979f6 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 3 Apr 2015 21:03:08 +0900 Subject: [PATCH 15/75] add base upper bound --- msgpack-rpc/msgpack-rpc.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index 78e4f7c..dde6622 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -24,7 +24,7 @@ library exposed-modules: Network.MessagePack.Server Network.MessagePack.Client - build-depends: base >=4.5 + build-depends: base >=4.5 && <5 , bytestring >=0.10 , text >=1.2 , network >=2.6 From 5afe7390d2208dbc3ca19165ab5af58e7b1e0794 Mon Sep 17 00:00:00 2001 From: Reid Draper Date: Thu, 23 Apr 2015 14:24:56 -0500 Subject: [PATCH 16/75] Add QuickCheck property for Float This property currently fails, because of an incorrect tag: 0xCB vs 0xCA. --- msgpack/test/test.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/msgpack/test/test.hs b/msgpack/test/test.hs index f6d62f2..dd908bf 100644 --- a/msgpack/test/test.hs +++ b/msgpack/test/test.hs @@ -35,6 +35,8 @@ tests = \(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" $ From d6509c0f1cb4e2904fe662bebf198ad76f151746 Mon Sep 17 00:00:00 2001 From: Reid Draper Date: Thu, 23 Apr 2015 14:25:44 -0500 Subject: [PATCH 17/75] Fix Float binary encoding This fixes the Float QuickCheck test --- msgpack/src/Data/MessagePack/Put.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 321e58d..bb27e8c 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -58,7 +58,7 @@ putInt n putFloat :: Float -> Put putFloat f = do - putWord8 0xCB + putWord8 0xCA putFloat32be f putDouble :: Double -> Put From 1ab12faba418ce07bd660605b0e45f9be702e85a Mon Sep 17 00:00:00 2001 From: Reid Draper Date: Tue, 5 May 2015 20:24:32 -0500 Subject: [PATCH 18/75] Add test for (Maybe Int) roundtrip This test currently fails, and enters an infinite loop. The test can be reproced easily in a ghci session: import Data.MessagePack fromObject (ObjectInt 5) :: Maybe (Maybe Int) -- wait forever... --- msgpack/test/test.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/msgpack/test/test.hs b/msgpack/test/test.hs index f6d62f2..144252a 100644 --- a/msgpack/test/test.hs +++ b/msgpack/test/test.hs @@ -43,6 +43,8 @@ tests = \(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 "[string]" $ From 1b113d8bdb955c7dd9a53246b7c874249e2e4f14 Mon Sep 17 00:00:00 2001 From: Reid Draper Date: Tue, 5 May 2015 20:26:03 -0500 Subject: [PATCH 19/75] Fix bug in (Maybe a) MessagePack instance Before this fix, this code (in a ghci session) will enter an infinite loop import Data.MessagePack fromObject (ObjectInt 5) :: Maybe (Maybe Int) -- wait forever... --- msgpack/src/Data/MessagePack/Object.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 824e65b..c34bf1d 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -189,7 +189,7 @@ instance MessagePack a => MessagePack (Maybe a) where fromObject = \case ObjectNil -> Just Nothing - obj -> fromObject obj + obj -> Just <$> fromObject obj -- UTF8 string like From a6e07fbeca0a72095f16cf8ba27a36d949d12ddb Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 24 Jun 2015 20:15:04 +0900 Subject: [PATCH 20/75] start using stack --- .gitignore | 1 + stack.yaml | 10 ++++++++++ 2 files changed, 11 insertions(+) create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index ef42924..3ec9cb5 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ tmp/ /msgpack-rpc/cabal.sandbox.config /msgpack-aeson/cabal.sandbox.config /msgpack-aeson/.cabal-sandbox/ +/.stack-work/ diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..e92276e --- /dev/null +++ b/stack.yaml @@ -0,0 +1,10 @@ +flags: {} +packages: +- msgpack/ +- msgpack-rpc/ +- msgpack-aeson/ +# - msgpack-idl/ +# - msgpack-idl-web/ +extra-deps: +- peggy-0.3.2 +resolver: lts-2.15 From d897317c115f73b0dabadf2583a3a3f05aa8a4a1 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 24 Jun 2015 20:15:57 +0900 Subject: [PATCH 21/75] fix for compiling --- msgpack-idl-web/mpidl-web.cabal | 4 ++-- msgpack-idl-web/{ => src}/Application.hs | 0 msgpack-idl-web/{ => src}/Foundation.hs | 0 msgpack-idl-web/{ => src}/Handler/Home.hs | 0 msgpack-idl-web/{ => src}/Import.hs | 0 msgpack-idl-web/{ => src}/Model.hs | 0 msgpack-idl-web/{ => src}/Settings.hs | 0 msgpack-idl-web/{ => src}/Settings/Development.hs | 0 msgpack-idl-web/{ => src}/Settings/StaticFiles.hs | 0 msgpack-idl-web/{ => src}/devel.hs | 0 msgpack-idl-web/{ => src}/main.hs | 0 msgpack-rpc/msgpack-rpc.cabal | 2 +- msgpack-rpc/src/Network/MessagePack/Server.hs | 3 ++- msgpack/msgpack.cabal | 4 ++-- 14 files changed, 7 insertions(+), 6 deletions(-) rename msgpack-idl-web/{ => src}/Application.hs (100%) rename msgpack-idl-web/{ => src}/Foundation.hs (100%) rename msgpack-idl-web/{ => src}/Handler/Home.hs (100%) rename msgpack-idl-web/{ => src}/Import.hs (100%) rename msgpack-idl-web/{ => src}/Model.hs (100%) rename msgpack-idl-web/{ => src}/Settings.hs (100%) rename msgpack-idl-web/{ => src}/Settings/Development.hs (100%) rename msgpack-idl-web/{ => src}/Settings/StaticFiles.hs (100%) rename msgpack-idl-web/{ => src}/devel.hs (100%) rename msgpack-idl-web/{ => src}/main.hs (100%) 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 dde6622..0f55430 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -29,7 +29,7 @@ library , text >=1.2 , network >=2.6 , random >=1.1 - , mtl >=2.2 + , mtl >=2.1 , monad-control >=1.0 , conduit >=1.2 , conduit-extra >=1.1 diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs index a3514fd..ea294ef 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -81,7 +82,7 @@ class Monad m => MethodType m f where -- | Create a RPC method from a Hakell function toBody :: f -> [Object] -> m Object -instance (MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where +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" diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 6f98ab7..5b8b042 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -28,7 +28,7 @@ library Data.MessagePack.Put build-depends: base ==4.* - , mtl >=2.2 + , mtl >=2.1 , bytestring >=0.10 , text >=1.2 , containers >=0.5.5 @@ -49,7 +49,7 @@ test-suite msgpack-tests build-depends: base , bytestring - , QuickCheck >=2.8 + , QuickCheck >=2.7 , tasty >=0.10 , tasty-quickcheck >=0.8 , msgpack From 74f8d8f318fcd7483e5d66ce0f729ba8343977cf Mon Sep 17 00:00:00 2001 From: Carter Hinsley Date: Fri, 29 Jan 2016 19:53:05 -0500 Subject: [PATCH 22/75] Tidy up grammatical structure; fix spelling errors --- README.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 6399329..6bdaf75 100644 --- a/README.md +++ b/README.md @@ -3,12 +3,12 @@ MessagePack for Haskell This is an implementation of msgpack for Haskell. -It containes: +It contains: * Serializer/Deserializer * RPC -# Install +# Installation Execute following instructions: @@ -18,9 +18,9 @@ $ cabal install msgpack $ cabal install msgpack-rpc ~~~ -# Document +# Documentation -There are Haddoc documents on Hackage Database. +Haddock documentation can be found on Hackage: * * From 2cfb003c6d050a4c8dbaaa5a4a458ae2be804b50 Mon Sep 17 00:00:00 2001 From: iphydf Date: Tue, 6 Sep 2016 12:54:11 +0100 Subject: [PATCH 23/75] Removed stale non-working msgpack-idl code. --- msgpack-idl-web/LICENSE | 25 - msgpack-idl-web/config/favicon.ico | Bin 1342 -> 0 bytes msgpack-idl-web/config/models | 11 - msgpack-idl-web/config/robots.txt | 1 - msgpack-idl-web/config/routes | 7 - msgpack-idl-web/config/settings.yml | 21 - msgpack-idl-web/config/sqlite.yml | 20 - msgpack-idl-web/deploy/Procfile | 97 - msgpack-idl-web/messages/en.msg | 1 - msgpack-idl-web/mpidl-web.cabal | 114 - msgpack-idl-web/src/Application.hs | 61 - msgpack-idl-web/src/Foundation.hs | 162 - msgpack-idl-web/src/Handler/Home.hs | 59 - msgpack-idl-web/src/Import.hs | 28 - msgpack-idl-web/src/Model.hs | 14 - msgpack-idl-web/src/Settings.hs | 68 - msgpack-idl-web/src/Settings/Development.hs | 14 - msgpack-idl-web/src/Settings/StaticFiles.hs | 18 - msgpack-idl-web/src/devel.hs | 26 - msgpack-idl-web/src/main.hs | 8 - msgpack-idl-web/static/css/bootstrap.css | 3990 ----------------- .../static/img/glyphicons-halflings-white.png | Bin 8777 -> 0 bytes .../static/img/glyphicons-halflings.png | Bin 13826 -> 0 bytes .../templates/default-layout-wrapper.hamlet | 47 - .../templates/default-layout.hamlet | 3 - msgpack-idl-web/templates/homepage.hamlet | 20 - msgpack-idl-web/templates/homepage.julius | 1 - msgpack-idl-web/templates/homepage.lucius | 6 - msgpack-idl-web/templates/normalize.lucius | 439 -- msgpack-idl-web/tests/HomeTest.hs | 24 - msgpack-idl-web/tests/main.hs | 22 - msgpack-idl/LICENSE | 30 - msgpack-idl/Language/MessagePack/IDL.hs | 9 - msgpack-idl/Language/MessagePack/IDL/Check.hs | 9 - .../Language/MessagePack/IDL/CodeGen/Cpp.hs | 298 -- .../MessagePack/IDL/CodeGen/Erlang.hs | 189 - .../MessagePack/IDL/CodeGen/Haskell.hs | 209 - .../Language/MessagePack/IDL/CodeGen/Java.hs | 349 -- .../Language/MessagePack/IDL/CodeGen/Perl.hs | 104 - .../Language/MessagePack/IDL/CodeGen/Php.hs | 181 - .../MessagePack/IDL/CodeGen/Python.hs | 172 - .../Language/MessagePack/IDL/CodeGen/Ruby.hs | 285 -- .../Language/MessagePack/IDL/Internal.hs | 14 - .../Language/MessagePack/IDL/Parser.hs | 14 - .../Language/MessagePack/IDL/Syntax.hs | 76 - msgpack-idl/README.md | 66 - msgpack-idl/Setup.hs | 2 - msgpack-idl/Specification.md | 160 - msgpack-idl/exec/main.hs | 138 - msgpack-idl/mpidl.peggy | 87 - msgpack-idl/msgpack-idl.cabal | 68 - msgpack-idl/test/TODO.txt | 19 - msgpack-idl/test/idls/empty.idl | 8 - msgpack-idl/test/test.hs | 18 - 54 files changed, 7812 deletions(-) delete mode 100644 msgpack-idl-web/LICENSE delete mode 100644 msgpack-idl-web/config/favicon.ico delete mode 100644 msgpack-idl-web/config/models delete mode 100644 msgpack-idl-web/config/robots.txt delete mode 100644 msgpack-idl-web/config/routes delete mode 100644 msgpack-idl-web/config/settings.yml delete mode 100644 msgpack-idl-web/config/sqlite.yml delete mode 100644 msgpack-idl-web/deploy/Procfile delete mode 100644 msgpack-idl-web/messages/en.msg delete mode 100644 msgpack-idl-web/mpidl-web.cabal delete mode 100644 msgpack-idl-web/src/Application.hs delete mode 100644 msgpack-idl-web/src/Foundation.hs delete mode 100644 msgpack-idl-web/src/Handler/Home.hs delete mode 100644 msgpack-idl-web/src/Import.hs delete mode 100644 msgpack-idl-web/src/Model.hs delete mode 100644 msgpack-idl-web/src/Settings.hs delete mode 100644 msgpack-idl-web/src/Settings/Development.hs delete mode 100644 msgpack-idl-web/src/Settings/StaticFiles.hs delete mode 100644 msgpack-idl-web/src/devel.hs delete mode 100644 msgpack-idl-web/src/main.hs delete mode 100644 msgpack-idl-web/static/css/bootstrap.css delete mode 100644 msgpack-idl-web/static/img/glyphicons-halflings-white.png delete mode 100644 msgpack-idl-web/static/img/glyphicons-halflings.png delete mode 100644 msgpack-idl-web/templates/default-layout-wrapper.hamlet delete mode 100644 msgpack-idl-web/templates/default-layout.hamlet delete mode 100644 msgpack-idl-web/templates/homepage.hamlet delete mode 100644 msgpack-idl-web/templates/homepage.julius delete mode 100644 msgpack-idl-web/templates/homepage.lucius delete mode 100644 msgpack-idl-web/templates/normalize.lucius delete mode 100644 msgpack-idl-web/tests/HomeTest.hs delete mode 100644 msgpack-idl-web/tests/main.hs delete mode 100644 msgpack-idl/LICENSE delete mode 100644 msgpack-idl/Language/MessagePack/IDL.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/Check.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Haskell.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Perl.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Php.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Python.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/Internal.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/Parser.hs delete mode 100644 msgpack-idl/Language/MessagePack/IDL/Syntax.hs delete mode 100644 msgpack-idl/README.md delete mode 100644 msgpack-idl/Setup.hs delete mode 100644 msgpack-idl/Specification.md delete mode 100644 msgpack-idl/exec/main.hs delete mode 100644 msgpack-idl/mpidl.peggy delete mode 100644 msgpack-idl/msgpack-idl.cabal delete mode 100644 msgpack-idl/test/TODO.txt delete mode 100644 msgpack-idl/test/idls/empty.idl delete mode 100644 msgpack-idl/test/test.hs diff --git a/msgpack-idl-web/LICENSE b/msgpack-idl-web/LICENSE deleted file mode 100644 index 7fd5055..0000000 --- a/msgpack-idl-web/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2012, 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. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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-idl-web/config/favicon.ico b/msgpack-idl-web/config/favicon.ico deleted file mode 100644 index 9dd5f356d4119b9f50f2cfc370d84b975688ca3f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1342 zcmZQzU}Ruo5D;Jh(h3Y2EDQ{43=BX%6OhlyumQ;K1Bz*Y#DG`9fi}^UD+ED^lEv4=~bZE?Oa#QNJ z+cU2q@Jy_cXbVuDRgi&!Pndy$Uj&FjG%!r~G*}n}eN{LmftXW(osr#3fhE^klz}@^ zU$|;Qg2VkYvnvl)`{~~bP+{8=sLs_J1jT`BoV|gnVB8(3%DyR3nI&CMh(Rw@h3UVq z976)oLHzLs0y{P~#GTvJ7=J#|Q0S1eI75h=9Fw`b9HR{w%Q9NKNHZGw$TO`BQDl7J zB*l;!s>tv^SdrnOhYW+Vqd0?Ip`+sMGqWlVOi6OO5U9ko&Rv=z-&2+$3yQ1#2)2Iyt@UV6l_ZOK%y5iLO!%E~8CEhtTI!F91gl`Au7IhU0E0?}kN(w@ z(@GAltcg2Y=&tj-&|Ulg{DQz6r)QS$ZjG{eR_vksuf$95e~GvL|56`=|G7@8hd^n- zM_a_T#Lx6fU6|F+{xt7rP0@~@>%wjS*G1U>Z;o;N-k;|6qA}9`6OjL}G1~EeW3=^5DjW<90fw^D6(KfPd$WT6cc%IO1Eo_)x()sZqPsJK{&i;t{p-yR`PY{n z`maAX{C`cD?VMyQIW~~}Y`~P9?rvnzn&NkBR(1OSnN?~3XI7^E1JWS;e-;Q=r~jK( zlL?~#x2O27D)F}fCP`F~?PDR|ni?=~ZbR<>vMam ze^E`iJs(V`ngAn=$#81rbOtk7PUZ{`6Xo`dki6+t8S`h>Wv`xIl|HpC#V@MB$4ofh z$&hh#oH1ArFpV<&kY`}{z|O$%fSG~e;eQ|-XxxTB3=A_W7#Jih7#Jo1Rc-*{2S9uP eCz>> package.json -# -# Postgresql Yesod setup: -# -# * add a dependency on the "heroku" package in your cabal file -# -# * add code in Application.hs to use the heroku package and load the connection parameters. -# The below works for Postgresql. -# -# #ifndef DEVELOPMENT -# import qualified Web.Heroku -# #endif -# -# -# makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application -# makeApplication conf logger = do -# manager <- newManager def -# s <- staticSite -# hconfig <- loadHerokuConfig -# dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf) -# (Database.Persist.Store.loadConfig . combineMappings hconfig) >>= -# Database.Persist.Store.applyEnv -# p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig) -# Database.Persist.Store.runPool dbconf (runMigration migrateAll) p -# let foundation = App conf setLogger s p manager dbconf -# app <- toWaiAppPlain foundation -# return $ logWare app -# where -##ifdef DEVELOPMENT -# logWare = logCallbackDev (logBS setLogger) -# setLogger = logger -##else -# setLogger = toProduction logger -- by default the logger is set for development -# logWare = logCallback (logBS setLogger) -##endif -# -# #ifndef DEVELOPMENT -# canonicalizeKey :: (Text, val) -> (Text, val) -# canonicalizeKey ("dbname", val) = ("database", val) -# canonicalizeKey pair = pair -# -# toMapping :: [(Text, Text)] -> AT.Value -# toMapping xs = AT.Object $ M.fromList $ map (\(key, val) -> (key, AT.String val)) xs -# #endif -# -# combineMappings :: AT.Value -> AT.Value -> AT.Value -# combineMappings (AT.Object m1) (AT.Object m2) = AT.Object $ m1 `M.union` m2 -# combineMappings _ _ = error "Data.Object is not a Mapping." -# -# loadHerokuConfig :: IO AT.Value -# loadHerokuConfig = do -# #ifdef DEVELOPMENT -# return $ AT.Object M.empty -# #else -# Web.Heroku.dbConnParams >>= return . toMapping . map canonicalizeKey -# #endif - - - -# Heroku setup: -# Find the Heroku guide. Roughly: -# -# * sign up for a heroku account and register your ssh key -# * create a new application on the *cedar* stack -# -# * make your Yesod project the git repository for that application -# * create a deploy branch -# -# git checkout -b deploy -# -# Repeat these steps to deploy: -# * add your web executable binary (referenced below) to the git repository -# -# git checkout deploy -# git add ./dist/build/mpidl-web/mpidl-web -# git commit -m deploy -# -# * push to Heroku -# -# git push heroku deploy:master - - -# Heroku configuration that runs your app -web: ./dist/build/mpidl-web/mpidl-web production -p $PORT diff --git a/msgpack-idl-web/messages/en.msg b/msgpack-idl-web/messages/en.msg deleted file mode 100644 index e928c34..0000000 --- a/msgpack-idl-web/messages/en.msg +++ /dev/null @@ -1 +0,0 @@ -Hello: Hello diff --git a/msgpack-idl-web/mpidl-web.cabal b/msgpack-idl-web/mpidl-web.cabal deleted file mode 100644 index f55b172..0000000 --- a/msgpack-idl-web/mpidl-web.cabal +++ /dev/null @@ -1,114 +0,0 @@ -name: mpidl-web -version: 0.0.0 -license: BSD3 -license-file: LICENSE -author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka -synopsis: The greatest Yesod web application ever. -description: I'm sure you can say something clever here if you try. -category: Web -stability: Experimental -cabal-version: >= 1.8 -build-type: Simple -homepage: http://mpidl-web.yesodweb.com/ - -Flag dev - Description: Turn on development settings, like auto-reload templates. - Default: False - -Flag library-only - Description: Build for use with "yesod devel" - Default: False - -library - exposed-modules: Application - Foundation - Import - Model - Settings - Settings.StaticFiles - Settings.Development - Handler.Home - - if flag(dev) || flag(library-only) - cpp-options: -DDEVELOPMENT - ghc-options: -Wall -threaded -O0 - else - ghc-options: -Wall -threaded -O2 - - extensions: TemplateHaskell - QuasiQuotes - OverloadedStrings - NoImplicitPrelude - CPP - MultiParamTypeClasses - TypeFamilies - GADTs - GeneralizedNewtypeDeriving - FlexibleContexts - EmptyDataDecls - NoMonomorphismRestriction - - build-depends: base >= 4 && < 5 - , yesod-platform >= 1.0 && < 1.1 - , yesod >= 1.0 && < 1.1 - , yesod-core >= 1.0 && < 1.1 - , yesod-auth >= 1.0 && < 1.1 - , yesod-static >= 1.0 && < 1.1 - , yesod-default >= 1.0 && < 1.1 - , yesod-form >= 1.0 && < 1.1 - , yesod-test >= 0.2 && < 0.3 - , clientsession >= 0.7.3 && < 0.8 - , bytestring >= 0.9 && < 0.10 - , text >= 0.11 && < 0.12 - , persistent >= 0.9 && < 0.10 - , persistent-sqlite >= 0.9 && < 0.10 - , template-haskell - , hamlet >= 1.0 && < 1.1 - , shakespeare-css >= 1.0 && < 1.1 - , shakespeare-js >= 1.0 && < 1.1 - , shakespeare-text >= 1.0 && < 1.1 - , hjsmin >= 0.1 && < 0.2 - , monad-control >= 0.3 && < 0.4 - , wai-extra >= 1.2 && < 1.3 - , yaml >= 0.7 && < 0.8 - , http-conduit >= 1.4 && < 1.5 - , directory >= 1.1 && < 1.2 - , warp >= 1.2 && < 1.3 - - , shelly - , bytestring - , system-fileio - -executable mpidl-web - if flag(library-only) - Buildable: False - - main-is: main.hs - hs-source-dirs: src - build-depends: base - , mpidl-web - , yesod-default - -test-suite test - type: exitcode-stdio-1.0 - main-is: main.hs - hs-source-dirs: tests - ghc-options: -Wall - extensions: TemplateHaskell - QuasiQuotes - OverloadedStrings - NoImplicitPrelude - CPP - OverloadedStrings - MultiParamTypeClasses - TypeFamilies - GADTs - GeneralizedNewtypeDeriving - FlexibleContexts - - build-depends: base - , mpidl-web - , yesod-test - , yesod-default - , yesod-core diff --git a/msgpack-idl-web/src/Application.hs b/msgpack-idl-web/src/Application.hs deleted file mode 100644 index 607a11f..0000000 --- a/msgpack-idl-web/src/Application.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Application - ( makeApplication - , getApplicationDev - , makeFoundation - ) where - -import Import -import Settings -import Yesod.Auth -import Yesod.Default.Config -import Yesod.Default.Main -import Yesod.Default.Handlers -import Yesod.Logger (Logger, logBS, toProduction) -import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev) -import qualified Database.Persist.Store -import Database.Persist.GenericSql (runMigration) -import Network.HTTP.Conduit (newManager, def) - --- Import all relevant handler modules here. --- Don't forget to add new modules to your cabal file! -import Handler.Home - --- This line actually creates our YesodSite instance. It is the second half --- of the call to mkYesodData which occurs in Foundation.hs. Please see --- the comments there for more details. -mkYesodDispatch "App" resourcesApp - --- This function allocates resources (such as a database connection pool), --- performs initialization and creates a WAI application. This is also the --- place to put your migrate statements to have automatic database --- migrations handled by Yesod. -makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application -makeApplication conf logger = do - foundation <- makeFoundation conf setLogger - app <- toWaiAppPlain foundation - return $ logWare app - where - setLogger = if development then logger else toProduction logger - logWare = if development then logCallbackDev (logBS setLogger) - else logCallback (logBS setLogger) - -makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App -makeFoundation conf setLogger = do - manager <- newManager def - s <- staticSite - dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf) - Database.Persist.Store.loadConfig >>= - Database.Persist.Store.applyEnv - p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig) - Database.Persist.Store.runPool dbconf (runMigration migrateAll) p - return $ App conf setLogger s p manager dbconf - --- for yesod devel -getApplicationDev :: IO (Int, Application) -getApplicationDev = - defaultDevelApp loader makeApplication - where - loader = loadConfig (configSettings Development) - { csParseExtra = parseExtra - } diff --git a/msgpack-idl-web/src/Foundation.hs b/msgpack-idl-web/src/Foundation.hs deleted file mode 100644 index fed8a4f..0000000 --- a/msgpack-idl-web/src/Foundation.hs +++ /dev/null @@ -1,162 +0,0 @@ -module Foundation - ( App (..) - , Route (..) - , AppMessage (..) - , resourcesApp - , Handler - , Widget - , Form - , maybeAuth - , requireAuth - , module Settings - , module Model - ) where - -import Prelude -import Yesod -import Yesod.Static -import Yesod.Auth -import Yesod.Auth.BrowserId -import Yesod.Auth.GoogleEmail -import Yesod.Default.Config -import Yesod.Default.Util (addStaticContentExternal) -import Yesod.Logger (Logger, logMsg, formatLogText) -import Network.HTTP.Conduit (Manager) -import qualified Settings -import qualified Database.Persist.Store -import Settings.StaticFiles -import Database.Persist.GenericSql -import Settings (widgetFile, Extra (..)) -import Model -import Text.Jasmine (minifym) -import Web.ClientSession (getKey) -import Text.Hamlet (hamletFile) - --- | The site argument for your application. This can be a good place to --- keep settings and values requiring initialization before your application --- starts running, such as database connections. Every handler will have --- access to the data present here. -data App = App - { settings :: AppConfig DefaultEnv Extra - , getLogger :: Logger - , getStatic :: Static -- ^ Settings for static file serving. - , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool. - , httpManager :: Manager - , persistConfig :: Settings.PersistConfig - } - --- Set up i18n messages. See the message folder. -mkMessage "App" "messages" "en" - --- This is where we define all of the routes in our application. For a full --- explanation of the syntax, please see: --- http://www.yesodweb.com/book/handler --- --- This function does three things: --- --- * Creates the route datatype AppRoute. Every valid URL in your --- application can be represented as a value of this type. --- * Creates the associated type: --- type instance Route App = AppRoute --- * Creates the value resourcesApp which contains information on the --- resources declared below. This is used in Handler.hs by the call to --- mkYesodDispatch --- --- What this function does *not* do is create a YesodSite instance for --- App. Creating that instance requires all of the handler functions --- for our application to be in scope. However, the handler functions --- usually require access to the AppRoute datatype. Therefore, we --- split these actions into two functions and place them in separate files. -mkYesodData "App" $(parseRoutesFile "config/routes") - -type Form x = Html -> MForm App App (FormResult x, Widget) - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod App where - approot = ApprootMaster $ appRoot . settings - - -- Store session data on the client in encrypted cookies, - -- default session idle timeout is 120 minutes - makeSessionBackend _ = do - key <- getKey "config/client_session_key.aes" - return . Just $ clientSessionBackend key 120 - - defaultLayout widget = do - master <- getYesod - mmsg <- getMessage - - -- We break up the default layout into two components: - -- default-layout is the contents of the body tag, and - -- default-layout-wrapper is the entire page. Since the final - -- value passed to hamletToRepHtml cannot be a widget, this allows - -- you to use normal widget features in default-layout. - - pc <- widgetToPageContent $ do - $(widgetFile "normalize") - addStylesheet $ StaticR css_bootstrap_css - $(widgetFile "default-layout") - hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") - - -- This is done to provide an optimization for serving static files from - -- a separate domain. Please see the staticRoot setting in Settings.hs - urlRenderOverride y (StaticR s) = - Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s - urlRenderOverride _ _ = Nothing - - -- The page to be redirected to when authentication is required. - authRoute _ = Just $ AuthR LoginR - - messageLogger y loc level msg = - formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y) - - -- This function creates static content files in the static folder - -- and names them based on a hash of their content. This allows - -- expiration dates to be set far in the future without worry of - -- users receiving stale content. - addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) - - -- Place Javascript at bottom of the body tag so the rest of the page loads first - jsLoader _ = BottomOfBody - --- How to run database actions. -instance YesodPersist App where - type YesodPersistBackend App = SqlPersist - runDB f = do - master <- getYesod - Database.Persist.Store.runPool - (persistConfig master) - f - (connPool master) - -instance YesodAuth App where - type AuthId App = UserId - - -- Where to send a user after successful login - loginDest _ = HomeR - -- Where to send a user after logout - logoutDest _ = HomeR - - getAuthId creds = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (Entity uid _) -> return $ Just uid - Nothing -> do - fmap Just $ insert $ User (credsIdent creds) Nothing - - -- You can add other plugins like BrowserID, email or OAuth here - authPlugins _ = [authBrowserId, authGoogleEmail] - - authHttpManager = httpManager - --- This instance is required to use forms. You can modify renderMessage to --- achieve customized and internationalized form validation messages. -instance RenderMessage App FormMessage where - renderMessage _ _ = defaultFormMessage - --- Note: previous versions of the scaffolding included a deliver function to --- send emails. Unfortunately, there are too many different options for us to --- give a reasonable default. Instead, the information is available on the --- wiki: --- --- https://github.com/yesodweb/yesod/wiki/Sending-email diff --git a/msgpack-idl-web/src/Handler/Home.hs b/msgpack-idl-web/src/Handler/Home.hs deleted file mode 100644 index c0ee0c2..0000000 --- a/msgpack-idl-web/src/Handler/Home.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TupleSections, OverloadedStrings, ViewPatterns #-} -module Handler.Home where - -import Import - -import Data.Maybe -import qualified Data.Text.Lazy as LT -import qualified Filesystem as FS -import Shelly -import Text.Shakespeare.Text - -defaultCode :: Text -defaultCode = [st| -message hoge { - 0: int moge - 1: map hage -} - -service test { - void foo(0: hoge x) -} -|] - -getHomeR :: Handler RepHtml -getHomeR = do - let submission = Nothing :: Maybe (FileInfo, Text) - handlerName = "getHomeR" :: Text - defaultLayout $ do - aDomId <- lift newIdent - setTitle "MessagePack IDL Code Generator" - $(widgetFile "homepage") - -postHomeR :: Handler (ContentType, Content) -postHomeR = do - (fromMaybe "noname" -> name, source, lang, namespace) <- runInputPost $ (,,,) - <$> iopt textField "name" - <*> ireq textField "source" - <*> ireq textField "lang" - <*> iopt textField "namespace" - - let tarname = [lt|#{name}.tar.bz2|] - idlname = [lt|#{name}.idl|] - - let opts = map LT.fromStrict $ case (lang, namespace) of - ("cpp", Just ns) -> ["-n", ns] - ("java", Just pn) -> ["-p", pn] - ("ruby", Just mn) -> ["-m", mn] - _ -> [] - - archive <- shelly $ do - withTmpDir $ \tmppath -> chdir tmppath $ do - writefile (fromText idlname) $ LT.fromStrict source - run_ "mpidl" $ [LT.fromStrict lang, "-o", [lt|#{name}|], idlname] ++ opts - run_ "tar" ["-cjf", tarname, [lt|#{name}|]] - p <- pwd - liftIO $ FS.readFile $ p fromText tarname - - setHeader "Content-Disposition" [st|attachment; filename="#{tarname}"|] - return ("application/x-bz2", toContent archive) diff --git a/msgpack-idl-web/src/Import.hs b/msgpack-idl-web/src/Import.hs deleted file mode 100644 index 641de38..0000000 --- a/msgpack-idl-web/src/Import.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Import - ( module Prelude - , module Yesod - , module Foundation - , module Settings.StaticFiles - , module Settings.Development - , module Data.Monoid - , module Control.Applicative - , Text -#if __GLASGOW_HASKELL__ < 704 - , (<>) -#endif - ) where - -import Prelude hiding (writeFile, readFile, head, tail, init, last) -import Yesod hiding (Route(..)) -import Foundation -import Data.Monoid (Monoid (mappend, mempty, mconcat)) -import Control.Applicative ((<$>), (<*>), pure) -import Data.Text (Text) -import Settings.StaticFiles -import Settings.Development - -#if __GLASGOW_HASKELL__ < 704 -infixr 5 <> -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -#endif diff --git a/msgpack-idl-web/src/Model.hs b/msgpack-idl-web/src/Model.hs deleted file mode 100644 index 12f6697..0000000 --- a/msgpack-idl-web/src/Model.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Model where - -import Prelude -import Yesod -import Data.Text (Text) -import Database.Persist.Quasi - - --- You can define all of your database entities in the entities file. --- You can find more information on persistent and how to declare entities --- at: --- http://www.yesodweb.com/book/persistent/ -share [mkPersist sqlSettings, mkMigrate "migrateAll"] - $(persistFileWith lowerCaseSettings "config/models") diff --git a/msgpack-idl-web/src/Settings.hs b/msgpack-idl-web/src/Settings.hs deleted file mode 100644 index f9f7075..0000000 --- a/msgpack-idl-web/src/Settings.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | Settings are centralized, as much as possible, into this file. This --- includes database connection settings, static file locations, etc. --- In addition, you can configure a number of different aspects of Yesod --- by overriding methods in the Yesod typeclass. That instance is --- declared in the Foundation.hs file. -module Settings - ( widgetFile - , PersistConfig - , staticRoot - , staticDir - , Extra (..) - , parseExtra - ) where - -import Prelude -import Text.Shakespeare.Text (st) -import Language.Haskell.TH.Syntax -import Database.Persist.Sqlite (SqliteConf) -import Yesod.Default.Config -import qualified Yesod.Default.Util -import Data.Text (Text) -import Data.Yaml -import Control.Applicative -import Settings.Development - --- | Which Persistent backend this site is using. -type PersistConfig = SqliteConf - --- Static setting below. Changing these requires a recompile - --- | The location of static files on your system. This is a file system --- path. The default value works properly with your scaffolded site. -staticDir :: FilePath -staticDir = "static" - --- | The base URL for your static files. As you can see by the default --- value, this can simply be "static" appended to your application root. --- A powerful optimization can be serving static files from a separate --- domain name. This allows you to use a web server optimized for static --- files, more easily set expires and cache values, and avoid possibly --- costly transference of cookies on static files. For more information, --- please see: --- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain --- --- If you change the resource pattern for StaticR in Foundation.hs, you will --- have to make a corresponding change here. --- --- To see how this value is used, see urlRenderOverride in Foundation.hs -staticRoot :: AppConfig DefaultEnv x -> Text -staticRoot conf = [st|#{appRoot conf}/static|] - - --- The rest of this file contains settings which rarely need changing by a --- user. - -widgetFile :: String -> Q Exp -widgetFile = if development then Yesod.Default.Util.widgetFileReload - else Yesod.Default.Util.widgetFileNoReload - -data Extra = Extra - { extraCopyright :: Text - , extraAnalytics :: Maybe Text -- ^ Google Analytics - } deriving Show - -parseExtra :: DefaultEnv -> Object -> Parser Extra -parseExtra _ o = Extra - <$> o .: "copyright" - <*> o .:? "analytics" diff --git a/msgpack-idl-web/src/Settings/Development.hs b/msgpack-idl-web/src/Settings/Development.hs deleted file mode 100644 index 73613f0..0000000 --- a/msgpack-idl-web/src/Settings/Development.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Settings.Development where - -import Prelude - -development :: Bool -development = -#if DEVELOPMENT - True -#else - False -#endif - -production :: Bool -production = not development diff --git a/msgpack-idl-web/src/Settings/StaticFiles.hs b/msgpack-idl-web/src/Settings/StaticFiles.hs deleted file mode 100644 index 2510795..0000000 --- a/msgpack-idl-web/src/Settings/StaticFiles.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Settings.StaticFiles where - -import Prelude (IO) -import Yesod.Static -import qualified Yesod.Static as Static -import Settings (staticDir) -import Settings.Development - --- | use this to create your static file serving site -staticSite :: IO Static.Static -staticSite = if development then Static.staticDevel staticDir - else Static.static staticDir - --- | This generates easy references to files in the static directory at compile time, --- giving you compile-time verification that referenced files exist. --- Warning: any files added to your static directory during run-time can't be --- accessed this way. You'll have to use their FilePath or URL to access them. -$(staticFiles Settings.staticDir) diff --git a/msgpack-idl-web/src/devel.hs b/msgpack-idl-web/src/devel.hs deleted file mode 100644 index 6ce1f7f..0000000 --- a/msgpack-idl-web/src/devel.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE PackageImports #-} -import "mpidl-web" Application (getApplicationDev) -import Network.Wai.Handler.Warp - (runSettings, defaultSettings, settingsPort) -import Control.Concurrent (forkIO) -import System.Directory (doesFileExist, removeFile) -import System.Exit (exitSuccess) -import Control.Concurrent (threadDelay) - -main :: IO () -main = do - putStrLn "Starting devel application" - (port, app) <- getApplicationDev - forkIO $ runSettings defaultSettings - { settingsPort = port - } app - loop - -loop :: IO () -loop = do - threadDelay 100000 - e <- doesFileExist "dist/devel-terminate" - if e then terminateDevel else loop - -terminateDevel :: IO () -terminateDevel = exitSuccess diff --git a/msgpack-idl-web/src/main.hs b/msgpack-idl-web/src/main.hs deleted file mode 100644 index a059fcb..0000000 --- a/msgpack-idl-web/src/main.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Prelude (IO) -import Yesod.Default.Config (fromArgs) -import Yesod.Default.Main (defaultMain) -import Settings (parseExtra) -import Application (makeApplication) - -main :: IO () -main = defaultMain (fromArgs parseExtra) makeApplication diff --git a/msgpack-idl-web/static/css/bootstrap.css b/msgpack-idl-web/static/css/bootstrap.css deleted file mode 100644 index 495188a..0000000 --- a/msgpack-idl-web/static/css/bootstrap.css +++ /dev/null @@ -1,3990 +0,0 @@ -/*! - * Bootstrap v2.0.2 - * - * Copyright 2012 Twitter, Inc - * Licensed under the Apache License v2.0 - * http://www.apache.org/licenses/LICENSE-2.0 - * - * Designed and built with all the love in the world @twitter by @mdo and @fat. - */ -article, -aside, -details, -figcaption, -figure, -footer, -header, -hgroup, -nav, -section { - display: block; -} -audio, -canvas, -video { - display: inline-block; - *display: inline; - *zoom: 1; -} -audio:not([controls]) { - display: none; -} -html { - font-size: 100%; - -webkit-text-size-adjust: 100%; - -ms-text-size-adjust: 100%; -} -a:focus { - outline: thin dotted #333; - outline: 5px auto -webkit-focus-ring-color; - outline-offset: -2px; -} -a:hover, -a:active { - outline: 0; -} -sub, -sup { - position: relative; - font-size: 75%; - line-height: 0; - vertical-align: baseline; -} -sup { - top: -0.5em; -} -sub { - bottom: -0.25em; -} -img { - height: auto; - border: 0; - -ms-interpolation-mode: bicubic; - vertical-align: middle; -} -button, -input, -select, -textarea { - margin: 0; - font-size: 100%; - vertical-align: middle; -} -button, -input { - *overflow: visible; - line-height: normal; -} -button::-moz-focus-inner, -input::-moz-focus-inner { - padding: 0; - border: 0; -} -button, -input[type="button"], -input[type="reset"], -input[type="submit"] { - cursor: pointer; - -webkit-appearance: button; -} -input[type="search"] { - -webkit-appearance: textfield; - -webkit-box-sizing: content-box; - -moz-box-sizing: content-box; - box-sizing: content-box; -} -input[type="search"]::-webkit-search-decoration, -input[type="search"]::-webkit-search-cancel-button { - -webkit-appearance: none; -} -textarea { - overflow: auto; - vertical-align: top; -} -.clearfix { - *zoom: 1; -} -.clearfix:before, -.clearfix:after { - display: table; - content: ""; -} -.clearfix:after { - clear: both; -} -.hide-text { - overflow: hidden; - text-indent: 100%; - white-space: nowrap; -} -.input-block-level { - display: block; - width: 100%; - min-height: 28px; - /* Make inputs at least the height of their button counterpart */ - - /* Makes inputs behave like true block-level elements */ - - -webkit-box-sizing: border-box; - -moz-box-sizing: border-box; - -ms-box-sizing: border-box; - box-sizing: border-box; -} -body { - margin: 0; - font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; - font-size: 13px; - line-height: 18px; - color: #333333; - background-color: #ffffff; -} -a { - color: #0088cc; - text-decoration: none; -} -a:hover { - color: #005580; - text-decoration: underline; -} -.row { - margin-left: -20px; - *zoom: 1; -} -.row:before, -.row:after { - display: table; - content: ""; -} -.row:after { - clear: both; -} -[class*="span"] { - float: left; - margin-left: 20px; -} -.container, -.navbar-fixed-top .container, -.navbar-fixed-bottom .container { - width: 940px; -} -.span12 { - width: 940px; -} -.span11 { - width: 860px; -} -.span10 { - width: 780px; -} -.span9 { - width: 700px; -} -.span8 { - width: 620px; -} -.span7 { - width: 540px; -} -.span6 { - width: 460px; -} -.span5 { - width: 380px; -} -.span4 { - width: 300px; -} -.span3 { - width: 220px; -} -.span2 { - width: 140px; -} -.span1 { - width: 60px; -} -.offset12 { - margin-left: 980px; -} -.offset11 { - margin-left: 900px; -} -.offset10 { - margin-left: 820px; -} -.offset9 { - margin-left: 740px; -} -.offset8 { - margin-left: 660px; -} -.offset7 { - margin-left: 580px; -} -.offset6 { - margin-left: 500px; -} -.offset5 { - margin-left: 420px; -} -.offset4 { - margin-left: 340px; -} -.offset3 { - margin-left: 260px; -} -.offset2 { - margin-left: 180px; -} -.offset1 { - margin-left: 100px; -} -.row-fluid { - width: 100%; - *zoom: 1; -} -.row-fluid:before, -.row-fluid:after { - display: table; - content: ""; -} -.row-fluid:after { - clear: both; -} -.row-fluid > [class*="span"] { - float: left; - margin-left: 2.127659574%; -} -.row-fluid > [class*="span"]:first-child { - margin-left: 0; -} -.row-fluid > .span12 { - width: 99.99999998999999%; -} -.row-fluid > .span11 { - width: 91.489361693%; -} -.row-fluid > .span10 { - width: 82.97872339599999%; -} -.row-fluid > .span9 { - width: 74.468085099%; -} -.row-fluid > .span8 { - width: 65.95744680199999%; -} -.row-fluid > .span7 { - width: 57.446808505%; -} -.row-fluid > .span6 { - width: 48.93617020799999%; -} -.row-fluid > .span5 { - width: 40.425531911%; -} -.row-fluid > .span4 { - width: 31.914893614%; -} -.row-fluid > .span3 { - width: 23.404255317%; -} -.row-fluid > .span2 { - width: 14.89361702%; -} -.row-fluid > .span1 { - width: 6.382978723%; -} -.container { - margin-left: auto; - margin-right: auto; - *zoom: 1; -} -.container:before, -.container:after { - display: table; - content: ""; -} -.container:after { - clear: both; -} -.container-fluid { - padding-left: 20px; - padding-right: 20px; - *zoom: 1; -} -.container-fluid:before, -.container-fluid:after { - display: table; - content: ""; -} -.container-fluid:after { - clear: both; -} -p { - margin: 0 0 9px; - font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; - font-size: 13px; - line-height: 18px; -} -p small { - font-size: 11px; - color: #999999; -} -.lead { - margin-bottom: 18px; - font-size: 20px; - font-weight: 200; - line-height: 27px; -} -h1, -h2, -h3, -h4, -h5, -h6 { - margin: 0; - font-family: inherit; - font-weight: bold; - color: inherit; - text-rendering: optimizelegibility; -} -h1 small, -h2 small, -h3 small, -h4 small, -h5 small, -h6 small { - font-weight: normal; - color: #999999; -} -h1 { - font-size: 30px; - line-height: 36px; -} -h1 small { - font-size: 18px; -} -h2 { - font-size: 24px; - line-height: 36px; -} -h2 small { - font-size: 18px; -} -h3 { - line-height: 27px; - font-size: 18px; -} -h3 small { - font-size: 14px; -} -h4, -h5, -h6 { - line-height: 18px; -} -h4 { - font-size: 14px; -} -h4 small { - font-size: 12px; -} -h5 { - font-size: 12px; -} -h6 { - font-size: 11px; - color: #999999; - text-transform: uppercase; -} -.page-header { - padding-bottom: 17px; - margin: 18px 0; - border-bottom: 1px solid #eeeeee; -} -.page-header h1 { - line-height: 1; -} -ul, -ol { - padding: 0; - margin: 0 0 9px 25px; -} -ul ul, -ul ol, -ol ol, -ol ul { - margin-bottom: 0; -} -ul { - list-style: disc; -} -ol { - list-style: decimal; -} -li { - line-height: 18px; -} -ul.unstyled, -ol.unstyled { - margin-left: 0; - list-style: none; -} -dl { - margin-bottom: 18px; -} -dt, -dd { - line-height: 18px; -} -dt { - font-weight: bold; - line-height: 17px; -} -dd { - margin-left: 9px; -} -.dl-horizontal dt { - float: left; - clear: left; - width: 120px; - text-align: right; -} -.dl-horizontal dd { - margin-left: 130px; -} -hr { - margin: 18px 0; - border: 0; - border-top: 1px solid #eeeeee; - border-bottom: 1px solid #ffffff; -} -strong { - font-weight: bold; -} -em { - font-style: italic; -} -.muted { - color: #999999; -} -abbr[title] { - border-bottom: 1px dotted #ddd; - cursor: help; -} -abbr.initialism { - font-size: 90%; - text-transform: uppercase; -} -blockquote { - padding: 0 0 0 15px; - margin: 0 0 18px; - border-left: 5px solid #eeeeee; -} -blockquote p { - margin-bottom: 0; - font-size: 16px; - font-weight: 300; - line-height: 22.5px; -} -blockquote small { - display: block; - line-height: 18px; - color: #999999; -} -blockquote small:before { - content: '\2014 \00A0'; -} -blockquote.pull-right { - float: right; - padding-left: 0; - padding-right: 15px; - border-left: 0; - border-right: 5px solid #eeeeee; -} -blockquote.pull-right p, -blockquote.pull-right small { - text-align: right; -} -q:before, -q:after, -blockquote:before, -blockquote:after { - content: ""; -} -address { - display: block; - margin-bottom: 18px; - line-height: 18px; - font-style: normal; -} -small { - font-size: 100%; -} -cite { - font-style: normal; -} -code, -pre { - padding: 0 3px 2px; - font-family: Menlo, Monaco, "Courier New", monospace; - font-size: 12px; - color: #333333; - -webkit-border-radius: 3px; - -moz-border-radius: 3px; - border-radius: 3px; -} -code { - padding: 2px 4px; - color: #d14; - background-color: #f7f7f9; - border: 1px solid #e1e1e8; -} -pre { - display: block; - padding: 8.5px; - margin: 0 0 9px; - font-size: 12.025px; - line-height: 18px; - background-color: #f5f5f5; - border: 1px solid #ccc; - border: 1px solid rgba(0, 0, 0, 0.15); - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; - white-space: pre; - white-space: pre-wrap; - word-break: break-all; - word-wrap: break-word; -} -pre.prettyprint { - margin-bottom: 18px; -} -pre code { - padding: 0; - color: inherit; - background-color: transparent; - border: 0; -} -.pre-scrollable { - max-height: 340px; - overflow-y: scroll; -} -form { - margin: 0 0 18px; -} -fieldset { - padding: 0; - margin: 0; - border: 0; -} -legend { - display: block; - width: 100%; - padding: 0; - margin-bottom: 27px; - font-size: 19.5px; - line-height: 36px; - color: #333333; - border: 0; - border-bottom: 1px solid #eee; -} -legend small { - font-size: 13.5px; - color: #999999; -} -label, -input, -button, -select, -textarea { - font-size: 13px; - font-weight: normal; - line-height: 18px; -} -input, -button, -select, -textarea { - font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; -} -label { - display: block; - margin-bottom: 5px; - color: #333333; -} -input, -textarea, -select, -.uneditable-input { - display: inline-block; - width: 210px; - height: 18px; - padding: 4px; - margin-bottom: 9px; - font-size: 13px; - line-height: 18px; - color: #555555; - border: 1px solid #cccccc; - -webkit-border-radius: 3px; - -moz-border-radius: 3px; - border-radius: 3px; -} -.uneditable-textarea { - width: auto; - height: auto; -} -label input, -label textarea, -label select { - display: block; -} -input[type="image"], -input[type="checkbox"], -input[type="radio"] { - width: auto; - height: auto; - padding: 0; - margin: 3px 0; - *margin-top: 0; - /* IE7 */ - - line-height: normal; - cursor: pointer; - -webkit-border-radius: 0; - -moz-border-radius: 0; - border-radius: 0; - border: 0 \9; - /* IE9 and down */ - -} -input[type="image"] { - border: 0; -} -input[type="file"] { - width: auto; - padding: initial; - line-height: initial; - border: initial; - background-color: #ffffff; - background-color: initial; - -webkit-box-shadow: none; - -moz-box-shadow: none; - box-shadow: none; -} -input[type="button"], -input[type="reset"], -input[type="submit"] { - width: auto; - height: auto; -} -select, -input[type="file"] { - height: 28px; - /* In IE7, the height of the select element cannot be changed by height, only font-size */ - - *margin-top: 4px; - /* For IE7, add top margin to align select with labels */ - - line-height: 28px; -} -input[type="file"] { - line-height: 18px \9; -} -select { - width: 220px; - background-color: #ffffff; -} -select[multiple], -select[size] { - height: auto; -} -input[type="image"] { - -webkit-box-shadow: none; - -moz-box-shadow: none; - box-shadow: none; -} -textarea { - height: auto; -} -input[type="hidden"] { - display: none; -} -.radio, -.checkbox { - padding-left: 18px; -} -.radio input[type="radio"], -.checkbox input[type="checkbox"] { - float: left; - margin-left: -18px; -} -.controls > .radio:first-child, -.controls > .checkbox:first-child { - padding-top: 5px; -} -.radio.inline, -.checkbox.inline { - display: inline-block; - padding-top: 5px; - margin-bottom: 0; - vertical-align: middle; -} -.radio.inline + .radio.inline, -.checkbox.inline + .checkbox.inline { - margin-left: 10px; -} -input, -textarea { - -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); - -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); - box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); - -webkit-transition: border linear 0.2s, box-shadow linear 0.2s; - -moz-transition: border linear 0.2s, box-shadow linear 0.2s; - -ms-transition: border linear 0.2s, box-shadow linear 0.2s; - -o-transition: border linear 0.2s, box-shadow linear 0.2s; - transition: border linear 0.2s, box-shadow linear 0.2s; -} -input:focus, -textarea:focus { - border-color: rgba(82, 168, 236, 0.8); - -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6); - -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6); - box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6); - outline: 0; - outline: thin dotted \9; - /* IE6-9 */ - -} -input[type="file"]:focus, -input[type="radio"]:focus, -input[type="checkbox"]:focus, -select:focus { - -webkit-box-shadow: none; - -moz-box-shadow: none; - box-shadow: none; - outline: thin dotted #333; - outline: 5px auto -webkit-focus-ring-color; - outline-offset: -2px; -} -.input-mini { - width: 60px; -} -.input-small { - width: 90px; -} -.input-medium { - width: 150px; -} -.input-large { - width: 210px; -} -.input-xlarge { - width: 270px; -} -.input-xxlarge { - width: 530px; -} -input[class*="span"], -select[class*="span"], -textarea[class*="span"], -.uneditable-input { - float: none; - margin-left: 0; -} -input, -textarea, -.uneditable-input { - margin-left: 0; -} -input.span12, textarea.span12, .uneditable-input.span12 { - width: 930px; -} -input.span11, textarea.span11, .uneditable-input.span11 { - width: 850px; -} -input.span10, textarea.span10, .uneditable-input.span10 { - width: 770px; -} -input.span9, textarea.span9, .uneditable-input.span9 { - width: 690px; -} -input.span8, textarea.span8, .uneditable-input.span8 { - width: 610px; -} -input.span7, textarea.span7, .uneditable-input.span7 { - width: 530px; -} -input.span6, textarea.span6, .uneditable-input.span6 { - width: 450px; -} -input.span5, textarea.span5, .uneditable-input.span5 { - width: 370px; -} -input.span4, textarea.span4, .uneditable-input.span4 { - width: 290px; -} -input.span3, textarea.span3, .uneditable-input.span3 { - width: 210px; -} -input.span2, textarea.span2, .uneditable-input.span2 { - width: 130px; -} -input.span1, textarea.span1, .uneditable-input.span1 { - width: 50px; -} -input[disabled], -select[disabled], -textarea[disabled], -input[readonly], -select[readonly], -textarea[readonly] { - background-color: #eeeeee; - border-color: #ddd; - cursor: not-allowed; -} -.control-group.warning > label, -.control-group.warning .help-block, -.control-group.warning .help-inline { - color: #c09853; -} -.control-group.warning input, -.control-group.warning select, -.control-group.warning textarea { - color: #c09853; - border-color: #c09853; -} -.control-group.warning input:focus, -.control-group.warning select:focus, -.control-group.warning textarea:focus { - border-color: #a47e3c; - -webkit-box-shadow: 0 0 6px #dbc59e; - -moz-box-shadow: 0 0 6px #dbc59e; - box-shadow: 0 0 6px #dbc59e; -} -.control-group.warning .input-prepend .add-on, -.control-group.warning .input-append .add-on { - color: #c09853; - background-color: #fcf8e3; - border-color: #c09853; -} -.control-group.error > label, -.control-group.error .help-block, -.control-group.error .help-inline { - color: #b94a48; -} -.control-group.error input, -.control-group.error select, -.control-group.error textarea { - color: #b94a48; - border-color: #b94a48; -} -.control-group.error input:focus, -.control-group.error select:focus, -.control-group.error textarea:focus { - border-color: #953b39; - -webkit-box-shadow: 0 0 6px #d59392; - -moz-box-shadow: 0 0 6px #d59392; - box-shadow: 0 0 6px #d59392; -} -.control-group.error .input-prepend .add-on, -.control-group.error .input-append .add-on { - color: #b94a48; - background-color: #f2dede; - border-color: #b94a48; -} -.control-group.success > label, -.control-group.success .help-block, -.control-group.success .help-inline { - color: #468847; -} -.control-group.success input, -.control-group.success select, -.control-group.success textarea { - color: #468847; - border-color: #468847; -} -.control-group.success input:focus, -.control-group.success select:focus, -.control-group.success textarea:focus { - border-color: #356635; - -webkit-box-shadow: 0 0 6px #7aba7b; - -moz-box-shadow: 0 0 6px #7aba7b; - box-shadow: 0 0 6px #7aba7b; -} -.control-group.success .input-prepend .add-on, -.control-group.success .input-append .add-on { - color: #468847; - background-color: #dff0d8; - border-color: #468847; -} -input:focus:required:invalid, -textarea:focus:required:invalid, -select:focus:required:invalid { - color: #b94a48; - border-color: #ee5f5b; -} -input:focus:required:invalid:focus, -textarea:focus:required:invalid:focus, -select:focus:required:invalid:focus { - border-color: #e9322d; - -webkit-box-shadow: 0 0 6px #f8b9b7; - -moz-box-shadow: 0 0 6px #f8b9b7; - box-shadow: 0 0 6px #f8b9b7; -} -.form-actions { - padding: 17px 20px 18px; - margin-top: 18px; - margin-bottom: 18px; - background-color: #eeeeee; - border-top: 1px solid #ddd; - *zoom: 1; -} -.form-actions:before, -.form-actions:after { - display: table; - content: ""; -} -.form-actions:after { - clear: both; -} -.uneditable-input { - display: block; - background-color: #ffffff; - border-color: #eee; - -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.025); - -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.025); - box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.025); - cursor: not-allowed; -} -:-moz-placeholder { - color: #999999; -} -::-webkit-input-placeholder { - color: #999999; -} -.help-block, -.help-inline { - color: #555555; -} -.help-block { - display: block; - margin-bottom: 9px; -} -.help-inline { - display: inline-block; - *display: inline; - /* IE7 inline-block hack */ - - *zoom: 1; - vertical-align: middle; - padding-left: 5px; -} -.input-prepend, -.input-append { - margin-bottom: 5px; -} -.input-prepend input, -.input-append input, -.input-prepend select, -.input-append select, -.input-prepend .uneditable-input, -.input-append .uneditable-input { - *margin-left: 0; - -webkit-border-radius: 0 3px 3px 0; - -moz-border-radius: 0 3px 3px 0; - border-radius: 0 3px 3px 0; -} -.input-prepend input:focus, -.input-append input:focus, -.input-prepend select:focus, -.input-append select:focus, -.input-prepend .uneditable-input:focus, -.input-append .uneditable-input:focus { - position: relative; - z-index: 2; -} -.input-prepend .uneditable-input, -.input-append .uneditable-input { - border-left-color: #ccc; -} -.input-prepend .add-on, -.input-append .add-on { - display: inline-block; - width: auto; - min-width: 16px; - height: 18px; - padding: 4px 5px; - font-weight: normal; - line-height: 18px; - text-align: center; - text-shadow: 0 1px 0 #ffffff; - vertical-align: middle; - background-color: #eeeeee; - border: 1px solid #ccc; -} -.input-prepend .add-on, -.input-append .add-on, -.input-prepend .btn, -.input-append .btn { - -webkit-border-radius: 3px 0 0 3px; - -moz-border-radius: 3px 0 0 3px; - border-radius: 3px 0 0 3px; -} -.input-prepend .active, -.input-append .active { - background-color: #a9dba9; - border-color: #46a546; -} -.input-prepend .add-on, -.input-prepend .btn { - margin-right: -1px; -} -.input-append input, -.input-append select .uneditable-input { - -webkit-border-radius: 3px 0 0 3px; - -moz-border-radius: 3px 0 0 3px; - border-radius: 3px 0 0 3px; -} -.input-append .uneditable-input { - border-left-color: #eee; - border-right-color: #ccc; -} -.input-append .add-on, -.input-append .btn { - margin-left: -1px; - -webkit-border-radius: 0 3px 3px 0; - -moz-border-radius: 0 3px 3px 0; - border-radius: 0 3px 3px 0; -} -.input-prepend.input-append input, -.input-prepend.input-append select, -.input-prepend.input-append .uneditable-input { - -webkit-border-radius: 0; - -moz-border-radius: 0; - border-radius: 0; -} -.input-prepend.input-append .add-on:first-child, -.input-prepend.input-append .btn:first-child { - margin-right: -1px; - -webkit-border-radius: 3px 0 0 3px; - -moz-border-radius: 3px 0 0 3px; - border-radius: 3px 0 0 3px; -} -.input-prepend.input-append .add-on:last-child, -.input-prepend.input-append .btn:last-child { - margin-left: -1px; - -webkit-border-radius: 0 3px 3px 0; - -moz-border-radius: 0 3px 3px 0; - border-radius: 0 3px 3px 0; -} -.search-query { - padding-left: 14px; - padding-right: 14px; - margin-bottom: 0; - -webkit-border-radius: 14px; - -moz-border-radius: 14px; - border-radius: 14px; -} -.form-search input, -.form-inline input, -.form-horizontal input, -.form-search textarea, -.form-inline textarea, -.form-horizontal textarea, -.form-search select, -.form-inline select, -.form-horizontal select, -.form-search .help-inline, -.form-inline .help-inline, -.form-horizontal .help-inline, -.form-search .uneditable-input, -.form-inline .uneditable-input, -.form-horizontal .uneditable-input, -.form-search .input-prepend, -.form-inline .input-prepend, -.form-horizontal .input-prepend, -.form-search .input-append, -.form-inline .input-append, -.form-horizontal .input-append { - display: inline-block; - margin-bottom: 0; -} -.form-search .hide, -.form-inline .hide, -.form-horizontal .hide { - display: none; -} -.form-search label, -.form-inline label { - display: inline-block; -} -.form-search .input-append, -.form-inline .input-append, -.form-search .input-prepend, -.form-inline .input-prepend { - margin-bottom: 0; -} -.form-search .radio, -.form-search .checkbox, -.form-inline .radio, -.form-inline .checkbox { - padding-left: 0; - margin-bottom: 0; - vertical-align: middle; -} -.form-search .radio input[type="radio"], -.form-search .checkbox input[type="checkbox"], -.form-inline .radio input[type="radio"], -.form-inline .checkbox input[type="checkbox"] { - float: left; - margin-left: 0; - margin-right: 3px; -} -.control-group { - margin-bottom: 9px; -} -legend + .control-group { - margin-top: 18px; - -webkit-margin-top-collapse: separate; -} -.form-horizontal .control-group { - margin-bottom: 18px; - *zoom: 1; -} -.form-horizontal .control-group:before, -.form-horizontal .control-group:after { - display: table; - content: ""; -} -.form-horizontal .control-group:after { - clear: both; -} -.form-horizontal .control-label { - float: left; - width: 140px; - padding-top: 5px; - text-align: right; -} -.form-horizontal .controls { - margin-left: 160px; - /* Super jank IE7 fix to ensure the inputs in .input-append and input-prepend don't inherit the margin of the parent, in this case .controls */ - - *display: inline-block; - *margin-left: 0; - *padding-left: 20px; -} -.form-horizontal .help-block { - margin-top: 9px; - margin-bottom: 0; -} -.form-horizontal .form-actions { - padding-left: 160px; -} -table { - max-width: 100%; - border-collapse: collapse; - border-spacing: 0; - background-color: transparent; -} -.table { - width: 100%; - margin-bottom: 18px; -} -.table th, -.table td { - padding: 8px; - line-height: 18px; - text-align: left; - vertical-align: top; - border-top: 1px solid #dddddd; -} -.table th { - font-weight: bold; -} -.table thead th { - vertical-align: bottom; -} -.table colgroup + thead tr:first-child th, -.table colgroup + thead tr:first-child td, -.table thead:first-child tr:first-child th, -.table thead:first-child tr:first-child td { - border-top: 0; -} -.table tbody + tbody { - border-top: 2px solid #dddddd; -} -.table-condensed th, -.table-condensed td { - padding: 4px 5px; -} -.table-bordered { - border: 1px solid #dddddd; - border-left: 0; - border-collapse: separate; - *border-collapse: collapsed; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.table-bordered th, -.table-bordered td { - border-left: 1px solid #dddddd; -} -.table-bordered thead:first-child tr:first-child th, -.table-bordered tbody:first-child tr:first-child th, -.table-bordered tbody:first-child tr:first-child td { - border-top: 0; -} -.table-bordered thead:first-child tr:first-child th:first-child, -.table-bordered tbody:first-child tr:first-child td:first-child { - -webkit-border-radius: 4px 0 0 0; - -moz-border-radius: 4px 0 0 0; - border-radius: 4px 0 0 0; -} -.table-bordered thead:first-child tr:first-child th:last-child, -.table-bordered tbody:first-child tr:first-child td:last-child { - -webkit-border-radius: 0 4px 0 0; - -moz-border-radius: 0 4px 0 0; - border-radius: 0 4px 0 0; -} -.table-bordered thead:last-child tr:last-child th:first-child, -.table-bordered tbody:last-child tr:last-child td:first-child { - -webkit-border-radius: 0 0 0 4px; - -moz-border-radius: 0 0 0 4px; - border-radius: 0 0 0 4px; -} -.table-bordered thead:last-child tr:last-child th:last-child, -.table-bordered tbody:last-child tr:last-child td:last-child { - -webkit-border-radius: 0 0 4px 0; - -moz-border-radius: 0 0 4px 0; - border-radius: 0 0 4px 0; -} -.table-striped tbody tr:nth-child(odd) td, -.table-striped tbody tr:nth-child(odd) th { - background-color: #f9f9f9; -} -.table tbody tr:hover td, -.table tbody tr:hover th { - background-color: #f5f5f5; -} -table .span1 { - float: none; - width: 44px; - margin-left: 0; -} -table .span2 { - float: none; - width: 124px; - margin-left: 0; -} -table .span3 { - float: none; - width: 204px; - margin-left: 0; -} -table .span4 { - float: none; - width: 284px; - margin-left: 0; -} -table .span5 { - float: none; - width: 364px; - margin-left: 0; -} -table .span6 { - float: none; - width: 444px; - margin-left: 0; -} -table .span7 { - float: none; - width: 524px; - margin-left: 0; -} -table .span8 { - float: none; - width: 604px; - margin-left: 0; -} -table .span9 { - float: none; - width: 684px; - margin-left: 0; -} -table .span10 { - float: none; - width: 764px; - margin-left: 0; -} -table .span11 { - float: none; - width: 844px; - margin-left: 0; -} -table .span12 { - float: none; - width: 924px; - margin-left: 0; -} -table .span13 { - float: none; - width: 1004px; - margin-left: 0; -} -table .span14 { - float: none; - width: 1084px; - margin-left: 0; -} -table .span15 { - float: none; - width: 1164px; - margin-left: 0; -} -table .span16 { - float: none; - width: 1244px; - margin-left: 0; -} -table .span17 { - float: none; - width: 1324px; - margin-left: 0; -} -table .span18 { - float: none; - width: 1404px; - margin-left: 0; -} -table .span19 { - float: none; - width: 1484px; - margin-left: 0; -} -table .span20 { - float: none; - width: 1564px; - margin-left: 0; -} -table .span21 { - float: none; - width: 1644px; - margin-left: 0; -} -table .span22 { - float: none; - width: 1724px; - margin-left: 0; -} -table .span23 { - float: none; - width: 1804px; - margin-left: 0; -} -table .span24 { - float: none; - width: 1884px; - margin-left: 0; -} -[class^="icon-"], -[class*=" icon-"] { - display: inline-block; - width: 14px; - height: 14px; - line-height: 14px; - vertical-align: text-top; - background-image: url("https://github.com/img/glyphicons-halflings.png"); - background-position: 14px 14px; - background-repeat: no-repeat; - *margin-right: .3em; -} -[class^="icon-"]:last-child, -[class*=" icon-"]:last-child { - *margin-left: 0; -} -.icon-white { - background-image: url("https://github.com/img/glyphicons-halflings-white.png"); -} -.icon-glass { - background-position: 0 0; -} -.icon-music { - background-position: -24px 0; -} -.icon-search { - background-position: -48px 0; -} -.icon-envelope { - background-position: -72px 0; -} -.icon-heart { - background-position: -96px 0; -} -.icon-star { - background-position: -120px 0; -} -.icon-star-empty { - background-position: -144px 0; -} -.icon-user { - background-position: -168px 0; -} -.icon-film { - background-position: -192px 0; -} -.icon-th-large { - background-position: -216px 0; -} -.icon-th { - background-position: -240px 0; -} -.icon-th-list { - background-position: -264px 0; -} -.icon-ok { - background-position: -288px 0; -} -.icon-remove { - background-position: -312px 0; -} -.icon-zoom-in { - background-position: -336px 0; -} -.icon-zoom-out { - background-position: -360px 0; -} -.icon-off { - background-position: -384px 0; -} -.icon-signal { - background-position: -408px 0; -} -.icon-cog { - background-position: -432px 0; -} -.icon-trash { - background-position: -456px 0; -} -.icon-home { - background-position: 0 -24px; -} -.icon-file { - background-position: -24px -24px; -} -.icon-time { - background-position: -48px -24px; -} -.icon-road { - background-position: -72px -24px; -} -.icon-download-alt { - background-position: -96px -24px; -} -.icon-download { - background-position: -120px -24px; -} -.icon-upload { - background-position: -144px -24px; -} -.icon-inbox { - background-position: -168px -24px; -} -.icon-play-circle { - background-position: -192px -24px; -} -.icon-repeat { - background-position: -216px -24px; -} -.icon-refresh { - background-position: -240px -24px; -} -.icon-list-alt { - background-position: -264px -24px; -} -.icon-lock { - background-position: -287px -24px; -} -.icon-flag { - background-position: -312px -24px; -} -.icon-headphones { - background-position: -336px -24px; -} -.icon-volume-off { - background-position: -360px -24px; -} -.icon-volume-down { - background-position: -384px -24px; -} -.icon-volume-up { - background-position: -408px -24px; -} -.icon-qrcode { - background-position: -432px -24px; -} -.icon-barcode { - background-position: -456px -24px; -} -.icon-tag { - background-position: 0 -48px; -} -.icon-tags { - background-position: -25px -48px; -} -.icon-book { - background-position: -48px -48px; -} -.icon-bookmark { - background-position: -72px -48px; -} -.icon-print { - background-position: -96px -48px; -} -.icon-camera { - background-position: -120px -48px; -} -.icon-font { - background-position: -144px -48px; -} -.icon-bold { - background-position: -167px -48px; -} -.icon-italic { - background-position: -192px -48px; -} -.icon-text-height { - background-position: -216px -48px; -} -.icon-text-width { - background-position: -240px -48px; -} -.icon-align-left { - background-position: -264px -48px; -} -.icon-align-center { - background-position: -288px -48px; -} -.icon-align-right { - background-position: -312px -48px; -} -.icon-align-justify { - background-position: -336px -48px; -} -.icon-list { - background-position: -360px -48px; -} -.icon-indent-left { - background-position: -384px -48px; -} -.icon-indent-right { - background-position: -408px -48px; -} -.icon-facetime-video { - background-position: -432px -48px; -} -.icon-picture { - background-position: -456px -48px; -} -.icon-pencil { - background-position: 0 -72px; -} -.icon-map-marker { - background-position: -24px -72px; -} -.icon-adjust { - background-position: -48px -72px; -} -.icon-tint { - background-position: -72px -72px; -} -.icon-edit { - background-position: -96px -72px; -} -.icon-share { - background-position: -120px -72px; -} -.icon-check { - background-position: -144px -72px; -} -.icon-move { - background-position: -168px -72px; -} -.icon-step-backward { - background-position: -192px -72px; -} -.icon-fast-backward { - background-position: -216px -72px; -} -.icon-backward { - background-position: -240px -72px; -} -.icon-play { - background-position: -264px -72px; -} -.icon-pause { - background-position: -288px -72px; -} -.icon-stop { - background-position: -312px -72px; -} -.icon-forward { - background-position: -336px -72px; -} -.icon-fast-forward { - background-position: -360px -72px; -} -.icon-step-forward { - background-position: -384px -72px; -} -.icon-eject { - background-position: -408px -72px; -} -.icon-chevron-left { - background-position: -432px -72px; -} -.icon-chevron-right { - background-position: -456px -72px; -} -.icon-plus-sign { - background-position: 0 -96px; -} -.icon-minus-sign { - background-position: -24px -96px; -} -.icon-remove-sign { - background-position: -48px -96px; -} -.icon-ok-sign { - background-position: -72px -96px; -} -.icon-question-sign { - background-position: -96px -96px; -} -.icon-info-sign { - background-position: -120px -96px; -} -.icon-screenshot { - background-position: -144px -96px; -} -.icon-remove-circle { - background-position: -168px -96px; -} -.icon-ok-circle { - background-position: -192px -96px; -} -.icon-ban-circle { - background-position: -216px -96px; -} -.icon-arrow-left { - background-position: -240px -96px; -} -.icon-arrow-right { - background-position: -264px -96px; -} -.icon-arrow-up { - background-position: -289px -96px; -} -.icon-arrow-down { - background-position: -312px -96px; -} -.icon-share-alt { - background-position: -336px -96px; -} -.icon-resize-full { - background-position: -360px -96px; -} -.icon-resize-small { - background-position: -384px -96px; -} -.icon-plus { - background-position: -408px -96px; -} -.icon-minus { - background-position: -433px -96px; -} -.icon-asterisk { - background-position: -456px -96px; -} -.icon-exclamation-sign { - background-position: 0 -120px; -} -.icon-gift { - background-position: -24px -120px; -} -.icon-leaf { - background-position: -48px -120px; -} -.icon-fire { - background-position: -72px -120px; -} -.icon-eye-open { - background-position: -96px -120px; -} -.icon-eye-close { - background-position: -120px -120px; -} -.icon-warning-sign { - background-position: -144px -120px; -} -.icon-plane { - background-position: -168px -120px; -} -.icon-calendar { - background-position: -192px -120px; -} -.icon-random { - background-position: -216px -120px; -} -.icon-comment { - background-position: -240px -120px; -} -.icon-magnet { - background-position: -264px -120px; -} -.icon-chevron-up { - background-position: -288px -120px; -} -.icon-chevron-down { - background-position: -313px -119px; -} -.icon-retweet { - background-position: -336px -120px; -} -.icon-shopping-cart { - background-position: -360px -120px; -} -.icon-folder-close { - background-position: -384px -120px; -} -.icon-folder-open { - background-position: -408px -120px; -} -.icon-resize-vertical { - background-position: -432px -119px; -} -.icon-resize-horizontal { - background-position: -456px -118px; -} -.dropdown { - position: relative; -} -.dropdown-toggle { - *margin-bottom: -3px; -} -.dropdown-toggle:active, -.open .dropdown-toggle { - outline: 0; -} -.caret { - display: inline-block; - width: 0; - height: 0; - vertical-align: top; - border-left: 4px solid transparent; - border-right: 4px solid transparent; - border-top: 4px solid #000000; - opacity: 0.3; - filter: alpha(opacity=30); - content: ""; -} -.dropdown .caret { - margin-top: 8px; - margin-left: 2px; -} -.dropdown:hover .caret, -.open.dropdown .caret { - opacity: 1; - filter: alpha(opacity=100); -} -.dropdown-menu { - position: absolute; - top: 100%; - left: 0; - z-index: 1000; - float: left; - display: none; - min-width: 160px; - padding: 4px 0; - margin: 0; - list-style: none; - background-color: #ffffff; - border-color: #ccc; - border-color: rgba(0, 0, 0, 0.2); - border-style: solid; - border-width: 1px; - -webkit-border-radius: 0 0 5px 5px; - -moz-border-radius: 0 0 5px 5px; - border-radius: 0 0 5px 5px; - -webkit-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); - -moz-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); - box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); - -webkit-background-clip: padding-box; - -moz-background-clip: padding; - background-clip: padding-box; - *border-right-width: 2px; - *border-bottom-width: 2px; -} -.dropdown-menu.pull-right { - right: 0; - left: auto; -} -.dropdown-menu .divider { - height: 1px; - margin: 8px 1px; - overflow: hidden; - background-color: #e5e5e5; - border-bottom: 1px solid #ffffff; - *width: 100%; - *margin: -5px 0 5px; -} -.dropdown-menu a { - display: block; - padding: 3px 15px; - clear: both; - font-weight: normal; - line-height: 18px; - color: #333333; - white-space: nowrap; -} -.dropdown-menu li > a:hover, -.dropdown-menu .active > a, -.dropdown-menu .active > a:hover { - color: #ffffff; - text-decoration: none; - background-color: #0088cc; -} -.dropdown.open { - *z-index: 1000; -} -.dropdown.open .dropdown-toggle { - color: #ffffff; - background: #ccc; - background: rgba(0, 0, 0, 0.3); -} -.dropdown.open .dropdown-menu { - display: block; -} -.pull-right .dropdown-menu { - left: auto; - right: 0; -} -.dropup .caret, -.navbar-fixed-bottom .dropdown .caret { - border-top: 0; - border-bottom: 4px solid #000000; - content: "\2191"; -} -.dropup .dropdown-menu, -.navbar-fixed-bottom .dropdown .dropdown-menu { - top: auto; - bottom: 100%; - margin-bottom: 1px; -} -.typeahead { - margin-top: 2px; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.well { - min-height: 20px; - padding: 19px; - margin-bottom: 20px; - background-color: #f5f5f5; - border: 1px solid #eee; - border: 1px solid rgba(0, 0, 0, 0.05); - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; - -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.05); - -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.05); - box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.05); -} -.well blockquote { - border-color: #ddd; - border-color: rgba(0, 0, 0, 0.15); -} -.well-large { - padding: 24px; - -webkit-border-radius: 6px; - -moz-border-radius: 6px; - border-radius: 6px; -} -.well-small { - padding: 9px; - -webkit-border-radius: 3px; - -moz-border-radius: 3px; - border-radius: 3px; -} -.fade { - -webkit-transition: opacity 0.15s linear; - -moz-transition: opacity 0.15s linear; - -ms-transition: opacity 0.15s linear; - -o-transition: opacity 0.15s linear; - transition: opacity 0.15s linear; - opacity: 0; -} -.fade.in { - opacity: 1; -} -.collapse { - -webkit-transition: height 0.35s ease; - -moz-transition: height 0.35s ease; - -ms-transition: height 0.35s ease; - -o-transition: height 0.35s ease; - transition: height 0.35s ease; - position: relative; - overflow: hidden; - height: 0; -} -.collapse.in { - height: auto; -} -.close { - float: right; - font-size: 20px; - font-weight: bold; - line-height: 18px; - color: #000000; - text-shadow: 0 1px 0 #ffffff; - opacity: 0.2; - filter: alpha(opacity=20); -} -.close:hover { - color: #000000; - text-decoration: none; - opacity: 0.4; - filter: alpha(opacity=40); - cursor: pointer; -} -.btn { - display: inline-block; - *display: inline; - /* IE7 inline-block hack */ - - *zoom: 1; - padding: 4px 10px 4px; - margin-bottom: 0; - font-size: 13px; - line-height: 18px; - color: #333333; - text-align: center; - text-shadow: 0 1px 1px rgba(255, 255, 255, 0.75); - vertical-align: middle; - background-color: #f5f5f5; - background-image: -moz-linear-gradient(top, #ffffff, #e6e6e6); - background-image: -ms-linear-gradient(top, #ffffff, #e6e6e6); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ffffff), to(#e6e6e6)); - background-image: -webkit-linear-gradient(top, #ffffff, #e6e6e6); - background-image: -o-linear-gradient(top, #ffffff, #e6e6e6); - background-image: linear-gradient(top, #ffffff, #e6e6e6); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffff', endColorstr='#e6e6e6', GradientType=0); - border-color: #e6e6e6 #e6e6e6 #bfbfbf; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); - border: 1px solid #cccccc; - border-bottom-color: #b3b3b3; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; - -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); - -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); - box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); - cursor: pointer; - *margin-left: .3em; -} -.btn:hover, -.btn:active, -.btn.active, -.btn.disabled, -.btn[disabled] { - background-color: #e6e6e6; -} -.btn:active, -.btn.active { - background-color: #cccccc \9; -} -.btn:first-child { - *margin-left: 0; -} -.btn:hover { - color: #333333; - text-decoration: none; - background-color: #e6e6e6; - background-position: 0 -15px; - -webkit-transition: background-position 0.1s linear; - -moz-transition: background-position 0.1s linear; - -ms-transition: background-position 0.1s linear; - -o-transition: background-position 0.1s linear; - transition: background-position 0.1s linear; -} -.btn:focus { - outline: thin dotted #333; - outline: 5px auto -webkit-focus-ring-color; - outline-offset: -2px; -} -.btn.active, -.btn:active { - background-image: none; - -webkit-box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); - -moz-box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); - box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); - background-color: #e6e6e6; - background-color: #d9d9d9 \9; - outline: 0; -} -.btn.disabled, -.btn[disabled] { - cursor: default; - background-image: none; - background-color: #e6e6e6; - opacity: 0.65; - filter: alpha(opacity=65); - -webkit-box-shadow: none; - -moz-box-shadow: none; - box-shadow: none; -} -.btn-large { - padding: 9px 14px; - font-size: 15px; - line-height: normal; - -webkit-border-radius: 5px; - -moz-border-radius: 5px; - border-radius: 5px; -} -.btn-large [class^="icon-"] { - margin-top: 1px; -} -.btn-small { - padding: 5px 9px; - font-size: 11px; - line-height: 16px; -} -.btn-small [class^="icon-"] { - margin-top: -1px; -} -.btn-mini { - padding: 2px 6px; - font-size: 11px; - line-height: 14px; -} -.btn-primary, -.btn-primary:hover, -.btn-warning, -.btn-warning:hover, -.btn-danger, -.btn-danger:hover, -.btn-success, -.btn-success:hover, -.btn-info, -.btn-info:hover, -.btn-inverse, -.btn-inverse:hover { - text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); - color: #ffffff; -} -.btn-primary.active, -.btn-warning.active, -.btn-danger.active, -.btn-success.active, -.btn-info.active, -.btn-inverse.active { - color: rgba(255, 255, 255, 0.75); -} -.btn-primary { - background-color: #0074cc; - background-image: -moz-linear-gradient(top, #0088cc, #0055cc); - background-image: -ms-linear-gradient(top, #0088cc, #0055cc); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0055cc)); - background-image: -webkit-linear-gradient(top, #0088cc, #0055cc); - background-image: -o-linear-gradient(top, #0088cc, #0055cc); - background-image: linear-gradient(top, #0088cc, #0055cc); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#0088cc', endColorstr='#0055cc', GradientType=0); - border-color: #0055cc #0055cc #003580; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); -} -.btn-primary:hover, -.btn-primary:active, -.btn-primary.active, -.btn-primary.disabled, -.btn-primary[disabled] { - background-color: #0055cc; -} -.btn-primary:active, -.btn-primary.active { - background-color: #004099 \9; -} -.btn-warning { - background-color: #faa732; - background-image: -moz-linear-gradient(top, #fbb450, #f89406); - background-image: -ms-linear-gradient(top, #fbb450, #f89406); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#fbb450), to(#f89406)); - background-image: -webkit-linear-gradient(top, #fbb450, #f89406); - background-image: -o-linear-gradient(top, #fbb450, #f89406); - background-image: linear-gradient(top, #fbb450, #f89406); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fbb450', endColorstr='#f89406', GradientType=0); - border-color: #f89406 #f89406 #ad6704; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); -} -.btn-warning:hover, -.btn-warning:active, -.btn-warning.active, -.btn-warning.disabled, -.btn-warning[disabled] { - background-color: #f89406; -} -.btn-warning:active, -.btn-warning.active { - background-color: #c67605 \9; -} -.btn-danger { - background-color: #da4f49; - background-image: -moz-linear-gradient(top, #ee5f5b, #bd362f); - background-image: -ms-linear-gradient(top, #ee5f5b, #bd362f); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ee5f5b), to(#bd362f)); - background-image: -webkit-linear-gradient(top, #ee5f5b, #bd362f); - background-image: -o-linear-gradient(top, #ee5f5b, #bd362f); - background-image: linear-gradient(top, #ee5f5b, #bd362f); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ee5f5b', endColorstr='#bd362f', GradientType=0); - border-color: #bd362f #bd362f #802420; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); -} -.btn-danger:hover, -.btn-danger:active, -.btn-danger.active, -.btn-danger.disabled, -.btn-danger[disabled] { - background-color: #bd362f; -} -.btn-danger:active, -.btn-danger.active { - background-color: #942a25 \9; -} -.btn-success { - background-color: #5bb75b; - background-image: -moz-linear-gradient(top, #62c462, #51a351); - background-image: -ms-linear-gradient(top, #62c462, #51a351); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#62c462), to(#51a351)); - background-image: -webkit-linear-gradient(top, #62c462, #51a351); - background-image: -o-linear-gradient(top, #62c462, #51a351); - background-image: linear-gradient(top, #62c462, #51a351); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#62c462', endColorstr='#51a351', GradientType=0); - border-color: #51a351 #51a351 #387038; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); -} -.btn-success:hover, -.btn-success:active, -.btn-success.active, -.btn-success.disabled, -.btn-success[disabled] { - background-color: #51a351; -} -.btn-success:active, -.btn-success.active { - background-color: #408140 \9; -} -.btn-info { - background-color: #49afcd; - background-image: -moz-linear-gradient(top, #5bc0de, #2f96b4); - background-image: -ms-linear-gradient(top, #5bc0de, #2f96b4); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#5bc0de), to(#2f96b4)); - background-image: -webkit-linear-gradient(top, #5bc0de, #2f96b4); - background-image: -o-linear-gradient(top, #5bc0de, #2f96b4); - background-image: linear-gradient(top, #5bc0de, #2f96b4); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#5bc0de', endColorstr='#2f96b4', GradientType=0); - border-color: #2f96b4 #2f96b4 #1f6377; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); -} -.btn-info:hover, -.btn-info:active, -.btn-info.active, -.btn-info.disabled, -.btn-info[disabled] { - background-color: #2f96b4; -} -.btn-info:active, -.btn-info.active { - background-color: #24748c \9; -} -.btn-inverse { - background-color: #414141; - background-image: -moz-linear-gradient(top, #555555, #222222); - background-image: -ms-linear-gradient(top, #555555, #222222); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#555555), to(#222222)); - background-image: -webkit-linear-gradient(top, #555555, #222222); - background-image: -o-linear-gradient(top, #555555, #222222); - background-image: linear-gradient(top, #555555, #222222); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#555555', endColorstr='#222222', GradientType=0); - border-color: #222222 #222222 #000000; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); -} -.btn-inverse:hover, -.btn-inverse:active, -.btn-inverse.active, -.btn-inverse.disabled, -.btn-inverse[disabled] { - background-color: #222222; -} -.btn-inverse:active, -.btn-inverse.active { - background-color: #080808 \9; -} -button.btn, -input[type="submit"].btn { - *padding-top: 2px; - *padding-bottom: 2px; -} -button.btn::-moz-focus-inner, -input[type="submit"].btn::-moz-focus-inner { - padding: 0; - border: 0; -} -button.btn.btn-large, -input[type="submit"].btn.btn-large { - *padding-top: 7px; - *padding-bottom: 7px; -} -button.btn.btn-small, -input[type="submit"].btn.btn-small { - *padding-top: 3px; - *padding-bottom: 3px; -} -button.btn.btn-mini, -input[type="submit"].btn.btn-mini { - *padding-top: 1px; - *padding-bottom: 1px; -} -.btn-group { - position: relative; - *zoom: 1; - *margin-left: .3em; -} -.btn-group:before, -.btn-group:after { - display: table; - content: ""; -} -.btn-group:after { - clear: both; -} -.btn-group:first-child { - *margin-left: 0; -} -.btn-group + .btn-group { - margin-left: 5px; -} -.btn-toolbar { - margin-top: 9px; - margin-bottom: 9px; -} -.btn-toolbar .btn-group { - display: inline-block; - *display: inline; - /* IE7 inline-block hack */ - - *zoom: 1; -} -.btn-group .btn { - position: relative; - float: left; - margin-left: -1px; - -webkit-border-radius: 0; - -moz-border-radius: 0; - border-radius: 0; -} -.btn-group .btn:first-child { - margin-left: 0; - -webkit-border-top-left-radius: 4px; - -moz-border-radius-topleft: 4px; - border-top-left-radius: 4px; - -webkit-border-bottom-left-radius: 4px; - -moz-border-radius-bottomleft: 4px; - border-bottom-left-radius: 4px; -} -.btn-group .btn:last-child, -.btn-group .dropdown-toggle { - -webkit-border-top-right-radius: 4px; - -moz-border-radius-topright: 4px; - border-top-right-radius: 4px; - -webkit-border-bottom-right-radius: 4px; - -moz-border-radius-bottomright: 4px; - border-bottom-right-radius: 4px; -} -.btn-group .btn.large:first-child { - margin-left: 0; - -webkit-border-top-left-radius: 6px; - -moz-border-radius-topleft: 6px; - border-top-left-radius: 6px; - -webkit-border-bottom-left-radius: 6px; - -moz-border-radius-bottomleft: 6px; - border-bottom-left-radius: 6px; -} -.btn-group .btn.large:last-child, -.btn-group .large.dropdown-toggle { - -webkit-border-top-right-radius: 6px; - -moz-border-radius-topright: 6px; - border-top-right-radius: 6px; - -webkit-border-bottom-right-radius: 6px; - -moz-border-radius-bottomright: 6px; - border-bottom-right-radius: 6px; -} -.btn-group .btn:hover, -.btn-group .btn:focus, -.btn-group .btn:active, -.btn-group .btn.active { - z-index: 2; -} -.btn-group .dropdown-toggle:active, -.btn-group.open .dropdown-toggle { - outline: 0; -} -.btn-group .dropdown-toggle { - padding-left: 8px; - padding-right: 8px; - -webkit-box-shadow: inset 1px 0 0 rgba(255, 255, 255, 0.125), inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); - -moz-box-shadow: inset 1px 0 0 rgba(255, 255, 255, 0.125), inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); - box-shadow: inset 1px 0 0 rgba(255, 255, 255, 0.125), inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); - *padding-top: 3px; - *padding-bottom: 3px; -} -.btn-group .btn-mini.dropdown-toggle { - padding-left: 5px; - padding-right: 5px; - *padding-top: 1px; - *padding-bottom: 1px; -} -.btn-group .btn-small.dropdown-toggle { - *padding-top: 4px; - *padding-bottom: 4px; -} -.btn-group .btn-large.dropdown-toggle { - padding-left: 12px; - padding-right: 12px; -} -.btn-group.open { - *z-index: 1000; -} -.btn-group.open .dropdown-menu { - display: block; - margin-top: 1px; - -webkit-border-radius: 5px; - -moz-border-radius: 5px; - border-radius: 5px; -} -.btn-group.open .dropdown-toggle { - background-image: none; - -webkit-box-shadow: inset 0 1px 6px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); - -moz-box-shadow: inset 0 1px 6px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); - box-shadow: inset 0 1px 6px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); -} -.btn .caret { - margin-top: 7px; - margin-left: 0; -} -.btn:hover .caret, -.open.btn-group .caret { - opacity: 1; - filter: alpha(opacity=100); -} -.btn-mini .caret { - margin-top: 5px; -} -.btn-small .caret { - margin-top: 6px; -} -.btn-large .caret { - margin-top: 6px; - border-left: 5px solid transparent; - border-right: 5px solid transparent; - border-top: 5px solid #000000; -} -.btn-primary .caret, -.btn-warning .caret, -.btn-danger .caret, -.btn-info .caret, -.btn-success .caret, -.btn-inverse .caret { - border-top-color: #ffffff; - border-bottom-color: #ffffff; - opacity: 0.75; - filter: alpha(opacity=75); -} -.alert { - padding: 8px 35px 8px 14px; - margin-bottom: 18px; - text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); - background-color: #fcf8e3; - border: 1px solid #fbeed5; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; - color: #c09853; -} -.alert-heading { - color: inherit; -} -.alert .close { - position: relative; - top: -2px; - right: -21px; - line-height: 18px; -} -.alert-success { - background-color: #dff0d8; - border-color: #d6e9c6; - color: #468847; -} -.alert-danger, -.alert-error { - background-color: #f2dede; - border-color: #eed3d7; - color: #b94a48; -} -.alert-info { - background-color: #d9edf7; - border-color: #bce8f1; - color: #3a87ad; -} -.alert-block { - padding-top: 14px; - padding-bottom: 14px; -} -.alert-block > p, -.alert-block > ul { - margin-bottom: 0; -} -.alert-block p + p { - margin-top: 5px; -} -.nav { - margin-left: 0; - margin-bottom: 18px; - list-style: none; -} -.nav > li > a { - display: block; -} -.nav > li > a:hover { - text-decoration: none; - background-color: #eeeeee; -} -.nav .nav-header { - display: block; - padding: 3px 15px; - font-size: 11px; - font-weight: bold; - line-height: 18px; - color: #999999; - text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); - text-transform: uppercase; -} -.nav li + .nav-header { - margin-top: 9px; -} -.nav-list { - padding-left: 15px; - padding-right: 15px; - margin-bottom: 0; -} -.nav-list > li > a, -.nav-list .nav-header { - margin-left: -15px; - margin-right: -15px; - text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); -} -.nav-list > li > a { - padding: 3px 15px; -} -.nav-list > .active > a, -.nav-list > .active > a:hover { - color: #ffffff; - text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.2); - background-color: #0088cc; -} -.nav-list [class^="icon-"] { - margin-right: 2px; -} -.nav-list .divider { - height: 1px; - margin: 8px 1px; - overflow: hidden; - background-color: #e5e5e5; - border-bottom: 1px solid #ffffff; - *width: 100%; - *margin: -5px 0 5px; -} -.nav-tabs, -.nav-pills { - *zoom: 1; -} -.nav-tabs:before, -.nav-pills:before, -.nav-tabs:after, -.nav-pills:after { - display: table; - content: ""; -} -.nav-tabs:after, -.nav-pills:after { - clear: both; -} -.nav-tabs > li, -.nav-pills > li { - float: left; -} -.nav-tabs > li > a, -.nav-pills > li > a { - padding-right: 12px; - padding-left: 12px; - margin-right: 2px; - line-height: 14px; -} -.nav-tabs { - border-bottom: 1px solid #ddd; -} -.nav-tabs > li { - margin-bottom: -1px; -} -.nav-tabs > li > a { - padding-top: 8px; - padding-bottom: 8px; - line-height: 18px; - border: 1px solid transparent; - -webkit-border-radius: 4px 4px 0 0; - -moz-border-radius: 4px 4px 0 0; - border-radius: 4px 4px 0 0; -} -.nav-tabs > li > a:hover { - border-color: #eeeeee #eeeeee #dddddd; -} -.nav-tabs > .active > a, -.nav-tabs > .active > a:hover { - color: #555555; - background-color: #ffffff; - border: 1px solid #ddd; - border-bottom-color: transparent; - cursor: default; -} -.nav-pills > li > a { - padding-top: 8px; - padding-bottom: 8px; - margin-top: 2px; - margin-bottom: 2px; - -webkit-border-radius: 5px; - -moz-border-radius: 5px; - border-radius: 5px; -} -.nav-pills > .active > a, -.nav-pills > .active > a:hover { - color: #ffffff; - background-color: #0088cc; -} -.nav-stacked > li { - float: none; -} -.nav-stacked > li > a { - margin-right: 0; -} -.nav-tabs.nav-stacked { - border-bottom: 0; -} -.nav-tabs.nav-stacked > li > a { - border: 1px solid #ddd; - -webkit-border-radius: 0; - -moz-border-radius: 0; - border-radius: 0; -} -.nav-tabs.nav-stacked > li:first-child > a { - -webkit-border-radius: 4px 4px 0 0; - -moz-border-radius: 4px 4px 0 0; - border-radius: 4px 4px 0 0; -} -.nav-tabs.nav-stacked > li:last-child > a { - -webkit-border-radius: 0 0 4px 4px; - -moz-border-radius: 0 0 4px 4px; - border-radius: 0 0 4px 4px; -} -.nav-tabs.nav-stacked > li > a:hover { - border-color: #ddd; - z-index: 2; -} -.nav-pills.nav-stacked > li > a { - margin-bottom: 3px; -} -.nav-pills.nav-stacked > li:last-child > a { - margin-bottom: 1px; -} -.nav-tabs .dropdown-menu, -.nav-pills .dropdown-menu { - margin-top: 1px; - border-width: 1px; -} -.nav-pills .dropdown-menu { - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.nav-tabs .dropdown-toggle .caret, -.nav-pills .dropdown-toggle .caret { - border-top-color: #0088cc; - border-bottom-color: #0088cc; - margin-top: 6px; -} -.nav-tabs .dropdown-toggle:hover .caret, -.nav-pills .dropdown-toggle:hover .caret { - border-top-color: #005580; - border-bottom-color: #005580; -} -.nav-tabs .active .dropdown-toggle .caret, -.nav-pills .active .dropdown-toggle .caret { - border-top-color: #333333; - border-bottom-color: #333333; -} -.nav > .dropdown.active > a:hover { - color: #000000; - cursor: pointer; -} -.nav-tabs .open .dropdown-toggle, -.nav-pills .open .dropdown-toggle, -.nav > .open.active > a:hover { - color: #ffffff; - background-color: #999999; - border-color: #999999; -} -.nav .open .caret, -.nav .open.active .caret, -.nav .open a:hover .caret { - border-top-color: #ffffff; - border-bottom-color: #ffffff; - opacity: 1; - filter: alpha(opacity=100); -} -.tabs-stacked .open > a:hover { - border-color: #999999; -} -.tabbable { - *zoom: 1; -} -.tabbable:before, -.tabbable:after { - display: table; - content: ""; -} -.tabbable:after { - clear: both; -} -.tab-content { - display: table; - width: 100%; -} -.tabs-below .nav-tabs, -.tabs-right .nav-tabs, -.tabs-left .nav-tabs { - border-bottom: 0; -} -.tab-content > .tab-pane, -.pill-content > .pill-pane { - display: none; -} -.tab-content > .active, -.pill-content > .active { - display: block; -} -.tabs-below .nav-tabs { - border-top: 1px solid #ddd; -} -.tabs-below .nav-tabs > li { - margin-top: -1px; - margin-bottom: 0; -} -.tabs-below .nav-tabs > li > a { - -webkit-border-radius: 0 0 4px 4px; - -moz-border-radius: 0 0 4px 4px; - border-radius: 0 0 4px 4px; -} -.tabs-below .nav-tabs > li > a:hover { - border-bottom-color: transparent; - border-top-color: #ddd; -} -.tabs-below .nav-tabs .active > a, -.tabs-below .nav-tabs .active > a:hover { - border-color: transparent #ddd #ddd #ddd; -} -.tabs-left .nav-tabs > li, -.tabs-right .nav-tabs > li { - float: none; -} -.tabs-left .nav-tabs > li > a, -.tabs-right .nav-tabs > li > a { - min-width: 74px; - margin-right: 0; - margin-bottom: 3px; -} -.tabs-left .nav-tabs { - float: left; - margin-right: 19px; - border-right: 1px solid #ddd; -} -.tabs-left .nav-tabs > li > a { - margin-right: -1px; - -webkit-border-radius: 4px 0 0 4px; - -moz-border-radius: 4px 0 0 4px; - border-radius: 4px 0 0 4px; -} -.tabs-left .nav-tabs > li > a:hover { - border-color: #eeeeee #dddddd #eeeeee #eeeeee; -} -.tabs-left .nav-tabs .active > a, -.tabs-left .nav-tabs .active > a:hover { - border-color: #ddd transparent #ddd #ddd; - *border-right-color: #ffffff; -} -.tabs-right .nav-tabs { - float: right; - margin-left: 19px; - border-left: 1px solid #ddd; -} -.tabs-right .nav-tabs > li > a { - margin-left: -1px; - -webkit-border-radius: 0 4px 4px 0; - -moz-border-radius: 0 4px 4px 0; - border-radius: 0 4px 4px 0; -} -.tabs-right .nav-tabs > li > a:hover { - border-color: #eeeeee #eeeeee #eeeeee #dddddd; -} -.tabs-right .nav-tabs .active > a, -.tabs-right .nav-tabs .active > a:hover { - border-color: #ddd #ddd #ddd transparent; - *border-left-color: #ffffff; -} -.navbar { - *position: relative; - *z-index: 2; - overflow: visible; - margin-bottom: 18px; -} -.navbar-inner { - padding-left: 20px; - padding-right: 20px; - background-color: #2c2c2c; - background-image: -moz-linear-gradient(top, #333333, #222222); - background-image: -ms-linear-gradient(top, #333333, #222222); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#333333), to(#222222)); - background-image: -webkit-linear-gradient(top, #333333, #222222); - background-image: -o-linear-gradient(top, #333333, #222222); - background-image: linear-gradient(top, #333333, #222222); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#333333', endColorstr='#222222', GradientType=0); - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; - -webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.25), inset 0 -1px 0 rgba(0, 0, 0, 0.1); - -moz-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.25), inset 0 -1px 0 rgba(0, 0, 0, 0.1); - box-shadow: 0 1px 3px rgba(0, 0, 0, 0.25), inset 0 -1px 0 rgba(0, 0, 0, 0.1); -} -.navbar .container { - width: auto; -} -.btn-navbar { - display: none; - float: right; - padding: 7px 10px; - margin-left: 5px; - margin-right: 5px; - background-color: #2c2c2c; - background-image: -moz-linear-gradient(top, #333333, #222222); - background-image: -ms-linear-gradient(top, #333333, #222222); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#333333), to(#222222)); - background-image: -webkit-linear-gradient(top, #333333, #222222); - background-image: -o-linear-gradient(top, #333333, #222222); - background-image: linear-gradient(top, #333333, #222222); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#333333', endColorstr='#222222', GradientType=0); - border-color: #222222 #222222 #000000; - border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); - filter: progid:dximagetransform.microsoft.gradient(enabled=false); - -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.075); - -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.075); - box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.075); -} -.btn-navbar:hover, -.btn-navbar:active, -.btn-navbar.active, -.btn-navbar.disabled, -.btn-navbar[disabled] { - background-color: #222222; -} -.btn-navbar:active, -.btn-navbar.active { - background-color: #080808 \9; -} -.btn-navbar .icon-bar { - display: block; - width: 18px; - height: 2px; - background-color: #f5f5f5; - -webkit-border-radius: 1px; - -moz-border-radius: 1px; - border-radius: 1px; - -webkit-box-shadow: 0 1px 0 rgba(0, 0, 0, 0.25); - -moz-box-shadow: 0 1px 0 rgba(0, 0, 0, 0.25); - box-shadow: 0 1px 0 rgba(0, 0, 0, 0.25); -} -.btn-navbar .icon-bar + .icon-bar { - margin-top: 3px; -} -.nav-collapse.collapse { - height: auto; -} -.navbar { - color: #999999; -} -.navbar .brand:hover { - text-decoration: none; -} -.navbar .brand { - float: left; - display: block; - padding: 8px 20px 12px; - margin-left: -20px; - font-size: 20px; - font-weight: 200; - line-height: 1; - color: #ffffff; -} -.navbar .navbar-text { - margin-bottom: 0; - line-height: 40px; -} -.navbar .btn, -.navbar .btn-group { - margin-top: 5px; -} -.navbar .btn-group .btn { - margin-top: 0; -} -.navbar-form { - margin-bottom: 0; - *zoom: 1; -} -.navbar-form:before, -.navbar-form:after { - display: table; - content: ""; -} -.navbar-form:after { - clear: both; -} -.navbar-form input, -.navbar-form select, -.navbar-form .radio, -.navbar-form .checkbox { - margin-top: 5px; -} -.navbar-form input, -.navbar-form select { - display: inline-block; - margin-bottom: 0; -} -.navbar-form input[type="image"], -.navbar-form input[type="checkbox"], -.navbar-form input[type="radio"] { - margin-top: 3px; -} -.navbar-form .input-append, -.navbar-form .input-prepend { - margin-top: 6px; - white-space: nowrap; -} -.navbar-form .input-append input, -.navbar-form .input-prepend input { - margin-top: 0; -} -.navbar-search { - position: relative; - float: left; - margin-top: 6px; - margin-bottom: 0; -} -.navbar-search .search-query { - padding: 4px 9px; - font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; - font-size: 13px; - font-weight: normal; - line-height: 1; - color: #ffffff; - background-color: #626262; - border: 1px solid #151515; - -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1), 0 1px 0px rgba(255, 255, 255, 0.15); - -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1), 0 1px 0px rgba(255, 255, 255, 0.15); - box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1), 0 1px 0px rgba(255, 255, 255, 0.15); - -webkit-transition: none; - -moz-transition: none; - -ms-transition: none; - -o-transition: none; - transition: none; -} -.navbar-search .search-query:-moz-placeholder { - color: #cccccc; -} -.navbar-search .search-query::-webkit-input-placeholder { - color: #cccccc; -} -.navbar-search .search-query:focus, -.navbar-search .search-query.focused { - padding: 5px 10px; - color: #333333; - text-shadow: 0 1px 0 #ffffff; - background-color: #ffffff; - border: 0; - -webkit-box-shadow: 0 0 3px rgba(0, 0, 0, 0.15); - -moz-box-shadow: 0 0 3px rgba(0, 0, 0, 0.15); - box-shadow: 0 0 3px rgba(0, 0, 0, 0.15); - outline: 0; -} -.navbar-fixed-top, -.navbar-fixed-bottom { - position: fixed; - right: 0; - left: 0; - z-index: 1030; - margin-bottom: 0; -} -.navbar-fixed-top .navbar-inner, -.navbar-fixed-bottom .navbar-inner { - padding-left: 0; - padding-right: 0; - -webkit-border-radius: 0; - -moz-border-radius: 0; - border-radius: 0; -} -.navbar-fixed-top .container, -.navbar-fixed-bottom .container { - width: 940px; -} -.navbar-fixed-top { - top: 0; -} -.navbar-fixed-bottom { - bottom: 0; -} -.navbar .nav { - position: relative; - left: 0; - display: block; - float: left; - margin: 0 10px 0 0; -} -.navbar .nav.pull-right { - float: right; -} -.navbar .nav > li { - display: block; - float: left; -} -.navbar .nav > li > a { - float: none; - padding: 10px 10px 11px; - line-height: 19px; - color: #999999; - text-decoration: none; - text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); -} -.navbar .nav > li > a:hover { - background-color: transparent; - color: #ffffff; - text-decoration: none; -} -.navbar .nav .active > a, -.navbar .nav .active > a:hover { - color: #ffffff; - text-decoration: none; - background-color: #222222; -} -.navbar .divider-vertical { - height: 40px; - width: 1px; - margin: 0 9px; - overflow: hidden; - background-color: #222222; - border-right: 1px solid #333333; -} -.navbar .nav.pull-right { - margin-left: 10px; - margin-right: 0; -} -.navbar .dropdown-menu { - margin-top: 1px; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.navbar .dropdown-menu:before { - content: ''; - display: inline-block; - border-left: 7px solid transparent; - border-right: 7px solid transparent; - border-bottom: 7px solid #ccc; - border-bottom-color: rgba(0, 0, 0, 0.2); - position: absolute; - top: -7px; - left: 9px; -} -.navbar .dropdown-menu:after { - content: ''; - display: inline-block; - border-left: 6px solid transparent; - border-right: 6px solid transparent; - border-bottom: 6px solid #ffffff; - position: absolute; - top: -6px; - left: 10px; -} -.navbar-fixed-bottom .dropdown-menu:before { - border-top: 7px solid #ccc; - border-top-color: rgba(0, 0, 0, 0.2); - border-bottom: 0; - bottom: -7px; - top: auto; -} -.navbar-fixed-bottom .dropdown-menu:after { - border-top: 6px solid #ffffff; - border-bottom: 0; - bottom: -6px; - top: auto; -} -.navbar .nav .dropdown-toggle .caret, -.navbar .nav .open.dropdown .caret { - border-top-color: #ffffff; - border-bottom-color: #ffffff; -} -.navbar .nav .active .caret { - opacity: 1; - filter: alpha(opacity=100); -} -.navbar .nav .open > .dropdown-toggle, -.navbar .nav .active > .dropdown-toggle, -.navbar .nav .open.active > .dropdown-toggle { - background-color: transparent; -} -.navbar .nav .active > .dropdown-toggle:hover { - color: #ffffff; -} -.navbar .nav.pull-right .dropdown-menu, -.navbar .nav .dropdown-menu.pull-right { - left: auto; - right: 0; -} -.navbar .nav.pull-right .dropdown-menu:before, -.navbar .nav .dropdown-menu.pull-right:before { - left: auto; - right: 12px; -} -.navbar .nav.pull-right .dropdown-menu:after, -.navbar .nav .dropdown-menu.pull-right:after { - left: auto; - right: 13px; -} -.breadcrumb { - padding: 7px 14px; - margin: 0 0 18px; - list-style: none; - background-color: #fbfbfb; - background-image: -moz-linear-gradient(top, #ffffff, #f5f5f5); - background-image: -ms-linear-gradient(top, #ffffff, #f5f5f5); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ffffff), to(#f5f5f5)); - background-image: -webkit-linear-gradient(top, #ffffff, #f5f5f5); - background-image: -o-linear-gradient(top, #ffffff, #f5f5f5); - background-image: linear-gradient(top, #ffffff, #f5f5f5); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffff', endColorstr='#f5f5f5', GradientType=0); - border: 1px solid #ddd; - -webkit-border-radius: 3px; - -moz-border-radius: 3px; - border-radius: 3px; - -webkit-box-shadow: inset 0 1px 0 #ffffff; - -moz-box-shadow: inset 0 1px 0 #ffffff; - box-shadow: inset 0 1px 0 #ffffff; -} -.breadcrumb li { - display: inline-block; - *display: inline; - /* IE7 inline-block hack */ - - *zoom: 1; - text-shadow: 0 1px 0 #ffffff; -} -.breadcrumb .divider { - padding: 0 5px; - color: #999999; -} -.breadcrumb .active a { - color: #333333; -} -.pagination { - height: 36px; - margin: 18px 0; -} -.pagination ul { - display: inline-block; - *display: inline; - /* IE7 inline-block hack */ - - *zoom: 1; - margin-left: 0; - margin-bottom: 0; - -webkit-border-radius: 3px; - -moz-border-radius: 3px; - border-radius: 3px; - -webkit-box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05); - -moz-box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05); - box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05); -} -.pagination li { - display: inline; -} -.pagination a { - float: left; - padding: 0 14px; - line-height: 34px; - text-decoration: none; - border: 1px solid #ddd; - border-left-width: 0; -} -.pagination a:hover, -.pagination .active a { - background-color: #f5f5f5; -} -.pagination .active a { - color: #999999; - cursor: default; -} -.pagination .disabled span, -.pagination .disabled a, -.pagination .disabled a:hover { - color: #999999; - background-color: transparent; - cursor: default; -} -.pagination li:first-child a { - border-left-width: 1px; - -webkit-border-radius: 3px 0 0 3px; - -moz-border-radius: 3px 0 0 3px; - border-radius: 3px 0 0 3px; -} -.pagination li:last-child a { - -webkit-border-radius: 0 3px 3px 0; - -moz-border-radius: 0 3px 3px 0; - border-radius: 0 3px 3px 0; -} -.pagination-centered { - text-align: center; -} -.pagination-right { - text-align: right; -} -.pager { - margin-left: 0; - margin-bottom: 18px; - list-style: none; - text-align: center; - *zoom: 1; -} -.pager:before, -.pager:after { - display: table; - content: ""; -} -.pager:after { - clear: both; -} -.pager li { - display: inline; -} -.pager a { - display: inline-block; - padding: 5px 14px; - background-color: #fff; - border: 1px solid #ddd; - -webkit-border-radius: 15px; - -moz-border-radius: 15px; - border-radius: 15px; -} -.pager a:hover { - text-decoration: none; - background-color: #f5f5f5; -} -.pager .next a { - float: right; -} -.pager .previous a { - float: left; -} -.pager .disabled a, -.pager .disabled a:hover { - color: #999999; - background-color: #fff; - cursor: default; -} -.modal-open .dropdown-menu { - z-index: 2050; -} -.modal-open .dropdown.open { - *z-index: 2050; -} -.modal-open .popover { - z-index: 2060; -} -.modal-open .tooltip { - z-index: 2070; -} -.modal-backdrop { - position: fixed; - top: 0; - right: 0; - bottom: 0; - left: 0; - z-index: 1040; - background-color: #000000; -} -.modal-backdrop.fade { - opacity: 0; -} -.modal-backdrop, -.modal-backdrop.fade.in { - opacity: 0.8; - filter: alpha(opacity=80); -} -.modal { - position: fixed; - top: 50%; - left: 50%; - z-index: 1050; - overflow: auto; - width: 560px; - margin: -250px 0 0 -280px; - background-color: #ffffff; - border: 1px solid #999; - border: 1px solid rgba(0, 0, 0, 0.3); - *border: 1px solid #999; - /* IE6-7 */ - - -webkit-border-radius: 6px; - -moz-border-radius: 6px; - border-radius: 6px; - -webkit-box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); - -moz-box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); - box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); - -webkit-background-clip: padding-box; - -moz-background-clip: padding-box; - background-clip: padding-box; -} -.modal.fade { - -webkit-transition: opacity .3s linear, top .3s ease-out; - -moz-transition: opacity .3s linear, top .3s ease-out; - -ms-transition: opacity .3s linear, top .3s ease-out; - -o-transition: opacity .3s linear, top .3s ease-out; - transition: opacity .3s linear, top .3s ease-out; - top: -25%; -} -.modal.fade.in { - top: 50%; -} -.modal-header { - padding: 9px 15px; - border-bottom: 1px solid #eee; -} -.modal-header .close { - margin-top: 2px; -} -.modal-body { - overflow-y: auto; - max-height: 400px; - padding: 15px; -} -.modal-form { - margin-bottom: 0; -} -.modal-footer { - padding: 14px 15px 15px; - margin-bottom: 0; - text-align: right; - background-color: #f5f5f5; - border-top: 1px solid #ddd; - -webkit-border-radius: 0 0 6px 6px; - -moz-border-radius: 0 0 6px 6px; - border-radius: 0 0 6px 6px; - -webkit-box-shadow: inset 0 1px 0 #ffffff; - -moz-box-shadow: inset 0 1px 0 #ffffff; - box-shadow: inset 0 1px 0 #ffffff; - *zoom: 1; -} -.modal-footer:before, -.modal-footer:after { - display: table; - content: ""; -} -.modal-footer:after { - clear: both; -} -.modal-footer .btn + .btn { - margin-left: 5px; - margin-bottom: 0; -} -.modal-footer .btn-group .btn + .btn { - margin-left: -1px; -} -.tooltip { - position: absolute; - z-index: 1020; - display: block; - visibility: visible; - padding: 5px; - font-size: 11px; - opacity: 0; - filter: alpha(opacity=0); -} -.tooltip.in { - opacity: 0.8; - filter: alpha(opacity=80); -} -.tooltip.top { - margin-top: -2px; -} -.tooltip.right { - margin-left: 2px; -} -.tooltip.bottom { - margin-top: 2px; -} -.tooltip.left { - margin-left: -2px; -} -.tooltip.top .tooltip-arrow { - bottom: 0; - left: 50%; - margin-left: -5px; - border-left: 5px solid transparent; - border-right: 5px solid transparent; - border-top: 5px solid #000000; -} -.tooltip.left .tooltip-arrow { - top: 50%; - right: 0; - margin-top: -5px; - border-top: 5px solid transparent; - border-bottom: 5px solid transparent; - border-left: 5px solid #000000; -} -.tooltip.bottom .tooltip-arrow { - top: 0; - left: 50%; - margin-left: -5px; - border-left: 5px solid transparent; - border-right: 5px solid transparent; - border-bottom: 5px solid #000000; -} -.tooltip.right .tooltip-arrow { - top: 50%; - left: 0; - margin-top: -5px; - border-top: 5px solid transparent; - border-bottom: 5px solid transparent; - border-right: 5px solid #000000; -} -.tooltip-inner { - max-width: 200px; - padding: 3px 8px; - color: #ffffff; - text-align: center; - text-decoration: none; - background-color: #000000; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.tooltip-arrow { - position: absolute; - width: 0; - height: 0; -} -.popover { - position: absolute; - top: 0; - left: 0; - z-index: 1010; - display: none; - padding: 5px; -} -.popover.top { - margin-top: -5px; -} -.popover.right { - margin-left: 5px; -} -.popover.bottom { - margin-top: 5px; -} -.popover.left { - margin-left: -5px; -} -.popover.top .arrow { - bottom: 0; - left: 50%; - margin-left: -5px; - border-left: 5px solid transparent; - border-right: 5px solid transparent; - border-top: 5px solid #000000; -} -.popover.right .arrow { - top: 50%; - left: 0; - margin-top: -5px; - border-top: 5px solid transparent; - border-bottom: 5px solid transparent; - border-right: 5px solid #000000; -} -.popover.bottom .arrow { - top: 0; - left: 50%; - margin-left: -5px; - border-left: 5px solid transparent; - border-right: 5px solid transparent; - border-bottom: 5px solid #000000; -} -.popover.left .arrow { - top: 50%; - right: 0; - margin-top: -5px; - border-top: 5px solid transparent; - border-bottom: 5px solid transparent; - border-left: 5px solid #000000; -} -.popover .arrow { - position: absolute; - width: 0; - height: 0; -} -.popover-inner { - padding: 3px; - width: 280px; - overflow: hidden; - background: #000000; - background: rgba(0, 0, 0, 0.8); - -webkit-border-radius: 6px; - -moz-border-radius: 6px; - border-radius: 6px; - -webkit-box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); - -moz-box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); - box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); -} -.popover-title { - padding: 9px 15px; - line-height: 1; - background-color: #f5f5f5; - border-bottom: 1px solid #eee; - -webkit-border-radius: 3px 3px 0 0; - -moz-border-radius: 3px 3px 0 0; - border-radius: 3px 3px 0 0; -} -.popover-content { - padding: 14px; - background-color: #ffffff; - -webkit-border-radius: 0 0 3px 3px; - -moz-border-radius: 0 0 3px 3px; - border-radius: 0 0 3px 3px; - -webkit-background-clip: padding-box; - -moz-background-clip: padding-box; - background-clip: padding-box; -} -.popover-content p, -.popover-content ul, -.popover-content ol { - margin-bottom: 0; -} -.thumbnails { - margin-left: -20px; - list-style: none; - *zoom: 1; -} -.thumbnails:before, -.thumbnails:after { - display: table; - content: ""; -} -.thumbnails:after { - clear: both; -} -.thumbnails > li { - float: left; - margin: 0 0 18px 20px; -} -.thumbnail { - display: block; - padding: 4px; - line-height: 1; - border: 1px solid #ddd; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; - -webkit-box-shadow: 0 1px 1px rgba(0, 0, 0, 0.075); - -moz-box-shadow: 0 1px 1px rgba(0, 0, 0, 0.075); - box-shadow: 0 1px 1px rgba(0, 0, 0, 0.075); -} -a.thumbnail:hover { - border-color: #0088cc; - -webkit-box-shadow: 0 1px 4px rgba(0, 105, 214, 0.25); - -moz-box-shadow: 0 1px 4px rgba(0, 105, 214, 0.25); - box-shadow: 0 1px 4px rgba(0, 105, 214, 0.25); -} -.thumbnail > img { - display: block; - max-width: 100%; - margin-left: auto; - margin-right: auto; -} -.thumbnail .caption { - padding: 9px; -} -.label { - padding: 1px 4px 2px; - font-size: 10.998px; - font-weight: bold; - line-height: 13px; - color: #ffffff; - vertical-align: middle; - white-space: nowrap; - text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); - background-color: #999999; - -webkit-border-radius: 3px; - -moz-border-radius: 3px; - border-radius: 3px; -} -.label:hover { - color: #ffffff; - text-decoration: none; -} -.label-important { - background-color: #b94a48; -} -.label-important:hover { - background-color: #953b39; -} -.label-warning { - background-color: #f89406; -} -.label-warning:hover { - background-color: #c67605; -} -.label-success { - background-color: #468847; -} -.label-success:hover { - background-color: #356635; -} -.label-info { - background-color: #3a87ad; -} -.label-info:hover { - background-color: #2d6987; -} -.label-inverse { - background-color: #333333; -} -.label-inverse:hover { - background-color: #1a1a1a; -} -.badge { - padding: 1px 9px 2px; - font-size: 12.025px; - font-weight: bold; - white-space: nowrap; - color: #ffffff; - background-color: #999999; - -webkit-border-radius: 9px; - -moz-border-radius: 9px; - border-radius: 9px; -} -.badge:hover { - color: #ffffff; - text-decoration: none; - cursor: pointer; -} -.badge-error { - background-color: #b94a48; -} -.badge-error:hover { - background-color: #953b39; -} -.badge-warning { - background-color: #f89406; -} -.badge-warning:hover { - background-color: #c67605; -} -.badge-success { - background-color: #468847; -} -.badge-success:hover { - background-color: #356635; -} -.badge-info { - background-color: #3a87ad; -} -.badge-info:hover { - background-color: #2d6987; -} -.badge-inverse { - background-color: #333333; -} -.badge-inverse:hover { - background-color: #1a1a1a; -} -@-webkit-keyframes progress-bar-stripes { - from { - background-position: 0 0; - } - to { - background-position: 40px 0; - } -} -@-moz-keyframes progress-bar-stripes { - from { - background-position: 0 0; - } - to { - background-position: 40px 0; - } -} -@-ms-keyframes progress-bar-stripes { - from { - background-position: 0 0; - } - to { - background-position: 40px 0; - } -} -@keyframes progress-bar-stripes { - from { - background-position: 0 0; - } - to { - background-position: 40px 0; - } -} -.progress { - overflow: hidden; - height: 18px; - margin-bottom: 18px; - background-color: #f7f7f7; - background-image: -moz-linear-gradient(top, #f5f5f5, #f9f9f9); - background-image: -ms-linear-gradient(top, #f5f5f5, #f9f9f9); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#f5f5f5), to(#f9f9f9)); - background-image: -webkit-linear-gradient(top, #f5f5f5, #f9f9f9); - background-image: -o-linear-gradient(top, #f5f5f5, #f9f9f9); - background-image: linear-gradient(top, #f5f5f5, #f9f9f9); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#f5f5f5', endColorstr='#f9f9f9', GradientType=0); - -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1); - -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1); - box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1); - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.progress .bar { - width: 0%; - height: 18px; - color: #ffffff; - font-size: 12px; - text-align: center; - text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); - background-color: #0e90d2; - background-image: -moz-linear-gradient(top, #149bdf, #0480be); - background-image: -ms-linear-gradient(top, #149bdf, #0480be); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#149bdf), to(#0480be)); - background-image: -webkit-linear-gradient(top, #149bdf, #0480be); - background-image: -o-linear-gradient(top, #149bdf, #0480be); - background-image: linear-gradient(top, #149bdf, #0480be); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#149bdf', endColorstr='#0480be', GradientType=0); - -webkit-box-shadow: inset 0 -1px 0 rgba(0, 0, 0, 0.15); - -moz-box-shadow: inset 0 -1px 0 rgba(0, 0, 0, 0.15); - box-shadow: inset 0 -1px 0 rgba(0, 0, 0, 0.15); - -webkit-box-sizing: border-box; - -moz-box-sizing: border-box; - -ms-box-sizing: border-box; - box-sizing: border-box; - -webkit-transition: width 0.6s ease; - -moz-transition: width 0.6s ease; - -ms-transition: width 0.6s ease; - -o-transition: width 0.6s ease; - transition: width 0.6s ease; -} -.progress-striped .bar { - background-color: #149bdf; - background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); - background-image: -webkit-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -moz-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -ms-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -o-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - -webkit-background-size: 40px 40px; - -moz-background-size: 40px 40px; - -o-background-size: 40px 40px; - background-size: 40px 40px; -} -.progress.active .bar { - -webkit-animation: progress-bar-stripes 2s linear infinite; - -moz-animation: progress-bar-stripes 2s linear infinite; - animation: progress-bar-stripes 2s linear infinite; -} -.progress-danger .bar { - background-color: #dd514c; - background-image: -moz-linear-gradient(top, #ee5f5b, #c43c35); - background-image: -ms-linear-gradient(top, #ee5f5b, #c43c35); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ee5f5b), to(#c43c35)); - background-image: -webkit-linear-gradient(top, #ee5f5b, #c43c35); - background-image: -o-linear-gradient(top, #ee5f5b, #c43c35); - background-image: linear-gradient(top, #ee5f5b, #c43c35); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ee5f5b', endColorstr='#c43c35', GradientType=0); -} -.progress-danger.progress-striped .bar { - background-color: #ee5f5b; - background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); - background-image: -webkit-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -moz-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -ms-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -o-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); -} -.progress-success .bar { - background-color: #5eb95e; - background-image: -moz-linear-gradient(top, #62c462, #57a957); - background-image: -ms-linear-gradient(top, #62c462, #57a957); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#62c462), to(#57a957)); - background-image: -webkit-linear-gradient(top, #62c462, #57a957); - background-image: -o-linear-gradient(top, #62c462, #57a957); - background-image: linear-gradient(top, #62c462, #57a957); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#62c462', endColorstr='#57a957', GradientType=0); -} -.progress-success.progress-striped .bar { - background-color: #62c462; - background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); - background-image: -webkit-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -moz-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -ms-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -o-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); -} -.progress-info .bar { - background-color: #4bb1cf; - background-image: -moz-linear-gradient(top, #5bc0de, #339bb9); - background-image: -ms-linear-gradient(top, #5bc0de, #339bb9); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#5bc0de), to(#339bb9)); - background-image: -webkit-linear-gradient(top, #5bc0de, #339bb9); - background-image: -o-linear-gradient(top, #5bc0de, #339bb9); - background-image: linear-gradient(top, #5bc0de, #339bb9); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#5bc0de', endColorstr='#339bb9', GradientType=0); -} -.progress-info.progress-striped .bar { - background-color: #5bc0de; - background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); - background-image: -webkit-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -moz-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -ms-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -o-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); -} -.progress-warning .bar { - background-color: #faa732; - background-image: -moz-linear-gradient(top, #fbb450, #f89406); - background-image: -ms-linear-gradient(top, #fbb450, #f89406); - background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#fbb450), to(#f89406)); - background-image: -webkit-linear-gradient(top, #fbb450, #f89406); - background-image: -o-linear-gradient(top, #fbb450, #f89406); - background-image: linear-gradient(top, #fbb450, #f89406); - background-repeat: repeat-x; - filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fbb450', endColorstr='#f89406', GradientType=0); -} -.progress-warning.progress-striped .bar { - background-color: #fbb450; - background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); - background-image: -webkit-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -moz-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -ms-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: -o-linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); - background-image: linear-gradient(-45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); -} -.accordion { - margin-bottom: 18px; -} -.accordion-group { - margin-bottom: 2px; - border: 1px solid #e5e5e5; - -webkit-border-radius: 4px; - -moz-border-radius: 4px; - border-radius: 4px; -} -.accordion-heading { - border-bottom: 0; -} -.accordion-heading .accordion-toggle { - display: block; - padding: 8px 15px; -} -.accordion-inner { - padding: 9px 15px; - border-top: 1px solid #e5e5e5; -} -.carousel { - position: relative; - margin-bottom: 18px; - line-height: 1; -} -.carousel-inner { - overflow: hidden; - width: 100%; - position: relative; -} -.carousel .item { - display: none; - position: relative; - -webkit-transition: 0.6s ease-in-out left; - -moz-transition: 0.6s ease-in-out left; - -ms-transition: 0.6s ease-in-out left; - -o-transition: 0.6s ease-in-out left; - transition: 0.6s ease-in-out left; -} -.carousel .item > img { - display: block; - line-height: 1; -} -.carousel .active, -.carousel .next, -.carousel .prev { - display: block; -} -.carousel .active { - left: 0; -} -.carousel .next, -.carousel .prev { - position: absolute; - top: 0; - width: 100%; -} -.carousel .next { - left: 100%; -} -.carousel .prev { - left: -100%; -} -.carousel .next.left, -.carousel .prev.right { - left: 0; -} -.carousel .active.left { - left: -100%; -} -.carousel .active.right { - left: 100%; -} -.carousel-control { - position: absolute; - top: 40%; - left: 15px; - width: 40px; - height: 40px; - margin-top: -20px; - font-size: 60px; - font-weight: 100; - line-height: 30px; - color: #ffffff; - text-align: center; - background: #222222; - border: 3px solid #ffffff; - -webkit-border-radius: 23px; - -moz-border-radius: 23px; - border-radius: 23px; - opacity: 0.5; - filter: alpha(opacity=50); -} -.carousel-control.right { - left: auto; - right: 15px; -} -.carousel-control:hover { - color: #ffffff; - text-decoration: none; - opacity: 0.9; - filter: alpha(opacity=90); -} -.carousel-caption { - position: absolute; - left: 0; - right: 0; - bottom: 0; - padding: 10px 15px 5px; - background: #333333; - background: rgba(0, 0, 0, 0.75); -} -.carousel-caption h4, -.carousel-caption p { - color: #ffffff; -} -.hero-unit { - padding: 60px; - margin-bottom: 30px; - background-color: #eeeeee; - -webkit-border-radius: 6px; - -moz-border-radius: 6px; - border-radius: 6px; -} -.hero-unit h1 { - margin-bottom: 0; - font-size: 60px; - line-height: 1; - color: inherit; - letter-spacing: -1px; -} -.hero-unit p { - font-size: 18px; - font-weight: 200; - line-height: 27px; - color: inherit; -} -.pull-right { - float: right; -} -.pull-left { - float: left; -} -.hide { - display: none; -} -.show { - display: block; -} -.invisible { - visibility: hidden; -} diff --git a/msgpack-idl-web/static/img/glyphicons-halflings-white.png b/msgpack-idl-web/static/img/glyphicons-halflings-white.png deleted file mode 100644 index 3bf6484a29d8da269f9bc874b25493a45fae3bae..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8777 zcmZvC1yGz#v+m*$LXcp=A$ZWB0fL7wNbp_U*$~{_gL`my3oP#L!5tQYy99Ta`+g_q zKlj|KJ2f@c)ARJx{q*bbkhN_!|Wn*Vos8{TEhUT@5e;_WJsIMMcG5%>DiS&dv_N`4@J0cnAQ-#>RjZ z00W5t&tJ^l-QC*ST1-p~00u^9XJ=AUl7oW-;2a+x2k__T=grN{+1c4XK0ZL~^z^i$ zp&>vEhr@4fZWb380S18T&!0cQ3IKpHF)?v=b_NIm0Q>vwY7D0baZ)n z31Fa5sELUQARIVaU0nqf0XzT+fB_63aA;@<$l~wse|mcA;^G1TmX?-)e)jkGPfkuA z92@|!<>h5S_4f8QP-JRq>d&7)^Yin8l7K8gED$&_FaV?gY+wLjpoW%~7NDe=nHfMG z5DO3j{R9kv5GbssrUpO)OyvVrlx>u0UKD0i;Dpm5S5dY16(DL5l{ixz|mhJU@&-OWCTb7_%}8-fE(P~+XIRO zJU|wp1|S>|J3KrLcz^+v1f&BDpd>&MAaibR4#5A_4(MucZwG9E1h4@u0P@C8;oo+g zIVj7kfJi{oV~E(NZ*h(@^-(Q(C`Psb3KZ{N;^GB(a8NE*Vwc715!9 zr-H4Ao|T_c6+VT_JH9H+P3>iXSt!a$F`>s`jn`w9GZ_~B!{0soaiV|O_c^R2aWa%}O3jUE)WO=pa zs~_Wz08z|ieY5A%$@FcBF9^!1a}m5ks@7gjn;67N>}S~Hrm`4sM5Hh`q7&5-N{|31 z6x1{ol7BnskoViZ0GqbLa#kW`Z)VCjt1MysKg|rT zi!?s##Ck>8c zpi|>$lGlw#@yMNi&V4`6OBGJ(H&7lqLlcTQ&1zWriG_fL>BnFcr~?;E93{M-xIozQ zO=EHQ#+?<}%@wbWWv23#!V70h9MOuUVaU>3kpTvYfc|LBw?&b*89~Gc9i&8tlT#kF ztpbZoAzkdB+UTy=tx%L3Z4)I{zY(Kb)eg{InobSJmNwPZt$14aS-uc4eKuY8h$dtfyxu^a%zA)>fYI&)@ZXky?^{5>xSC?;w4r&td6vBdi%vHm4=XJH!3yL3?Ep+T5aU_>i;yr_XGq zxZfCzUU@GvnoIk+_Nd`aky>S&H!b*{A%L>?*XPAgWL(Vf(k7qUS}>Zn=U(ZfcOc{B z3*tOHH@t5Ub5D~#N7!Fxx}P2)sy{vE_l(R7$aW&CX>c|&HY+7};vUIietK%}!phrCuh+;C@1usp;XLU<8Gq8P!rEI3ieg#W$!= zQcZr{hp>8sF?k&Yl0?B84OneiQxef-4TEFrq3O~JAZR}yEJHA|Xkqd49tR&8oq{zP zY@>J^HBV*(gJvJZc_0VFN7Sx?H7#75E3#?N8Z!C+_f53YU}pyggxx1?wQi5Yb-_`I`_V*SMx5+*P^b=ec5RON-k1cIlsBLk}(HiaJyab0`CI zo0{=1_LO$~oE2%Tl_}KURuX<`+mQN_sTdM&* zkFf!Xtl^e^gTy6ON=&gTn6)$JHQq2)33R@_!#9?BLNq-Wi{U|rVX7Vny$l6#+SZ@KvQt@VYb%<9JfapI^b9j=wa+Tqb4ei;8c5 z&1>Uz@lVFv6T4Z*YU$r4G`g=91lSeA<=GRZ!*KTWKDPR}NPUW%peCUj`Ix_LDq!8| zMH-V`Pv!a~QkTL||L@cqiTz)*G-0=ytr1KqTuFPan9y4gYD5>PleK`NZB$ev@W%t= zkp)_=lBUTLZJpAtZg;pjI;7r2y|26-N7&a(hX|`1YNM9N8{>8JAuv}hp1v`3JHT-=5lbXpbMq7X~2J5Kl zh7tyU`_AusMFZ{ej9D;Uyy;SQ!4nwgSnngsYBwdS&EO3NS*o04)*juAYl;57c2Ly0(DEZ8IY?zSph-kyxu+D`tt@oU{32J#I{vmy=#0ySPK zA+i(A3yl)qmTz*$dZi#y9FS;$;h%bY+;StNx{_R56Otq+?pGe^T^{5d7Gs&?`_r`8 zD&dzOA|j8@3A&FR5U3*eQNBf<4^4W_iS_()*8b4aaUzfk2 zzIcMWSEjm;EPZPk{j{1>oXd}pXAj!NaRm8{Sjz!D=~q3WJ@vmt6ND_?HI~|wUS1j5 z9!S1MKr7%nxoJ3k`GB^7yV~*{n~O~n6($~x5Bu{7s|JyXbAyKI4+tO(zZYMslK;Zc zzeHGVl{`iP@jfSKq>R;{+djJ9n%$%EL()Uw+sykjNQdflkJZSjqV_QDWivbZS~S{K zkE@T^Jcv)Dfm93!mf$XYnCT--_A$zo9MOkPB6&diM8MwOfV?+ApNv`moV@nqn>&lv zYbN1-M|jc~sG|yLN^1R2=`+1ih3jCshg`iP&mY$GMTcY^W^T`WOCX!{-KHmZ#GiRH zYl{|+KLn5!PCLtBy~9i}`#d^gCDDx$+GQb~uc;V#K3OgbbOG0j5{BRG-si%Bo{@lB zGIt+Ain8^C`!*S0d0OSWVO+Z89}}O8aFTZ>p&k}2gGCV zh#<$gswePFxWGT$4DC^8@84_e*^KT74?7n8!$8cg=sL$OlKr&HMh@Rr5%*Wr!xoOl zo7jItnj-xYgVTX)H1=A2bD(tleEH57#V{xAeW_ezISg5OC zg=k>hOLA^urTH_e6*vSYRqCm$J{xo}-x3@HH;bsHD1Z`Pzvsn}%cvfw%Q(}h`Dgtb z0_J^niUmoCM5$*f)6}}qi(u;cPgxfyeVaaVmOsG<)5`6tzU4wyhF;k|~|x>7-2hXpVBpc5k{L4M`Wbe6Q?tr^*B z`Y*>6*&R#~%JlBIitlZ^qGe3s21~h3U|&k%%jeMM;6!~UH|+0+<5V-_zDqZQN79?n?!Aj!Nj`YMO9?j>uqI9-Tex+nJD z%e0#Yca6(zqGUR|KITa?9x-#C0!JKJHO(+fy@1!B$%ZwJwncQW7vGYv?~!^`#L~Um zOL++>4qmqW`0Chc0T23G8|vO)tK=Z2`gvS4*qpqhIJCEv9i&&$09VO8YOz|oZ+ubd zNXVdLc&p=KsSgtmIPLN69P7xYkYQ1vJ?u1g)T!6Ru`k2wkdj*wDC)VryGu2=yb0?F z>q~~e>KZ0d_#7f3UgV%9MY1}vMgF{B8yfE{HL*pMyhYF)WDZ^^3vS8F zGlOhs%g_~pS3=WQ#494@jAXwOtr^Y|TnQ5zki>qRG)(oPY*f}U_=ip_{qB0!%w7~G zWE!P4p3khyW-JJnE>eECuYfI?^d366Shq!Wm#x&jAo>=HdCllE$>DPO0N;y#4G)D2y#B@5=N=+F%Xo2n{gKcPcK2!hP*^WSXl+ut; zyLvVoY>VL{H%Kd9^i~lsb8j4>$EllrparEOJNT?Ym>vJa$(P^tOG)5aVb_5w^*&M0 zYOJ`I`}9}UoSnYg#E(&yyK(tqr^@n}qU2H2DhkK-`2He% zgXr_4kpXoQHxAO9S`wEdmqGU4j=1JdG!OixdqB4PPP6RXA}>GM zumruUUH|ZG2$bBj)Qluj&uB=dRb)?^qomw?Z$X%#D+Q*O97eHrgVB2*mR$bFBU`*} zIem?dM)i}raTFDn@5^caxE^XFXVhBePmH9fqcTi`TLaXiueH=@06sl}>F%}h9H_e9 z>^O?LxM1EjX}NVppaO@NNQr=AtHcH-BU{yBT_vejJ#J)l^cl69Z7$sk`82Zyw7Wxt z=~J?hZm{f@W}|96FUJfy65Gk8?^{^yjhOahUMCNNpt5DJw}ZKH7b!bGiFY9y6OY&T z_N)?Jj(MuLTN36ZCJ6I5Xy7uVlrb$o*Z%=-)kPo9s?<^Yqz~!Z* z_mP8(unFq65XSi!$@YtieSQ!<7IEOaA9VkKI?lA`*(nURvfKL8cX}-+~uw9|_5)uC2`ZHcaeX7L8aG6Ghleg@F9aG%X$#g6^yP5apnB>YTz&EfS{q z9UVfSyEIczebC)qlVu5cOoMzS_jrC|)rQlAzK7sfiW0`M8mVIohazPE9Jzn*qPt%6 zZL8RELY@L09B83@Be;x5V-IHnn$}{RAT#<2JA%ttlk#^(%u}CGze|1JY5MPhbfnYG zIw%$XfBmA-<_pKLpGKwbRF$#P;@_)ech#>vj25sv25VM$ouo)?BXdRcO{)*OwTw)G zv43W~T6ekBMtUD%5Bm>`^Ltv!w4~65N!Ut5twl!Agrzyq4O2Fi3pUMtCU~>9gt_=h-f% z;1&OuSu?A_sJvIvQ+dZNo3?m1%b1+s&UAx?8sUHEe_sB7zkm4R%6)<@oYB_i5>3Ip zIA+?jVdX|zL{)?TGpx+=Ta>G80}0}Ax+722$XFNJsC1gcH56{8B)*)eU#r~HrC&}` z|EWW92&;6y;3}!L5zXa385@?-D%>dSvyK;?jqU2t_R3wvBW;$!j45uQ7tyEIQva;Db}r&bR3kqNSh)Q_$MJ#Uj3Gj1F;)sO|%6z#@<+ zi{pbYsYS#u`X$Nf($OS+lhw>xgjos1OnF^$-I$u;qhJswhH~p|ab*nO>zBrtb0ndn zxV0uh!LN`&xckTP+JW}gznSpU492)u+`f{9Yr)js`NmfYH#Wdtradc0TnKNz@Su!e zu$9}G_=ku;%4xk}eXl>)KgpuT>_<`Ud(A^a++K&pm3LbN;gI}ku@YVrA%FJBZ5$;m zobR8}OLtW4-i+qPPLS-(7<>M{)rhiPoi@?&vDeVq5%fmZk=mDdRV>Pb-l7pP1y6|J z8I>sF+TypKV=_^NwBU^>4JJq<*14GLfM2*XQzYdlqqjnE)gZsPW^E@mp&ww* zW9i>XL=uwLVZ9pO*8K>t>vdL~Ek_NUL$?LQi5sc#1Q-f6-ywKcIT8Kw?C(_3pbR`e|)%9S-({if|E+hR2W!&qfQ&UiF^I!|M#xhdWsenv^wpKCBiuxXbnp85`{i|;BM?Ba`lqTA zyRm=UWJl&E{8JzYDHFu>*Z10-?#A8D|5jW9Ho0*CAs0fAy~MqbwYuOq9jjt9*nuHI zbDwKvh)5Ir$r!fS5|;?Dt>V+@F*v8=TJJF)TdnC#Mk>+tGDGCw;A~^PC`gUt*<(|i zB{{g{`uFehu`$fm4)&k7`u{xIV)yvA(%5SxX9MS80p2EKnLtCZ>tlX>*Z6nd&6-Mv$5rHD*db;&IBK3KH&M<+ArlGXDRdX1VVO4)&R$f4NxXI>GBh zSv|h>5GDAI(4E`@F?EnW zS>#c&Gw6~_XL`qQG4bK`W*>hek4LX*efn6|_MY+rXkNyAuu?NxS%L7~9tD3cn7&p( zCtfqe6sjB&Q-Vs7BP5+%;#Gk};4xtwU!KY0XXbmkUy$kR9)!~?*v)qw00!+Yg^#H> zc#8*z6zZo>+(bud?K<*!QO4ehiTCK&PD4G&n)Tr9X_3r-we z?fI+}-G~Yn93gI6F{}Dw_SC*FLZ)5(85zp4%uubtD)J)UELLkvGk4#tw&Tussa)mTD$R2&O~{ zCI3>fr-!-b@EGRI%g0L8UU%%u_<;e9439JNV;4KSxd|78v+I+8^rmMf3f40Jb}wEszROD?xBZu>Ll3;sUIoNxDK3|j3*sam2tC@@e$ z^!;+AK>efeBJB%ALsQ{uFui)oDoq()2USi?n=6C3#eetz?wPswc={I<8x=(8lE4EIsUfyGNZ{|KYn1IR|=E==f z(;!A5(-2y^2xRFCSPqzHAZn5RCN_bp22T(KEtjA(rFZ%>a4@STrHZflxKoqe9Z4@^ zM*scx_y73?Q{vt6?~WEl?2q*;@8 z3M*&@%l)SQmXkcUm)d@GT2#JdzhfSAP9|n#C;$E8X|pwD!r#X?0P>0ZisQ~TNqupW z*lUY~+ikD`vQb?@SAWX#r*Y+;=_|oacL$2CL$^(mV}aKO77pg}O+-=T1oLBT5sL2i z42Qth2+0@C`c+*D0*5!qy26sis<9a7>LN2{z%Qj49t z=L@x`4$ALHb*3COHoT?5S_c(Hs}g!V>W^=6Q0}zaubkDn)(lTax0+!+%B}9Vqw6{H zvL|BRM`O<@;eVi1DzM!tXtBrA20Ce@^Jz|>%X-t`vi-%WweXCh_LhI#bUg2*pcP~R z*RuTUzBKLXO~~uMd&o$v3@d0shHfUjC6c539PE6rF&;Ufa(Rw@K1*m7?f5)t`MjH0 z)_V(cajV5Am>f!kWcI@5rE8t6$S>5M=k=aRZROH6fA^jJp~2NlR4;Q2>L$7F#RT#9 z>4@1RhWG`Khy>P2j1Yx^BBL{S`niMaxlSWV-JBU0-T9zZ%>7mR3l$~QV$({o0;jTI ze5=cN^!Bc2bT|BcojXp~K#2cM>OTe*cM{Kg-j*CkiW)EGQot^}s;cy8_1_@JA0Whq zlrNr+R;Efa+`6N)s5rH*|E)nYZ3uqkk2C(E7@A|3YI`ozP~9Lexx#*1(r8luq+YPk z{J}c$s` zPM35Fx(YWB3Z5IYnN+L_4|jaR(5iWJi2~l&xy}aU7kW?o-V*6Av2wyZTG!E2KSW2* zGRLQkQU;Oz##ie-Z4fI)WSRxn$(ZcD;TL+;^r=a4(G~H3ZhK$lSXZj?cvyY8%d9JM zzc3#pD^W_QnWy#rx#;c&N@sqHhrnHRmj#i;s%zLm6SE(n&BWpd&f7>XnjV}OlZntI70fq%8~9<7 zMYaw`E-rp49-oC1N_uZTo)Cu%RR2QWdHpzQIcNsoDp`3xfP+`gI?tVQZ4X={qU?(n zV>0ASES^Xuc;9JBji{)RnFL(Lez;8XbB1uWaMp@p?7xhXk6V#!6B@aP4Rz7-K%a>i z?fvf}va_DGUXlI#4--`A3qK7J?-HwnG7O~H2;zR~RLW)_^#La!=}+>KW#anZ{|^D3 B7G?kd diff --git a/msgpack-idl-web/static/img/glyphicons-halflings.png b/msgpack-idl-web/static/img/glyphicons-halflings.png deleted file mode 100644 index 79bc568c21395d5a5ceab62fadb04457094b2ac7..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 13826 zcma)jby!@B+o%-915yyF0YFyB4?Ne(CRg z-#O<#&wb84`D17H-t*49Gi$BAvS#fBDJx22pcA4aAt7PN%1EdpAw8RXk~3bSJRMO{ zLOPzl2q2PL5H+wV#M#IJgd}PLHU^Q&+8CLER6#~2F82K(0VJg7mlo<;5G{o-d_b@b zi_u>l7MP9Q6B-FgKp19c1hfJ{$c#Z|7Pf*EM~$r%WELiZ6q=k0YzlVbAae^DR|k-q ztD-v4)e6XKLLn?fCII7mGGGIO7?HtjtZg0nV1g9?*yVeY|6XRLAp1uJVkJoNAEdMt zl*z=w4j?j47B*%e8y7nn*Jl>?&uqM(d6~#Qv9YtUvVUS_<7Q@Os%DRy=VF;OnbPZB&l+~Sg=;$olKxc@r)Yv8{FpRTZ&JYl7zK5_7had2=;im|h^ zOS1E@^NNabNpOiuiHY)jW|#UmR@T-LVq^;h{dM{mYw=&$PyZv9Puu}y1OYp!gTdDS z?kdXWUuEt5GU<9?B8*-aqzJHUs!SW&!V4sCD=ZRit}=F za#FB9kud@CK`bEFpnvsHQESM*Bx{Smy@b!&$kyyB9n2;mQzNJ~ghI&7+QrV?0tmKs zG<38vvbHufF>%IThd>Rse#s3_OPbdF5nnAWt zL)hVIta5&^8bd;2&ytl8Rfo+Tcz~_-Bx?#ZE2<3oUBe})+zpAGX&=O$_aCJBN!CBt zv~LUxtg{dH^uI`jCU#YZa*6x&AyIg@k@bxImc$%rVne48BslqY$+TLFj(v37h7yfx z$^jmG#g_Rs?ETA?`?LMJ^OpUDIY(RQdGlgR?XG$OKf8PyqRZyid2g!3%@a^C1igpD z2NKzV@|1wiF}EtKQRH|$CJJ9)q3e}#g7m#Zl(d`W;iCBregW~kz}j^J z#1PLChA^$dal^V@@cK(w}dv%n2!w4^wV*y35J)-xE{$fXwc@pa}RzJm5M)#tr)iJZA7 zBA<^jjwJWvLx1>RPDIS^k*z$pgpiQZ-O2S}m#&N|A4@|nID3F1~ z+{<)-J1C8b8ezW2FI#gotv2}C#wQERQ(Bd4_} zR$QREVi8_9nE3}6@Vks1@*cVLJrSLt#`lb0$M?!xg%%C;C!jFg2$sX)U0bprNA043 zt1cd;7oNIanP3?<(O0mgAc`)87;35OB;`nL3-yw7Fq`<#Hqz;v+Mj? z%y|w07f93V#m`17f@xa3g&Kss@<20hE22A#Ba2fDjWQe?u<#pkgd4DKg$db>BIa`q zqEeb}1&O#H`nWg^GT=P^c&c$+@UcRMn~k-y&+aN^ic}0j)s9vGd$m}}SL4iw!tr4e z74SRhmFujYvTL$e!;=bil=GRdGp3UA1~R?@@XL?>oK21E-g3xj0Gu;SC|l|8wmd~d zG@8i53Tu3s9ldBp@%(!A6E=rZOl&LAvv1Nkj=ysQ(9(~g-8X6}A>#Y#1a(KQ1TAh( z`*b|k%zN|vOG$C7_4PTiy8Lhr&rZ~I!*iV zG+W%bI&HR#n{T~n|CLrV#?k5#Et)n4f;XdM7~@Er-K9uS8vPNM>uZUibWxth=wqXp zt{0wO*|bZs%9J3Y;Tj4)?d>OBZ>YUb@tFh)1KiKdOeB10_CBOTMml4P#hsP|NnH`$ zn8C$aG#8|gqT#i}vYTeH^aF(r1JFKcz$K3~!6}2FX0@^RHCL+33v-FhYXz#e!VN4~ z3pAY$kL`HvPAaz%ZKvX4N680T6G=`cF|!UT=iU?gUR}#z>rLnIjH4UiW&X!Z2Ih$B z#MDHe_%!Yd4!bTFMGeNcO(+vEfWe=Y&#$#Dh_vk`s>hf<^Bj2jofdTiH?Cvh55o&b zE2N(49<70oDa2DrZnfjbhn{Jl;CT6QCOL517jsNXxh ztk>S%Nl!1kKE!_Y1E%82zuk(#fmi4VMZZ|C9XG#t=_a%pE(?AS@K%j{n=lj?kEKY< zW|3b0>CWE2bkN^RapDK@3*dIhwI~%Mb87ZxnF|-bX;tNwFf}3s_Ti{S8}(TUA=c4( zY2Z!UZS&H=Pk;r%irg?jcz?{s!|V*#QA4{2Fzp37$r+}Z-K{*#DE7B^Inz!%Q9nU} zU%!E(b~61SJ_R5KSY88G!*+2Crm?Vp1DUFviD)lB1c&Atk+dP7K7{oK1?N#HTx(Jx zis^|e#sUW_TPZE3IGu1R+xV`&BV&1NNkrD4j;(NEKdkpSdz8YLZ}ya474taW7yY@8 zsA-+N{3&saE60RSnI802s?NYn0KiULv+`y9hNB!6%B_qCFHMhVOa;O!ge!LzPKbk( zbOnDN{s12ui~i)C55qt9+S4F%_rqna@M}~Kvh3z-^-K67%2T=8H8g<_=LYj#`6IF< z&#}t=5w#4@^{y}B4J8rm?|c7nu!l2bJZ`U-W4@aT)V{Bm!c%#8HewtNPwZ4>dYBdQ z$`?MJMLJt7`j`p7Y7C@WWmQu(B(vQ&FMa>ZZpX>;(|`+m?2Yl|fhX43DejM5BMl`? zr(v=9l4R8Y3}+Abj6x1X^T?$#`1;s>I24lFFFn~&HRgQK%%Ey(mn=20z;U>um1z~Q zJG*-wAw;tG!?{U#JnA5M5rX*u%NF+}y;0xPbTQppWv;^8{aGUxG$gD!0YAlLo;KuE zkFzemm@vHoQYYv<_b|t(esPHC%z-nLF5Q9^?&hl?0?g0d9hVSdDc=X~B?dQzaRfp; z+2*{_ss{}_cv+!%k7WX20;r5{GER*rd{={D1l}-^Se~*W+_M}?z+w9HX;SR@AB6by zI0}UM&nJY!1O!_&a8xRuf`=Drhp4bwFD4GN;7|wXEpdq}@{E+u#{VT}-UEwtWPkxKl^Wa8Qi?#AQLxY4w+?_Y4 zd1glMwHFc0bglfOS-7V_h zjsOP>)fG0TPo!`fIkeDn-b_WlxJH)NqQqX{Cjt1+PPI$%JFTSWT#$Mj_6O?PY#fK3 zMy2&j?Y~|hc!Xla$G$#xZ0%AyTx!yYt=5!)nk&0@J-$=t?&(X;8%~rQYD<{9lr1z zs@8X~WZq3R1+cmT>`KWeE&^_UF>|q&Ay^}*sN63yo7B9nz}D!eQt$6m26sKn>O$P zmvsnQ7b9nJQ46`zs$s*Wtto!ux2}?)U%;Z5%hb7!$w!&8C`>TRG+*DdD0JLss5Xff zBThm&kGp*Qxmrsc3GjV@6TVB6)l|r!wyRJP)U%eM@Of-k4FDYmUY)1+7EUyRGbs_` zleaIf78kfz<{vx`Ls^b4Ogd8_rSR#I2AH%NK)|Vfh#}z~2k0bJcEvc$3He?p;bGVK zyam;#Nl5X&J8j^k<~QS18sq4NPR$kE>m%=`^Ki#+ieKpZYF?TTM#Jv80{<7eYn$&q2aN=p)lq6fG9}Dv2}g_RSVx*Iv-0C}kEWsUw>e$24l?hUH3zqG z2Sa%=_ql^t*`t3yW7`PZ(-yol6mNfiUV1c7e)%BgzOh%HQQd^uq9gC3O*vPSi&V!$ zuJ-gy-6_@)r?@+~#wK_V|QHgllM9B^dZanlnPLZqhL-@Wql1PDLO_j>7Nz?o z+_&sbFV42Gr7019rPl3IUH2}h2Wl+=p46k?>x70Pnt9Gn_CduyDht`=S4b}9&F^387k|mAZg2^t9(aD+I+W{ z#iMaSJ%Slg$*$}d;|(Q|7`BKm3z9) zh-*c!-WX<4{kD>(FE8TvP+#HUL}QrAKt*0vVL7!~ovM)?Ur`?N{))Ew;yk>PkfjG- z*)^I$qo~mV?U!~Gwi(1*M)0+vT9Jy~`kGC^1<}kh2R4PgR^?53j%>|Ns{2kn=ewGn zvPvguwaHo(xrDKI-r{x~q$onf~4u$MK|{q*`g)sDyNO(})q!R?7xZH;c=m6iWiHEU8Q0KT-e zKaAgECVApd!3(FjK2!e|a^g^-5f7L7jB^GFCrwQ_*B`o?=jeoDN_*x+cXrv8gf$36NQ*!QC!Kwg5~wLak^RyUvu(CifB7CA>(1lu6}+@1^DvB!>VYXX?9Ys*9wd&0abG}7TGJ`WsH;FX_s&}n4v(1m|Q)++R8J>#?XO`$8g+3q` zwN~X&6{@){!8Q1(2!in4P8(_gYuOhhFGZ;=C-6kTb%~vBQQ*b-=z*J+>E;6ujm;wX zvb?kY(oC=+ca4)i4a#h@{dTzWSLS3ag^66Gpkn{ke!AC9A{1jMRP%OcQ)<<@nxJH} zZIr?|jBinPoiR)snBOcecjcb@Wuh3my1iVRzl-u;gB}~Rjhub`?Cfu)nPL3L+b$kL zO32z2XK-0_shy`%ZT9<2V<1qI5Rel|E7W{`Hg#M|m&O0`Ua-&p;v}tapS>wTE*On` z756q!EO*AN?oxlV&@ybUeVWd1q~Tg`kpqG}F@V;VsN#&)R^`V00X5}(4*PmNqShEg zQih?Ga1nmgvx@-!Wngeg;A+L{F-(i zf_X7=?WU?j|23>ePpP8OODXHU69Lw_MmSudzHtic8)MWn1BPdI_Ae4ykPB0u9il*G zJ?$Q@);~I`)dd=AQuaxcTe2HSse|E|ii5U_*5>3~bz~#PL%91W(Nyd|=|ZA6*w`c7 z$R1sRD@XhF^&4gJ#exDQRqq3%$Y|oPc!wXV-=n37^UJ=Olj%RP#gEAol|$!AAbjxW zXq&hxEZQyPL4JOa6I*343W#)9&u%!GDhw_3B>yJ7)O`Ae76GRZenb(|eWOMZU_spF zuD{--T)B0<*4E?|ri0F<=p!twyj!hH;HlUN0Htt?hj8zO#!~F83W|K9Lvq z3{RaoPbjaDFu@z{^qW3cjj7kS$GR|;9I%R~LZ@6(ENvrteZFbkkow-9p%qZBx>J+M zq8}TEyApxpU@n((iw0bRrJvc6Cd$y8wbf4?-w4%S5$Slysc^DTKW~+Y`!?zI;_DZL zV9KO0`~P=A@%O2`KlPzF{xwsO>z5=mqo0Z23o-D!NekrdbEa^%TfV56v|FDM?4cKX z@rrk@JJ?1_5irzO66hc^C*{*Ke&o=Ijw!R*ZAgtQC0ezeL17SocQu_m!6VUsNTcVG zpwRaCZCIJ=OR~@li`X(c8LO9k&wjr&0Gd_GRou<{3Hu`Css}PU72iy4PZtFd(l9VK zR)fk*&dPTy&yMX{o8@~bPnX0_Q@UX-RN+o|sC$;fpA|xTEugMj7@)yJ{4@bO3x^+O zH0OTqp82(iEah+>0QWS z$@9x&MNFG_ayE3OJxi@l$%9i2{OAD1go7t5}Sv8p*L*?_XV-Inr zpe~mOfBekpsM*iZA4B0U-_aDDuQGQ>$du+c-pHfXyBaLv@T`?*-je(+>E!q1bXa1q z14-*PWvM+oFg(z{YlRS2em5Pw1U1&De`{t$Pg={frAk6|^cDRB$0e*ut zvJ=N0<2rG{&|2ECVoU=~V0R9rfUWk0Z${R3(A&#kkMCPoz`s?k7N+_8!1v32J*zyO zR9Lv8#NK_E; zsf^8eBN5l`rT5}^m`=Z(Oaw_(G`KLa6xX%V@W0keWi;An4+N4QThS_k{n&Vyk{0!?N_d)(8r)?>J|F`-ZusfRTzNO)+h%L=-)$92e&Ck?1oAE(~~ z$-n~o0g*n;RB*mqiaAn=Wlm0w2D6Yu&4fY#;MU1bvU(~NK6m1FUoPk+w;|b?nzGkO z_PUIl=pfDRhrLvm<;sb9>BFB~Sc4oJ;hS&xb#O~;Q7(2b8< zQ9Hg8isf_ddK#6OY$>r#Kxz@D+gtkY>hy|#o8Z-=^bH`o)WbuhhdK98@PHbw2Zt=7 zV$-oYeC$U<;|pnaU4187;%~hxdnq*JOnEGam?8hex6Iy=ZlWGzZv-4 zoJ{KX4x(J5=P>qor+5;Qvhp3GFBpXJ9fO3crB!vqua&Y$iFJdsGsQL15;##Wtx)a! zYY)JHGBW`d%x6ZI`{f6_r^+OdBbZk{<-B0y4iS|--^SLDWVMu&VT?M2Z|8*E=pfeq z);Kt;$?dDKuIJvdZG|d_=QWvbk?X!+UMjWng_S4uk_M}7f`V03>h!f-=Qxpm9ReU7 za!V9@Dytw&Y;Dn_tG@+O7`;DiSse1^ilx|o^~@+CRqBxKgXtuFTdkV9s}V3?Sy6{S z*XctI(Eyb3h^4g}R#0C=Al$1x3GX$~3fA}}eX>>DF+LFj4zJ()a-xd1d6P?W{`m*D z*x%43iLpP6D8xOj1Z<^h)%1C*{`|uBM zAKe~zJa>JT4Tqn|wxn>-+P9_i;yHBP@*ap6jMJgu7>d2GIq{>J`g;o%tKlmpM-RrSw{_pAKK; zSq)!`7M=VE#*z4?xSugikUTPD}y7GXhB{U`6@}s8z0d@C`F9EQ3#s|A3?{zk{KOin$?&5UgsTdnL zO1i!hQhbL?LiIIX*RA*iV$~) zB>zWXKyBeJC4}W_3SGU)PQseJzO;g~99>U&xx8@V2Qp$StzgO_?GxT!9UmQV2vt-^ zkab;==s?$tI#Akh4J+G|pAPYZQ5vA(8|@a9T2-p=)uPN{@6f@tmW11S)1s z!h%|zyG6Dc);F%IdWaK*t#r*khD51^8Ay)ixzUtt=#AX2VmjE zOFg-|2AdD>SmMSf?bo9uRB)zYaT{m9I%7Vs)$dLGX>bj<#I2?S8OUQRh(mJrJhADZ zT_^gL-3m0*JIokIbOUyiA83%98nW2{Wp2BW5akVi?klylc_3UwSpIlPTwb zEIG-t+EJ;a3(OZ-sGt+R_j^Z;x|qvjBr|7-{wn4kOG&^GRt$u`kMx zzV;Zy-UA7<xMJg(rd2`sKuS9&FoYuUoug>t*^~eJTjg>pWcBUABu-7%@{xM zICt)A_$aq9KQ1!{${`~7GXd+8ZDmu`rjx$oiC@GP<}zwn_dR8&M)WQdC&iw3E)YGG z>3e7ZNZUGzmYhW2?kKOPphuHB2q3zn7e!n3V8t*?@hpE5fc7snCI0l&iE)SiOs(W%=b1^y8b;aHjB&KaO|McF*t%v`zlW*&h5@1@_C^ zu@=`+#rV2TS56EeCh=>uP<-lPc^}fc208qOOb9~TKo;7L zA~1!rYZOt)&{UFvJI5a$VIW+Rn=eIQsZ^sU)8hNGK};PpknpE84hIhht07)(ER+4_ zxLhMx$;116i@tQodN*XTcFS{`!fPjk0n} z1udu3=k`@uaQK?j)YF!Z2n=fc zY`~>$*#BZX+mGk=DFM0Z|L3%DK(H(w+__!4UF`kf9Jf(YzE zR+p>6%a^g;g${|zdmK6-Gj(({7pl{TV*3&Z!Tg4cKvV0j;*Hb(Z#qmw#wdm`wZ8ts zjIUMJ`h#Vh4=S1zDw~a^H)q+6{ z#Hz!oYPE7ZFi~~AG7n#q$;s}pANs@VyV5vhU2&d`=@Es*pQh}pgHHCW`KB+GEa9ck zW`9DlW`Wvi6+8Jp#bM-ebD50CjykM&Y5Nb{=n_#L!>gatGhc`j`D$a>B*m5@1=_tY z1!7V55YfU?hSlU@@flw?^BFXCnLzGQ5nOAvVvjQP>otW|mQj7Pc1evAEdaVt_O7si zLf)Opv3>@Ky-^Y?)9yR;H}8pcbX&{bu?-8JE^rhUOvU2ko_d9PU&9pXO^>cRZ#zZo zCkq39jb4}nCKp>1oQXcr)#BC}eH;uS!al|lo`b0S;{)B1C!B9NGJ7sRRf8u~;@IH-gDB{~GwmgyVn+go-vI%&pi z&YpjGP!eesJV1P}>w0bDVqj#o(Td$rcY=Dy(vmsW4Lu7vblFZ1AkwFt&8yEeH+$MF z-`f?Kpo$}2=fdkh7scLN3X|LFczR*OC>3vQN$>T`HJ{7Et7(nPTo6piDNA7Mqp=3RT0d>DNW?+-b;wgbWc@xKrOgn@*hcG0Bl300~zM z1cqJaF;{x*c%r%A4-dBquj5*G&bu!gKwoO_nS;LQT^1W`?RvhSP_8$3==>+aY-PTt z>bq-vSj!54>+X4cy9uFc7n4e89$B@NcVD5A-ZJOxHgc`}0Xekmrnv zFXt>J(de%xG=HqM%#sdc`1MGQF^WDoQiWxMaI(4dHmX&4!LlBo`(Of>F#wiHG2!fZ zvB{2Q#2#f}GF24rrVMQV1q+OtDek8cd8z74b#rGk91~90FBtkjwVnDn53id&|26Z`rO1<>1bMNki zIionO>*HS1J4(aUYgwsF#kSB3LoKM6=_L4awnOEIti-PdFWHKvSHkYopzzkmO{#f! zBCp*D{8xF0vlect8R3v&sfl^TuDXSf&P%wC74{#9?N5X!pC24A7h4?)2V-9N|c{C;w5wl|z8<2X0es$`*M5j(oF{0r&32 z`U~-Q8qfbA;nM54%Pd-|nK@0LdSA=5KyqV*g)A>?W!gQiNj|kKfej`z+TWeH!`Hpg z4x)z(>^8nLqTC<9RW5iJvCjWHv7}1afGXDDjvlcDu^s2txL;E`C?VN3k?3wy4?Rg4 znmrvze0;v4z1-miFC~klv>fjZbDDi1Sb3^nk~4(v>AQ0kEgcS!BT@@JFn156+M2%+9d~_aj?sf*d7G$H=KZ+;~_5OXv~HkLZB`D1C0=ySHh6%$1n_d9W{Z z&m>oGu#UW7!b=#@N;S*cUt1_&zh6G6Pp&1MS&qW^nP8>f9Vydi7A|Q=nJs1UqHe~% zo8!0@d07eTQ)zRgq2lRbPX=U9X)}<}K~;F^6$@(xJg{M=ogF(BJK$Va())Mp;3$9P zb1zLrct_$*_$9%}3(n0%gfU}7>#&k71PXy}!LO#cR3p!xc`NR8zFQw{A$DKq6Oeuw z;ZC#iv;VMss-vmXR&ElJ5dxInx1l|}uEaG5i80LcV~4TkD%!RUD@5+~l+kiSOpS0( zJ-iwpm}JCR@Sy?BW$_tvO%K-fQUFm-UCi;NK$-MsQoWnQXO+(qUd!{zFS!JepUfxD zmmoFLB>{OkHam{gP2#GXZaq&=xio1Kop4j#`v}Qz6U1D0dc!ks4ikn{Y6ti#ZeqYgF+ z0jQIIQUvnReW)_53Z+>u>)Lw((~vxa6AFrr%d}nI!o7{spwl@ir`qH9j7o=6JXYD| zsp>X-yI}#VHc1S{c}{E|acAh>zF%*}R`4 zM+xtI9F&>Xs(IJooneFYo;l{cU*-2DT~2TUm;QwTC9RXwFSwqHS82mcZmDj8xVn(+ zhjg5e>~E9?3K-*RvJ)uCq0UIdRl~D85$B^#Nph2%)6FN1>6!u6+%oE;F=J5B=`W{` zL<6;Qu8Pq|0+tS%yP10nmIgUV^r%Hyjyo|#W0hIVR`qiw@r)O7`K*l4Ma$$u=XQc$ z^#q3KLI6#VtuIxX4b;#_lx#bieZGmNS8?8jxHeTsE52O+t4ih5iw}=p7@DZs*!jev z{i#&SO#GsN^zjC{G<~Nu|2>~?q2Z@)UnNDB&2?wHQCn?p9v7YpNRPW1 zWM9#550th&<~(gv_Sok5g3e8tnTzkV2|gxe#kE{nUT{aP8n5=}qg4mCp!JuEcz=Ht z&y3I7&uxdKU%P7D+5NV%Ok}hj@mimhKlv+R1bd8?zb|20JJD?Q?=vElsc#c2!VJmq z&W&vW+CaWx`FG1VfMsEf)`p}0TTes}|I{%_X{vj;}wDxh!zb$|D=4e756H z7dp8?Ul~60@eSwbY!+Crzr*mLMSqj6ofW&@mJB8fIGm%=B28`wnbx8F8YnigN|~sB z)ie@y57LaLin3|;u`JzFDsS0JCrG!Z4g+Nd*=-JadG7AesG5y*rMun?dHJhkCMW_% zCal ztKYWr0+ECjETkqk!9jw#hv?D8BB>sVztP<9s&fY3kg7O(65kdl!pnzWhNl>mkKBOP z9wGNuspXb&`T7gZLu#Y670KyIg|D$foZ^6CxK^NurqGjTAORgOb-D`MnNNRW8Xw=g z8)`pHz^^@&DlTfcLBTlT7>c#c{d1Rs^_EM?6rpWz{8ZrZ3&E3&F=tOC;zGnc>6#NjY1JQMZ!+8#j*!95<*U{5CE&b@6WIV= z`L8w`z0>!&Y?@c9IUIXc)WVTOpF}^_=xxWoJZGv|AT41`N;g@MZhWeGa@pxlgGji8 zR3?G5Rb3_fNj8zy!w)Nl>leQXO0(UI&kdY+N-i0G7Z%q|`!Oo^N%yZLWCBLMop?7) z`#d}b79JtI-AG(Fx@TIi!6u-D3-^!Dlae;43Yp1%MZ9XATQ^#ln*F21RntEEXZFkB z`SV+qf>QWy^~x~X!#q&<(a*gW8Npq#5?J;o^D1<$rOl;PQ2b4cBvE-R>e$@3lbK}qIv=--S zEeI|aC9>S#V3jN>JO#=lUV`ja4_n@N34a(b9DsX~5L~fhJpe=AgZbr~VX+0ZQY{x^ z(k)K(A0~mNkFt zA8e)|)*K0!nFmOg^$p@)RlWA0%f_jul)Ga}wOT-A_SHF)3v!5Ywj5XdkuSTR2s1b> z60lzNZMkjx`b~_wapzIo-Eku>H`NV#XFRgb*F@gDM&yDMiwX=D%B zmzw)_!+aX+zV8mY9at~%ev^rb^(0rwKSp(3};ZpMvxEwD2OjDaVA6Ry$0&8rtZV3pHxzf$? zzAjYXA~;b|XCc95MUR%dTT@Z>0}uY+8y=;wW1vky{pKP;cOV}6&6tV$I;>`FK z906wPfPrz9t=;&M?(Wwdm z0?&;KzLQk84srC-9#ap*I_9GregSZjm<$6oiZ>h3ACEnS7A^faq{fPmD!rT69qQG% zRVF#+RDZ(-Ue?g!$?;NT#p=8F8SV%EZ5ry{-5J)UN6Jj~-klPlw7o4w&aUp0pn@@) zM(jp3}a6rP@=sC1ZvM zV)jL-HO|elZ@x|hHXkrmGu9uS2%=Jqa zgIqpCmA+s{=XewW1!LqE)3%%mIO z(8jQbk;xApH`iS0;h7M96j^_3N=#|-xP-=*>3=obmL(W)Au>jdy3E<UjD;R zOI^Va(lW(qH`MjF&}RqCOifgKKA39SANA9=Qv4z+3Qey|4BJBzex_v%9=l5D-xJaG`?IF#?EKul!io4R+`>v>t_65&VXqROwiMr@*>SD)gNHL4^Ml5(vgCqodJjd$~XNSPzt@GziL=mgy;Y+qBZh&1qKxwm{>$kMCyH2rN?F2%^-bX#z9QBC| zNx?aIaFXEMqAKsMWDfWB@Pt3@$5LZ%DVDT70icB1BXM`F_#4rYqTkpk%wf tVgFekgZM{XhA!KlmFcR^%iaf4$rSfz)nO-hfB%&wE2$_^D)!aq{{YOB6}SKZ diff --git a/msgpack-idl-web/templates/default-layout-wrapper.hamlet b/msgpack-idl-web/templates/default-layout-wrapper.hamlet deleted file mode 100644 index 37a22d9..0000000 --- a/msgpack-idl-web/templates/default-layout-wrapper.hamlet +++ /dev/null @@ -1,47 +0,0 @@ -\ -\ -\ -\ -\ - - - - - #{pageTitle pc} - <meta name="description" content=""> - <meta name="author" content=""> - - <meta name="viewport" content="width=device-width,initial-scale=1"> - - ^{pageHead pc} - - \<!--[if lt IE 9]> - \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> - \<![endif]--> - - <script> - document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); - <body> - <div class="container"> - <header> - <div id="main" role="main"> - ^{pageBody pc} - <footer> - #{extraCopyright $ appExtra $ settings master} - - $maybe analytics <- extraAnalytics $ appExtra $ settings master - <script> - if(!window.location.href.match(/localhost/)){ - window._gaq = [['_setAccount','#{analytics}'],['_trackPageview'],['_trackPageLoadTime']]; - (function() { - \ var ga = document.createElement('script'); ga.type = 'text/javascript'; ga.async = true; - \ ga.src = ('https:' == document.location.protocol ? 'https://ssl/' : 'http://www/') + '.google-analytics.com/ga.js'; - \ var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(ga, s); - })(); - } - \<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6. chromium.org/developers/how-tos/chrome-frame-getting-started --> - \<!--[if lt IE 7 ]> - <script src="https://ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js"> - <script> - window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})}) - \<![endif]--> diff --git a/msgpack-idl-web/templates/default-layout.hamlet b/msgpack-idl-web/templates/default-layout.hamlet deleted file mode 100644 index fa86744..0000000 --- a/msgpack-idl-web/templates/default-layout.hamlet +++ /dev/null @@ -1,3 +0,0 @@ -$maybe msg <- mmsg - <div #message>#{msg} -^{widget} diff --git a/msgpack-idl-web/templates/homepage.hamlet b/msgpack-idl-web/templates/homepage.hamlet deleted file mode 100644 index 43f4202..0000000 --- a/msgpack-idl-web/templates/homepage.hamlet +++ /dev/null @@ -1,20 +0,0 @@ -<h1>MessagePack IDL Code Generator - -<form.well method=post action=@{HomeR}> - <label>IDL Name - <input type="text" name="name"> - <label>IDL Source - <textarea.input-xxlarge rows="20" name="source"> - #{defaultCode} - - <label>Language to Generate - <select name="lang"> - <option value="cpp">C++ - <option value="java">Java - <option value="python">Python - <option value="ruby">Ruby - - <label>Namespace / Package name / Module name - <input type="text" name="namespace"> - - <button.btn type="submit">Generate diff --git a/msgpack-idl-web/templates/homepage.julius b/msgpack-idl-web/templates/homepage.julius deleted file mode 100644 index efae799..0000000 --- a/msgpack-idl-web/templates/homepage.julius +++ /dev/null @@ -1 +0,0 @@ -document.getElementById("#{aDomId}").innerHTML = "This text was added by the Javascript part of the homepage widget."; diff --git a/msgpack-idl-web/templates/homepage.lucius b/msgpack-idl-web/templates/homepage.lucius deleted file mode 100644 index 54986f8..0000000 --- a/msgpack-idl-web/templates/homepage.lucius +++ /dev/null @@ -1,6 +0,0 @@ -h1 { - text-align: center -} -h2##{aDomId} { - color: #990 -} diff --git a/msgpack-idl-web/templates/normalize.lucius b/msgpack-idl-web/templates/normalize.lucius deleted file mode 100644 index 9fc7ae4..0000000 --- a/msgpack-idl-web/templates/normalize.lucius +++ /dev/null @@ -1,439 +0,0 @@ -/*! normalize.css 2011-08-12T17:28 UTC · http://github.com/necolas/normalize.css */ - -/* ============================================================================= - HTML5 display definitions - ========================================================================== */ - -/* - * Corrects block display not defined in IE6/7/8/9 & FF3 - */ - -article, -aside, -details, -figcaption, -figure, -footer, -header, -hgroup, -nav, -section { - display: block; -} - -/* - * Corrects inline-block display not defined in IE6/7/8/9 & FF3 - */ - -audio, -canvas, -video { - display: inline-block; - *display: inline; - *zoom: 1; -} - -/* - * Prevents modern browsers from displaying 'audio' without controls - */ - -audio:not([controls]) { - display: none; -} - -/* - * Addresses styling for 'hidden' attribute not present in IE7/8/9, FF3, S4 - * Known issue: no IE6 support - */ - -[hidden] { - display: none; -} - - -/* ============================================================================= - Base - ========================================================================== */ - -/* - * 1. Corrects text resizing oddly in IE6/7 when body font-size is set using em units - * http://clagnut.com/blog/348/#c790 - * 2. Keeps page centred in all browsers regardless of content height - * 3. Prevents iOS text size adjust after orientation change, without disabling user zoom - * www.456bereastreet.com/archive/201012/controlling_text_size_in_safari_for_ios_without_disabling_user_zoom/ - */ - -html { - font-size: 100%; /* 1 */ - overflow-y: scroll; /* 2 */ - -webkit-text-size-adjust: 100%; /* 3 */ - -ms-text-size-adjust: 100%; /* 3 */ -} - -/* - * Addresses margins handled incorrectly in IE6/7 - */ - -body { - margin: 0; -} - -/* - * Addresses font-family inconsistency between 'textarea' and other form elements. - */ - -body, -button, -input, -select, -textarea { - font-family: sans-serif; -} - - -/* ============================================================================= - Links - ========================================================================== */ - -a { - color: #00e; -} - -a:visited { - color: #551a8b; -} - -/* - * Addresses outline displayed oddly in Chrome - */ - -a:focus { - outline: thin dotted; -} - -/* - * Improves readability when focused and also mouse hovered in all browsers - * people.opera.com/patrickl/experiments/keyboard/test - */ - -a:hover, -a:active { - outline: 0; -} - - -/* ============================================================================= - Typography - ========================================================================== */ - -/* - * Addresses styling not present in IE7/8/9, S5, Chrome - */ - -abbr[title] { - border-bottom: 1px dotted; -} - -/* - * Addresses style set to 'bolder' in FF3/4, S4/5, Chrome -*/ - -b, -strong { - font-weight: bold; -} - -blockquote { - margin: 1em 40px; -} - -/* - * Addresses styling not present in S5, Chrome - */ - -dfn { - font-style: italic; -} - -/* - * Addresses styling not present in IE6/7/8/9 - */ - -mark { - background: #ff0; - color: #000; -} - -/* - * Corrects font family set oddly in IE6, S4/5, Chrome - * en.wikipedia.org/wiki/User:Davidgothberg/Test59 - */ - -pre, -code, -kbd, -samp { - font-family: monospace, serif; - _font-family: 'courier new', monospace; - font-size: 1em; -} - -/* - * Improves readability of pre-formatted text in all browsers - */ - -pre { - white-space: pre; - white-space: pre-wrap; - word-wrap: break-word; -} - -/* - * 1. Addresses CSS quotes not supported in IE6/7 - * 2. Addresses quote property not supported in S4 - */ - -/* 1 */ - -q { - quotes: none; -} - -/* 2 */ - -q:before, -q:after { - content: ''; - content: none; -} - -small { - font-size: 75%; -} - -/* - * Prevents sub and sup affecting line-height in all browsers - * gist.github.com/413930 - */ - -sub, -sup { - font-size: 75%; - line-height: 0; - position: relative; - vertical-align: baseline; -} - -sup { - top: -0.5em; -} - -sub { - bottom: -0.25em; -} - - -/* ============================================================================= - Lists - ========================================================================== */ - -ul, -ol { - margin: 1em 0; - padding: 0 0 0 40px; -} - -dd { - margin: 0 0 0 40px; -} - -nav ul, -nav ol { - list-style: none; - list-style-image: none; -} - - -/* ============================================================================= - Embedded content - ========================================================================== */ - -/* - * 1. Removes border when inside 'a' element in IE6/7/8/9 - * 2. Improves image quality when scaled in IE7 - * code.flickr.com/blog/2008/11/12/on-ui-quality-the-little-things-client-side-image-resizing/ - */ - -img { - border: 0; /* 1 */ - -ms-interpolation-mode: bicubic; /* 2 */ -} - -/* - * Corrects overflow displayed oddly in IE9 - */ - -svg:not(:root) { - overflow: hidden; -} - - -/* ============================================================================= - Figures - ========================================================================== */ - -/* - * Addresses margin not present in IE6/7/8/9, S5, O11 - */ - -figure { - margin: 0; -} - - -/* ============================================================================= - Forms - ========================================================================== */ - -/* - * Corrects margin displayed oddly in IE6/7 - */ - -form { - margin: 0; -} - -/* - * Define consistent margin and padding - */ - -fieldset { - margin: 0 2px; - padding: 0.35em 0.625em 0.75em; -} - -/* - * 1. Corrects color not being inherited in IE6/7/8/9 - * 2. Corrects alignment displayed oddly in IE6/7 - */ - -legend { - border: 0; /* 1 */ - *margin-left: -7px; /* 2 */ -} - -/* - * 1. Corrects font size not being inherited in all browsers - * 2. Addresses margins set differently in IE6/7, F3/4, S5, Chrome - * 3. Improves appearance and consistency in all browsers - */ - -button, -input, -select, -textarea { - font-size: 100%; /* 1 */ - margin: 0; /* 2 */ - vertical-align: baseline; /* 3 */ - *vertical-align: middle; /* 3 */ -} - -/* - * 1. Addresses FF3/4 setting line-height using !important in the UA stylesheet - * 2. Corrects inner spacing displayed oddly in IE6/7 - */ - -button, -input { - line-height: normal; /* 1 */ - *overflow: visible; /* 2 */ -} - -/* - * Corrects overlap and whitespace issue for buttons and inputs in IE6/7 - * Known issue: reintroduces inner spacing - */ - -table button, -table input { - *overflow: auto; -} - -/* - * 1. Improves usability and consistency of cursor style between image-type 'input' and others - * 2. Corrects inability to style clickable 'input' types in iOS - */ - -button, -html input[type="button"], -input[type="reset"], -input[type="submit"] { - cursor: pointer; /* 1 */ - -webkit-appearance: button; /* 2 */ -} - -/* - * 1. Addresses box sizing set to content-box in IE8/9 - * 2. Addresses excess padding in IE8/9 - */ - -input[type="checkbox"], -input[type="radio"] { - box-sizing: border-box; /* 1 */ - padding: 0; /* 2 */ -} - -/* - * 1. Addresses appearance set to searchfield in S5, Chrome - * 2. Addresses box sizing set to border-box in S5, Chrome (include -moz to future-proof) - */ - -input[type="search"] { - -webkit-appearance: textfield; /* 1 */ - -moz-box-sizing: content-box; - -webkit-box-sizing: content-box; /* 2 */ - box-sizing: content-box; -} - -/* - * Corrects inner padding displayed oddly in S5, Chrome on OSX - */ - -input[type="search"]::-webkit-search-decoration { - -webkit-appearance: none; -} - -/* - * Corrects inner padding and border displayed oddly in FF3/4 - * www.sitepen.com/blog/2008/05/14/the-devils-in-the-details-fixing-dojos-toolbar-buttons/ - */ - -button::-moz-focus-inner, -input::-moz-focus-inner { - border: 0; - padding: 0; -} - -/* - * 1. Removes default vertical scrollbar in IE6/7/8/9 - * 2. Improves readability and alignment in all browsers - */ - -textarea { - overflow: auto; /* 1 */ - vertical-align: top; /* 2 */ -} - - -/* ============================================================================= - Tables - ========================================================================== */ - -/* - * Remove most spacing between table cells - */ - -table { - border-collapse: collapse; - border-spacing: 0; -} diff --git a/msgpack-idl-web/tests/HomeTest.hs b/msgpack-idl-web/tests/HomeTest.hs deleted file mode 100644 index 17c9e6d..0000000 --- a/msgpack-idl-web/tests/HomeTest.hs +++ /dev/null @@ -1,24 +0,0 @@ -module HomeTest - ( homeSpecs - ) where - -import Import -import Yesod.Test - -homeSpecs :: Specs -homeSpecs = - describe "These are some example tests" $ - it "loads the index and checks it looks right" $ do - get_ "/" - statusIs 200 - htmlAllContain "h1" "Hello" - - post "/" $ do - addNonce - fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference - byLabel "What's on the file?" "Some Content" - - statusIs 200 - htmlCount ".message" 1 - htmlAllContain ".message" "Some Content" - htmlAllContain ".message" "text/plain" diff --git a/msgpack-idl-web/tests/main.hs b/msgpack-idl-web/tests/main.hs deleted file mode 100644 index d475fe8..0000000 --- a/msgpack-idl-web/tests/main.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Main where - -import Import -import Settings -import Yesod.Logger (defaultDevelopmentLogger) -import Yesod.Default.Config -import Yesod.Test -import Application (makeFoundation) - -import HomeTest - -main :: IO a -main = do - conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra } - logger <- defaultDevelopmentLogger - foundation <- makeFoundation conf logger - app <- toWaiAppPlain foundation - runTests app (connPool foundation) homeSpecs diff --git a/msgpack-idl/LICENSE b/msgpack-idl/LICENSE deleted file mode 100644 index 6eba326..0000000 --- a/msgpack-idl/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c)2011, 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-idl/Language/MessagePack/IDL.hs b/msgpack-idl/Language/MessagePack/IDL.hs deleted file mode 100644 index 08c6784..0000000 --- a/msgpack-idl/Language/MessagePack/IDL.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Language.MessagePack.IDL ( - module Language.MessagePack.IDL.Syntax, - module Language.MessagePack.IDL.Parser, - module Language.MessagePack.IDL.CodeGen.Haskell, - ) where - -import Language.MessagePack.IDL.Syntax -import Language.MessagePack.IDL.Parser -import Language.MessagePack.IDL.CodeGen.Haskell diff --git a/msgpack-idl/Language/MessagePack/IDL/Check.hs b/msgpack-idl/Language/MessagePack/IDL/Check.hs deleted file mode 100644 index 3207365..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/Check.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Language.MessagePack.IDL.Check ( - check, - ) where - -import Language.MessagePack.IDL.Syntax - --- TODO: Implement it! -check :: Spec -> Bool -check _ = True diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs deleted file mode 100644 index 951e1a4..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs +++ /dev/null @@ -1,298 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Cpp ( - Config(..), - generate, - ) where - -import Data.Char -import Data.List -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import Text.Shakespeare.Text - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath - , configNameSpace :: String - , configPFICommon :: Bool - } - deriving (Show, Eq) - -generate:: Config -> Spec -> IO () -generate Config {..} spec = do - let name = takeBaseName configFilePath - once = map toUpper name - ns = LT.splitOn "::" $ LT.pack configNameSpace - - typeHeader - | configPFICommon = - [lt|#include <msgpack.hpp>|] - | otherwise = - [lt|#include <msgpack.hpp>|] - serverHeader - | configPFICommon = - [lt|#include <pficommon/network/mprpc.h> -#include <pficommon/lang/bind.h>|] - | otherwise = - [lt|#include <msgpack/rpc/server.h>|] - clientHeader - | configPFICommon = - [lt|#include <pficommon/network/mprpc.h>|] - | otherwise = - [lt|#include <msgpack/rpc/client.h>|] - - LT.writeFile (name ++ "_types.hpp") $ templ configFilePath ns once "TYPES" [lt| -#include <vector> -#include <map> -#include <string> -#include <stdexcept> -#include <stdint.h> -#{typeHeader} - -#{genNameSpace ns $ LT.concat $ map (genTypeDecl name) spec } -|] - - LT.writeFile (name ++ "_server.hpp") $ templ configFilePath (snoc ns "server") once "SERVER" [lt| -#include "#{name}_types.hpp" -#{serverHeader} - -#{genNameSpace (snoc ns "server") $ LT.concat $ map (genServer configPFICommon) spec} -|] - - LT.writeFile (name ++ "_client.hpp") $ templ configFilePath (snoc ns "client") once "CLIENT" [lt| -#include "#{name}_types.hpp" -#{clientHeader} - -#{genNameSpace (snoc ns "client") $ LT.concat $ map (genClient configPFICommon) spec} -|] - -genTypeDecl :: String -> Decl -> LT.Text -genTypeDecl _ MPMessage {..} = - genMsg msgName msgFields False - -genTypeDecl _ MPException {..} = - genMsg excName excFields True - -genTypeDecl _ MPType { .. } = - [lt| -typedef #{genType tyType} #{tyName}; -|] - -genTypeDecl _ _ = "" - -genMsg name flds isExc = - let fields = map f flds - fs = map (maybe undefined fldName) $ sortField flds - in [lt| -struct #{name}#{e} { -public: - - #{destructor} - MSGPACK_DEFINE(#{T.intercalate ", " fs}); -#{LT.concat fields} -}; -|] - where - e = if isExc then [lt| : public std::exception|] else "" - destructor = if isExc then [lt|~#{name}() throw() {} -|] else "" - - f Field {..} = [lt| - #{genType fldType} #{fldName};|] - -sortField flds = - flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> - find ((==ix). fldId) flds - -genServer :: Bool -> Decl -> LT.Text -genServer False MPService {..} = [lt| -template <class Impl> -class #{serviceName} : public msgpack::rpc::server::base { -public: - - void dispatch(msgpack::rpc::request req) { - try { - std::string method; - req.method().convert(&method); -#{LT.concat $ map genMethodDispatch serviceMethods} - } catch (const msgpack::type_error& e) { - req.error(msgpack::rpc::ARGUMENT_ERROR); - } catch (const std::exception& e) { - req.error(std::string(e.what())); - } - } -}; -|] - where - genMethodDispatch Function {..} = - -- TODO: FIX IT! - let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs in - let params = map g methodArgs in - case params of - [] -> [lt| - if (method == "#{methodName}") { - req.result<#{genRetType methodRetType} >(static_cast<Impl*>(this)->#{methodName}()); - return; - } -|] - _ -> [lt| - if (method == "#{methodName}") { - msgpack::type::tuple<#{LT.intercalate ", " typs} > params; - req.params().convert(¶ms); - req.result<#{genRetType methodRetType} >(static_cast<Impl*>(this)->#{methodName}(#{LT.intercalate ", " params})); - return; - } -|] - where - g fld = [lt|params.get<#{show $ fldId fld}>()|] - - genMethodDispatch _ = "" - -genServer True MPService {..} = [lt| -template <class Impl> -class #{serviceName} : public pfi::network::mprpc::rpc_server { -public: - #{serviceName}(double timeout_sec): rpc_server(timeout_sec) { -#{LT.concat $ map genSetMethod serviceMethods} - } -}; -|] - where - genSetMethod Function {..} = - let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs - sign = [lt|#{genRetType methodRetType}(#{LT.intercalate ", " typs})|] - phs = LT.concat $ [[lt|, pfi::lang::_#{show ix}|] | ix <- [1 .. length (typs)]] - in [lt| - rpc_server::add<#{sign} >("#{methodName}", pfi::lang::bind(&Impl::#{methodName}, static_cast<Impl*>(this)#{phs}));|] - - genSetMethod _ = "" - -genServer _ _ = "" - -genClient :: Bool -> Decl -> LT.Text -genClient False MPService {..} = [lt| -class #{serviceName} { -public: - #{serviceName}(const std::string &host, uint64_t port) - : c_(host, port) {} -#{LT.concat $ map genMethodCall serviceMethods} -private: - msgpack::rpc::client c_; -}; -|] - where - genMethodCall Function {..} = - let args = LT.intercalate ", " $ map arg methodArgs in - let vals = LT.concat $ map val methodArgs in - case methodRetType of - Nothing -> [lt| - void #{methodName}(#{args}) { - c_.call("#{methodName}"#{vals}); - } -|] - Just typ -> [lt| - #{genType typ} #{methodName}(#{args}) { - return c_.call("#{methodName}"#{vals}).get<#{genType typ} >(); - } -|] - where - arg Field {..} = [lt|#{genType fldType} #{fldName}|] - val Field {..} = [lt|, #{fldName}|] - - genMethodCall _ = "" - -genClient True MPService {..} = [lt| -class #{serviceName} : public pfi::network::mprpc::rpc_client { -public: - #{serviceName}(const std::string &host, uint64_t port, double timeout_sec) - : rpc_client(host, port, timeout_sec) {} -#{LT.concat $ map genMethodCall serviceMethods} -private: -}; -|] - where - genMethodCall Function {..} = - let typs = map (genRetType . maybe Nothing (\f -> Just (fldType f))) $ sortField methodArgs - sign = [lt|#{genRetType methodRetType}(#{LT.intercalate ", " typs})|] - args = LT.intercalate ", " $ map arg methodArgs - vals = LT.intercalate ", " $ map val methodArgs in - case methodRetType of - Nothing -> [lt| - void #{methodName}(#{args}) { - call<#{sign}>("#{methodName}")(#{vals}); - } -|] - Just t -> [lt| - #{genType t} #{methodName}(#{args}) { - return call<#{sign}>("#{methodName}")(#{vals}); - } -|] - where - arg Field {..} = [lt|#{genType fldType} #{fldName}|] - val Field {..} = [lt|#{fldName}|] - - genMethodCall _ = "" - -genClient _ _ = "" - -genType :: Type -> LT.Text -genType (TInt sign bits) = - let base = if sign then "int" else "uint" :: LT.Text in - [lt|#{base}#{show bits}_t|] -genType (TFloat False) = - [lt|float|] -genType (TFloat True) = - [lt|double|] -genType TBool = - [lt|bool|] -genType TRaw = - [lt|std::string|] -genType TString = - [lt|std::string|] -genType (TList typ) = - [lt|std::vector<#{genType typ} >|] -genType (TMap typ1 typ2) = - [lt|std::map<#{genType typ1}, #{genType typ2} >|] -genType (TUserDef className params) = - [lt|#{className}|] -genType (TTuple ts) = - -- TODO: FIX - foldr1 (\t1 t2 -> [lt|std::pair<#{t1}, #{t2} >|]) $ map genType ts -genType TObject = - [lt|msgpack::object|] - -genRetType :: Maybe Type -> LT.Text -genRetType Nothing = [lt|void|] -genRetType (Just t) = genType t - -templ :: FilePath -> [LT.Text] -> String -> String -> LT.Text -> LT.Text -templ filepath ns once name content = [lt| -// This file is auto-generated from #{filepath} -// *** DO NOT EDIT *** - -#ifndef #{namespace}_#{once}_#{name}_HPP_ -#define #{namespace}_#{once}_#{name}_HPP_ - -#{content} - -#endif // #{namespace}_#{once}_#{name}_HPP_ -|] where - namespace = LT.intercalate "_" $ map LT.toUpper ns - - -genNameSpace :: [LT.Text] -> LT.Text -> LT.Text -genNameSpace namespace content = f namespace - where - f [] = [lt|#{content}|] - f (n:ns) = [lt| -namespace #{n} { -#{f ns} -} // namespace #{n} -|] - -snoc xs x = xs ++ [x] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs deleted file mode 100644 index e2e8d5d..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Erlang ( - Config(..), - generate, - ) where - -import Data.Char -import Data.List -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import Text.Shakespeare.Text - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath - } - deriving (Show, Eq) - -generate:: Config -> Spec -> IO () -generate Config {..} spec = do - let name = takeBaseName configFilePath - once = map toUpper name - - headerFile = name ++ "_types.hrl" - - LT.writeFile (headerFile) $ templ configFilePath once "TYPES" [lt| --ifndef(#{once}). --define(#{once}, 1). - --type mp_string() :: binary(). - -#{LT.concat $ map (genTypeDecl name) spec } - --endif. -|] - - LT.writeFile (name ++ "_server.tmpl.erl") $ templ configFilePath once "SERVER" [lt| - --module(#{name}_server). --author('@msgpack-idl'). - --include("#{headerFile}"). - -#{LT.concat $ map genServer spec} -|] - - LT.writeFile (name ++ "_client.erl") [lt| -% This file is automatically generated by msgpack-idl. --module(#{name}_client). --author('@msgpack-idl'). - --include("#{headerFile}"). --export([connect/3, close/1]). - -#{LT.concat $ map genClient spec} -|] - -genTypeDecl :: String -> Decl -> LT.Text -genTypeDecl _ MPMessage {..} = - genMsg msgName msgFields False - -genTypeDecl _ MPException {..} = - genMsg excName excFields True - -genTypeDecl _ MPType { .. } = - [lt| --type #{tyName}() :: #{genType tyType}. -|] - -genTypeDecl _ _ = "" - -genMsg name flds isExc = - let fields = map f flds - in [lt| --type #{name}() :: [ - #{LT.intercalate "\n | " fields} - ]. % #{e} -|] - where - e = if isExc then [lt| (exception)|] else "" - f Field {..} = [lt|#{genType fldType} % #{fldName}|] - -sortField flds = - flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> - find ((==ix). fldId) flds - -makeExport i Function {..} = - let j = i + length methodArgs in - [lt|#{methodName}/#{show j}|] -makeExport _ _ = "" - - -genServer :: Decl -> LT.Text -genServer MPService {..} = [lt| - --export([#{LT.intercalate ", " $ map (makeExport 0) serviceMethods}]). - -#{LT.concat $ map genSetMethod serviceMethods} - -|] - where - genSetMethod Function {..} = - let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs - args = map f methodArgs - f Field {..} = [lt|#{capitalize0 fldName}|] - capitalize0 str = T.cons (toUpper $ T.head str) (T.tail str) - - in [lt| --spec #{methodName}(#{LT.intercalate ", " typs}) -> #{genRetType methodRetType}. -#{methodName}(#{LT.intercalate ", " args}) -> - Reply = <<"ok">>, % write your code here - Reply. -|] - genSetMethod _ = "" - -genServer _ = "" - -genClient :: Decl -> LT.Text -genClient MPService {..} = [lt| - --export([#{LT.intercalate ", " $ map (makeExport 1) serviceMethods}]). - --spec connect(inet:ip_address(), inet:port_number(), [proplists:property()]) -> {ok, pid()} | {error, any()}. -connect(Host,Port,Options)-> - msgpack_rpc_client:connect(tcp,Host,Port,Options). - --spec close(pid())-> ok. -close(Pid)-> - msgpack_rpc_client:close(Pid). - -#{LT.concat $ map genMethodCall serviceMethods} -|] - where - genMethodCall Function {..} = - let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs - args = map f methodArgs - f Field {..} = [lt|#{capitalize0 fldName}|] - capitalize0 str = T.cons (toUpper $ T.head str) (T.tail str) - in [lt| --spec #{methodName}(pid(), #{LT.intercalate ", " typs}) -> #{genRetType methodRetType}. -#{methodName}(Pid, #{LT.intercalate ", " args}) -> - msgpack_rpc_client:call(Pid, #{methodName}, [#{LT.intercalate ", " args}]). -|] - where - arg Field {..} = [lt|#{genType fldType} #{fldName}|] - val Field {..} = [lt|#{fldName}|] - - genMethodCall _ = "" - -genClient _ = "" - -genType :: Type -> LT.Text -genType (TInt sign bits) = - let base = if sign then "non_neg_integer" else "integer" :: LT.Text in - [lt|#{base}()|] -genType (TFloat _) = - [lt|float()|] -genType TBool = - [lt|boolean()|] -genType TRaw = - [lt|binary()|] -genType TString = - [lt|mp_string()|] -genType (TList typ) = - [lt|list(#{genType typ})|] -genType (TMap typ1 typ2) = - [lt|list({#{genType typ1}, #{genType typ2}})|] -genType (TUserDef className params) = - [lt|#{className}()|] -genType (TTuple ts) = - -- TODO: FIX - foldr1 (\t1 t2 -> [lt|{#{t1}, #{t2}}|]) $ map genType ts -genType TObject = - [lt|term()|] - -genRetType :: Maybe Type -> LT.Text -genRetType Nothing = [lt|void()|] -genRetType (Just t) = genType t - -templ :: FilePath -> String -> String -> LT.Text -> LT.Text -templ filepath once name content = [lt| -% This file is auto-generated from #{filepath} - -#{content}|] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Haskell.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Haskell.hs deleted file mode 100644 index 40fbff6..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Haskell.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Language.MessagePack.IDL.CodeGen.Haskell ( - Config(..), - generate, - ) where - -import Data.Char -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import Text.Shakespeare.Text - -import Language.MessagePack.IDL.Syntax as MP - -data Config - = Config - { configFilePath :: FilePath - } - -generate :: Config -> Spec -> IO () -generate Config {..} spec = do - LT.writeFile "Types.hs" [lt| -{-# LANGUAGE TemplateHaskell #-} - -module Types where - -import Data.Int -import Data.MessagePack -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Words -#{LT.concat $ map genTypeDecl spec} -|] - - LT.writeFile "Server.hs" [lt| -|] - - LT.writeFile "Client.hs" [lt| -module Server where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T - -import qualified Network.MessagePackRpc.Client as MP - -import Types -#{LT.concat $ map genClient spec} -|] - -genClient :: Decl -> LT.Text -genClient MPService {..} = - [lt| -newtype #{monadName} m a - = #{monadName} { un#{monadName} :: StateT () m a } - deriving (Monad, MonadIO, MonadTrans, MonadState ()) -#{LT.concat $ map genMethod serviceMethods} -|] - where - monadName = classize (serviceName) `mappend` "T" - genMethod Function {..} = - let ts = map (genType . fldType) methodArgs in - let typs = ts ++ [ [lt|#{monadName} (#{genRetType methodRetType})|] ] in - [lt| -#{methodize methodName} :: #{LT.intercalate " -> " typs} -#{methodize methodName} = MP.method "#{methodName}" -|] - genMethod f = error $ "unsupported: " ++ show f - -genClient _ = "" - -genTypeDecl :: Decl -> LT.Text -genTypeDecl MPMessage {..} = - let mems = LT.intercalate "\n , " $ map f msgFields in - [lt| -data #{dataName} - = #{dataName} - { #{mems} - } - deriving (Eq, Show) -deriveObject False ''#{dataName} -|] - where - dataName = classize msgName - f Field {..} = - let fname = uncapital dataName `mappend` (capital $ camelize fldName) in - [lt|#{fname} :: #{genType fldType}|] - -genTypeDecl _ = "" - -genType :: Type -> LT.Text -genType (TInt sign bits) = - let base = if sign then "Int" else "Word" :: T.Text in - [lt|#{base}#{show bits}|] -genType (TFloat False) = - [lt|Float|] -genType (TFloat True) = - [lt|Double|] -genType TBool = - [lt|Bool|] -genType TRaw = - [lt|ByteString|] -genType TString = - [lt|Text|] -genType (TList typ) = - [lt|[#{genType typ}]|] -genType (TMap typ1 typ2) = - [lt|Map (#{genType typ1}) (#{genType typ2})|] -genType (TTuple typs) = - [lt|(#{LT.intercalate ", " $ map genType typs})|] -genType (TUserDef name params) = - [lt|#{classize name}|] -genType (TObject) = - undefined - -genRetType :: Maybe Type -> LT.Text -genRetType Nothing = "()" -genRetType (Just t) = genType t - -classize :: T.Text -> T.Text -classize = capital . camelize - -methodize :: T.Text -> T.Text -methodize = uncapital . camelize - -camelize :: T.Text -> T.Text -camelize = T.concat . map capital . T.words . T.map ubToSpc where - ubToSpc '_' = ' ' - ubToSpc c = c - -capital :: T.Text -> T.Text -capital word = - (T.map toUpper $ T.take 1 word) `mappend` T.drop 1 word - -uncapital :: T.Text -> T.Text -uncapital word = - (T.map toLower $ T.take 1 word) `mappend` T.drop 1 word - -{- -genServer :: Spec -> IO Builder -genServer = undefined - -genClient :: Spec -> IO Builder -genClient spec = do - decs <- runQ $ genClient' spec - putStrLn $ pprint decs - undefined - -genClient' :: Spec -> Q [Dec] -genClient' spec = return . concat =<< mapM genDecl spec - -genDecl :: Decl -> Q [Dec] -genDecl (Message name super fields) = do - let clsName = mkName $ T.unpack name - con = recC clsName $ map genFld fields - d <- dataD (cxt []) clsName [] [con] [''Eq, ''Ord, ''Show] - return [d] - where - genFld (Field fid req typ fname _) = - varStrictType (mkName $ uncapital $ T.unpack name ++ capital (T.unpack fname)) (strictType notStrict $ genType typ) - -genDecl (Service name version meths) = do - return [] - -genDecl _ = do - d <- dataD (cxt []) (mkName "Ign") [] [] [] - return [d] - -genType :: MP.Type -> Q TH.Type -genType (TInt False 8 ) = conT ''Word8 -genType (TInt False 16) = conT ''Word16 -genType (TInt False 32) = conT ''Word32 -genType (TInt False 64) = conT ''Word64 -genType (TInt True 8 ) = conT ''Int8 -genType (TInt True 16) = conT ''Int16 -genType (TInt True 32) = conT ''Int32 -genType (TInt True 64) = conT ''Int64 - -genType (TFloat False) = conT ''Float -genType (TFloat True ) = conT ''Double - -genType TBool = conT ''Bool -genType TRaw = conT ''B.ByteString -genType TString = conT ''T.Text - -genType (TList typ) = - listT `appT` genType typ -genType (TMap kt vt) = - [t| M.Map $(genType kt) $(genType vt) |] - -genType (TClass name) = - conT $ mkName $ capital $ T.unpack name - -genType (TTuple typs) = - foldl appT (tupleT (length typs)) (map genType typs) - -capital (c:cs) = toUpper c : cs -capital cs = cs - -uncapital (c:cs) = toLower c : cs -uncapital cs = cs --} diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs deleted file mode 100644 index b92c0ed..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs +++ /dev/null @@ -1,349 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Java ( - Config(..), - generate, - ) where - -import Data.Char -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import System.Directory -import Text.Shakespeare.Text - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath - , configPackage :: String - } - deriving (Show, Eq) - -generate :: Config -> Spec -> IO() -generate config spec = do - let typeAlias = map genAlias $ filter isMPType spec - dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack $ configPackage config - - genTuple config - createDirectoryIfMissing True dirName - mapM_ (genClient typeAlias config) spec - mapM_ (genStruct typeAlias config) spec - mapM_ (genException typeAlias config) spec - -{-- - LT.writeFile (name ++ "Server.java") $ templ (configFilePath ++ configPackage ++"/server/")[lt| -import org.msgpack.rpc.Server; -package #{configPackage} - -#{LT.concat $ map genServer spec} -|] ---} - -genTuple :: Config -> IO() -genTuple Config {..} = do - LT.writeFile("Tuple.java") $ templ (configFilePath) [lt| -package #{configPackage}; -public class Tuple<T, U> { - public T a; - public U b; -}; -|] - -genImport :: FilePath -> Decl -> LT.Text -genImport packageName MPMessage {..} = - [lt|import #{packageName}.#{formatClassNameT msgName}; -|] -genImport _ _ = "" - -genStruct :: [(T.Text, Type)] -> Config -> Decl -> IO() -genStruct alias Config{..} MPMessage {..} = do - let params = if null msgParam then "" else [lt|<#{T.intercalate ", " msgParam}>|] - resolvedMsgFields = map (resolveFieldAlias alias) msgFields - hashMapImport | not $ null [() | TMap _ _ <- map fldType resolvedMsgFields] = [lt|import java.util.HashMap;|] - | otherwise = "" - arrayListImport | not $ null [() | TList _ <- map fldType resolvedMsgFields] = [lt|import java.util.ArrayList;|] - | otherwise = "" - dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack configPackage - fileName = dirName ++ "/" ++ (T.unpack $ formatClassNameT msgName) ++ ".java" - - LT.writeFile fileName $ templ configFilePath [lt| -package #{configPackage}; - -#{hashMapImport} -#{arrayListImport} -import org.msgpack.MessagePack; -import org.msgpack.annotation.Message; - -@Message -public class #{formatClassNameT msgName} #{params} { - -#{LT.concat $ map genDecl resolvedMsgFields} - public #{formatClassNameT msgName}() { - #{LT.concat $ map genInit resolvedMsgFields} - } -}; -|] -genStruct _ _ _ = return () - -resolveMethodAlias :: [(T.Text, Type)] -> Method -> Method -resolveMethodAlias alias Function {..} = Function methodInherit methodName (resolveRetTypeAlias alias methodRetType) (map (resolveFieldAlias alias) methodArgs) -resolveMethodAlias _ f = f - -resolveFieldAlias :: [(T.Text, Type)] -> Field -> Field -resolveFieldAlias alias Field {..} = Field fldId (resolveTypeAlias alias fldType) fldName fldDefault - -resolveTypeAlias :: [(T.Text, Type)] -> Type -> Type -resolveTypeAlias alias ty = let fixedAlias = resolveTypeAlias alias in - case ty of - TNullable t -> - TNullable $ fixedAlias t - TList t -> - TList $ fixedAlias t - TMap s t -> - TMap (fixedAlias s) (fixedAlias t) - TTuple ts -> - TTuple $ map fixedAlias ts - TUserDef className params -> - case lookup className alias of - Just resolvedType -> resolvedType - Nothing -> TUserDef className (map fixedAlias params) - _ -> ty - -resolveRetTypeAlias :: [(T.Text, Type)] -> Maybe Type -> Maybe Type -resolveRetTypeAlias alias Nothing = Nothing -resolveRetTypeAlias alias (Just t) = Just (resolveTypeAlias alias t) - -genInit :: Field -> LT.Text -genInit Field {..} = case fldDefault of - Nothing -> "" - Just defaultVal -> [lt| #{fldName} = #{genLiteral defaultVal};|] - -genDecl :: Field -> LT.Text -genDecl Field {..} = - [lt| public #{genType fldType} #{fldName}; -|] - -genException :: [(T.Text, Type)] -> Config -> Decl -> IO() -genException alias Config{..} MPException{..} = do - LT.writeFile ( (formatClassName $ T.unpack excName) ++ ".java") $ templ configFilePath [lt| -package #{configPackage}; - -import org.msgpack.MessagePack; -import org.msgpack.annotation.Message; - -@Message -public class #{formatClassNameT excName} #{params}{ -#{LT.concat $ map genDecl excFields} - public #{formatClassNameT excName}() { - #{LT.concat $ map genInit excFields} - } -}; -|] - where - params = if null excParam then "" else [lt|<#{T.intercalate ", " excParam}>|] - super = case excSuper of - Just x -> [st|extends #{x}|] - Nothing -> "" -genException _ _ _ = return () - -genClient :: [(T.Text, Type)] -> Config -> Decl -> IO() -genClient alias Config {..} MPService {..} = do - let resolvedServiceMethods = map (resolveMethodAlias alias) serviceMethods - hashMapImport | not $ null [() | Just (TMap _ _) <- map methodRetType resolvedServiceMethods ] = [lt|import java.util.HashMap;|] - | otherwise = "" - arrayListImport | not $ null [() | Just (TList _) <- map methodRetType resolvedServiceMethods] = [lt|import java.util.ArrayList;|] - | otherwise = "" - dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack configPackage - fileName = dirName ++ "/" ++ (T.unpack className) ++ ".java" - - LT.writeFile fileName $ templ configFilePath [lt| -package #{configPackage}; - -#{hashMapImport} -#{arrayListImport} -import org.msgpack.rpc.Client; -import org.msgpack.rpc.loop.EventLoop; - -public class #{className} { - public #{className}(String host, int port, double timeout_sec) throws Exception { - EventLoop loop = EventLoop.defaultEventLoop(); - c_ = new Client(host, port, loop); - iface_ = c_.proxy(RPCInterface.class); - } - - public static interface RPCInterface { -#{LT.concat $ map genSignature resolvedServiceMethods} - } - -#{LT.concat $ map genMethodCall resolvedServiceMethods} - private Client c_; - private RPCInterface iface_; -}; -|] - where - className = (formatClassNameT serviceName) `mappend` "Client" - genMethodCall Function {..} = - let args = T.intercalate ", " $ map genArgs' methodArgs - vals = T.intercalate ", " $ pack methodArgs genVal in - case methodRetType of - Nothing -> [lt| - public void #{methodName}(#{args}) { - iface_.#{methodName}(#{vals}); - } -|] - Just typ -> [lt| - public #{genType typ} #{methodName}(#{args}) { - return iface_.#{methodName}(#{vals}); - } -|] - genMethodCall _ = "" - -genClient _ _ _ = return () - -genSignature :: Method -> LT.Text -genSignature Function {..} = - [lt| #{genRetType methodRetType} #{methodName}(#{args}); -|] - where - args = (T.intercalate ", " $ map genArgs' methodArgs) -genSignature _ = "" - -genArgs :: Maybe Field -> T.Text -genArgs (Just field) = genArgs' field -genArgs Nothing = "" - -genArgs' :: Field -> T.Text -genArgs' Field {..} = [st|#{genType fldType} #{fldName}|] - -pack :: [Field] -> (Maybe Field -> T.Text) -> [T.Text] -pack fields converter= - let ixs = map (\f -> fldId f) fields - dic = zip ixs [0..] - m = maximum (-1 :ixs) - sortedIxs = [ lookup ix dic | ix <- [0..m]] :: [Maybe Int] in - map (\sIx -> case sIx of - Nothing -> converter Nothing - Just i -> converter $ Just (fields!!i) ) sortedIxs - -genVal :: Maybe Field -> T.Text -genVal Nothing = "null" -genVal (Just field) = fldName field - -formatClassNameT :: T.Text -> T.Text -formatClassNameT = T.pack . formatClassName . T.unpack - -formatClassName :: String -> String -formatClassName = concatMap (\(c:cs) -> toUpper c:cs) . words . map (\c -> if c=='_' then ' ' else c) - -genServer :: Decl -> LT.Text -genServer _ = "" - -genLiteral :: Literal -> LT.Text -genLiteral (LInt i) = [lt|#{show i}|] -genLiteral (LFloat d) = [lt|#{show d}|] -genLiteral (LBool b) = [lt|#{show b}|] -genLiteral LNull = [lt|null|] -genLiteral (LString s) = [lt|#{show s}|] - -associateBracket :: [LT.Text] -> LT.Text -associateBracket msgParam = - if null msgParam then "" else [lt|<#{LT.intercalate ", " msgParam}>|] - - -genType :: Type -> LT.Text -genType (TInt _ bits) = case bits of - 8 -> [lt|byte|] - 16 -> [lt|short|] - 32 -> [lt|int|] - 64 -> [lt|long|] - _ -> [lt|int|] -genType (TFloat False) = - [lt|float|] -genType (TFloat True) = - [lt|double|] -genType TBool = - [lt|boolean|] -genType TRaw = - [lt|String|] -genType TString = - [lt|String|] -genType (TList typ) = - [lt|ArrayList<#{genWrapperType typ} >|] -genType (TMap typ1 typ2) = - [lt|HashMap<#{genType typ1}, #{genType typ2} >|] -genType (TUserDef className params) = - [lt|#{formatClassNameT className} #{associateBracket $ map genType params}|] -genType (TTuple ts) = - -- TODO: FIX - foldr1 (\t1 t2 -> [lt|Tuple<#{t1}, #{t2} >|]) $ map genWrapperType ts -genType TObject = - [lt|org.msgpack.type.Value|] - -genRetType :: Maybe Type -> LT.Text -genRetType Nothing = [lt|void|] -genRetType (Just t) = genType t - -genTypeWithContext :: Spec -> Type -> LT.Text -genTypeWithContext spec t = case t of - (TUserDef className params) -> - case lookup className $ map genAlias $ filter isMPType spec of - Just x -> genType x - Nothing -> "" - otherwise -> genType t - -isMPType :: Decl -> Bool -isMPType MPType {..} = True -isMPType _ = False - -genAlias :: Decl -> (T.Text, Type) -genAlias MPType {..} = (tyName, tyType) -genAlias _ = ("", TBool) - -genTypeWithTypedef :: T.Text -> Decl -> Maybe Type -genTypeWithTypedef className MPType {..} = - if className == tyName then Just tyType else Nothing -genTypeWithTypedef className _ = Nothing - -genWrapperType :: Type -> LT.Text -genWrapperType (TInt _ bits) = case bits of - 8 -> [lt|Byte|] - 16 -> [lt|Short|] - 32 -> [lt|Integer|] - 64 -> [lt|Long|] - _ -> [lt|Integer|] -genWrapperType (TFloat False) = - [lt|Float|] -genWrapperType (TFloat True) = - [lt|Double|] -genWrapperType TBool = - [lt|Boolean|] -genWrapperType TRaw = - [lt|String|] -genWrapperType TString = - [lt|String|] -genWrapperType (TList typ) = - [lt|ArrayList<#{genWrapperType typ} >|] -genWrapperType (TMap typ1 typ2) = - [lt|HashMap<#{genWrapperType typ1}, #{genWrapperType typ2} >|] -genWrapperType (TUserDef className params) = - [lt|#{formatClassNameT className} #{associateBracket $ map genWrapperType params}|] -genWrapperType (TTuple ts) = - -- TODO: FIX - foldr1 (\t1 t2 -> [lt|Tuple<#{t1}, #{t2} >|]) $ map genWrapperType ts -genWrapperType TObject = - [lt|org.msgpack.type.Value|] -genWrapperType (TNullable typ) = - genWrapperType typ - -templ :: FilePath -> LT.Text -> LT.Text -templ filepath content = [lt| -// This file is auto-generated from #{filepath} -// *** DO NOT EDIT *** - -#{content} - -|] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Perl.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Perl.hs deleted file mode 100644 index 357ef5d..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Perl.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Perl ( - Config(..), - generate, - ) where - -import Data.Char -import Data.List -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import Text.Shakespeare.Text - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath - , configNameSpace :: String - } - deriving (Show, Eq) - -generate:: Config -> Spec -> IO () -generate Config {..} spec = do - let name = takeBaseName configFilePath - once = map toUpper name - ns = LT.splitOn "::" $ LT.pack configNameSpace - --- types - mapM_ writeType spec - --- clients - LT.writeFile (name ++ "_client.pm") [lt| -package #{name}_client; -use strict; -use warnings; -use AnyEvent::MPRPC::Client; -#{LT.concat $ map genClient spec} -|] - -writeType :: Decl -> IO () -writeType MPMessage {..} = - let fields = sortBy (\x y -> fldId x `compare` fldId y) msgFields - fieldNames = map fldName fields :: [T.Text] - packageName = msgName :: T.Text - in LT.writeFile (T.unpack packageName ++ ".pm") [lt|package #{LT.pack $ T.unpack packageName}; -sub new { - return bless { #{LT.concat $ map f fieldNames} }; -} - -1; -|] - where - f :: T.Text -> LT.Text - f name = LT.append (LT.pack $ T.unpack name) $ LT.pack " => \"\"," - -writeType MPException {..} = - let fields = sortBy (\x y -> fldId x `compare` fldId y) excFields - fieldNames = map fldName fields :: [T.Text] - packageName = excName :: T.Text - in LT.writeFile (T.unpack packageName ++ ".pm") [lt|package #{LT.pack $ T.unpack packageName}; -sub new { - return bless { #{LT.concat $ map f fieldNames} }; -} - -1; -|] - where - f :: T.Text -> LT.Text - f name = LT.append (LT.pack $ T.unpack name) $ LT.pack " => \"\",\n" - -writeType _ = return () - -genClient :: Decl -> LT.Text -genClient MPService {..} = [lt| -sub new { - my ($self, $host, $port) = @_; - my $client = AnyEvent::MPRPC::Client->new( - host => $host, - port => $port - ); - bless { client => $client }, $self; -}; - -sub bar { - my ($self, $lang, $xs) = @_; - $self->{'client'}->call(bar => [$xs, $lang])->recv; -}; - -1; -|] - -genClient _ = "" - -templ :: FilePath -> String -> String -> LT.Text -> LT.Text -templ filepath once name content = [lt| -// This file is auto-generated from #{filepath} -// *** DO NOT EDIT *** - -#{content} - -|] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Php.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Php.hs deleted file mode 100644 index 1c5bce6..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Php.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Php ( - Config(..), - generate, - ) where - -import Data.Char -import Data.List -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import Text.Shakespeare.Text -import Data.Monoid - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath - } - deriving (Show, Eq) - -generate:: Config -> Spec -> IO () -generate Config {..} spec = do - let name = takeBaseName configFilePath - once = map toUpper name - - LT.writeFile (name ++ "_types.php") $ templ configFilePath once "TYPES" [lt| -include_once 'Net/MessagePackRPC.php'; - -#{LT.concat $ map genTypeDecl spec} - -class ObjectDecoder { - public static $USER_DEFINED_CLASSES = array( - #{LT.concat $ map genClassName spec} - ); - public static function decodeToObject($ret_array, $type_array) { - if ($type_array == "") { - // do nothing - $ret = $ret_array; - } else if (in_array($type_array, self::$USER_DEFINED_CLASSES)) { - // array -> object - $ret = new $type_array(); - $ret_keys = array_keys((array)$ret); - for ($i = 0; $i < count($ret_keys); $i++) { - $ret->{$ret_keys[$i]} = $ret_array[$i]; - } - } else { - // dissolve array - if (is_array($type_array)) { - if (count($type_array) == 1) { - // if array - foreach ($type_array as $key => $type) { - foreach ($ret_array as $ret_key => $ret_value) { - $ret[$ret_key] = $this->decodeToObject($ret_value, $type); - } - } - } else { - // if tuple - $ret = array(); - $i = 0; - foreach ($type_array as $type) { - $ret[$i] = $this->decodeToObject($ret_array[$i], $type); - $i++; - } - } - } else { - // type error - return $ret_array; - } - } - return $ret; - } -} - -|] - - LT.writeFile (name ++ "_client.php") [lt| -<?php -include_once(dirname(__FILE__)."/#{name}_types.php"); - -#{LT.concat $ map genClient spec} -?> -|] - -genClassName :: Decl -> LT.Text -genClassName MPMessage {..} = - [lt| "#{msgName}", - |] -genClassName _ = "" - -genTypeDecl :: Decl -> LT.Text -genTypeDecl MPMessage {..} = - genMsg msgName msgFields False - -genTypeDecl MPException {..} = - genMsg excName excFields True - -genTypeDecl _ = "" - -genMsg name flds isExc = - let fields = map f flds - fs = map (maybe undefined fldName) $ sortField flds - in [lt| -class #{name}#{e} { - -#{LT.concat fields} -} -|] - where - e = if isExc then [lt| extends Exception|] else "" - - f Field {..} = [lt| public $#{fldName}; -|] - -sortField flds = - flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> - find ((==ix). fldId) flds - -genClient :: Decl -> LT.Text -genClient MPService {..} = [lt| -class #{serviceName} { - public function __construct($host, $port) { - $this->client = new MessagePackRPC_Client($host, $port); - } -#{LT.concat $ map genMethodCall serviceMethods} - private $client; -} -|] - where - genMethodCall Function {..} = - let args = LT.intercalate ", " $ map arg methodArgs in - let sortedArgs = LT.intercalate ", " $ map (maybe undefined arg) $ sortField methodArgs in - case methodRetType of - Nothing -> [lt| - public function #{methodName}(#{args}) { - $this->client->call("#{methodName}", array(#{sortedArgs})); - } -|] - Just typ -> [lt| - public function #{methodName}(#{args}) { - $ret = $this->client->call("#{methodName}", array(#{sortedArgs})); - $type_array = #{genTypeArray typ}; - return ObjectDecoder::decodeToObject($ret, $type_array); - } -|] - where - arg Field {..} = [lt|$#{fldName}|] - - genMethodCall _ = "" - -genClient _ = "" - -genTypeArray :: Type -> LT.Text -genTypeArray (TList typ) = - [lt|array(#{genTypeArray typ})|] -genTypeArray (TMap typ1 typ2) = - [lt|array(#{genTypeArray typ1} => #{genTypeArray typ2})|] -genTypeArray (TUserDef className params) = - [lt|"#{className}"|] -genTypeArray (TTuple ts) = - foldr1 (\t1 t2 -> [lt|array(#{t1}, #{t2})|]) $ map genTypeArray ts -genTypeArray _ = [lt|""|] - -genType :: Type -> LT.Text -genType (TUserDef className params) = - [lt|#{className}|] -genType _ = "" - -templ :: FilePath -> String -> String -> LT.Text -> LT.Text -templ filepath once name content = [lt| -// This file is auto-generated from #{filepath} -// *** DO NOT EDIT *** -<?php -#{content} -?> -|] - -snoc xs x = xs ++ [x] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Python.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Python.hs deleted file mode 100644 index 2e696b5..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Python.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Python ( - Config(..), - generate, - ) where - -import Data.List -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import Text.Shakespeare.Text -import System.Directory - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath } - deriving (Show, Eq) - -generate:: Config -> Spec -> IO () -generate Config {..} spec = do - createDirectoryIfMissing True (takeBaseName configFilePath); - setCurrentDirectory (takeBaseName configFilePath); - LT.writeFile "__init__.py" $ templ configFilePath [lt| -|] - LT.writeFile "types.py" $ templ configFilePath [lt| -import sys -import msgpack - -#{LT.concat $ map (genTypeDecl "") spec } -|] - - LT.writeFile "server.tmpl.py" $ templ configFilePath [lt| -import msgpackrpc -from types import * -# write your server here and change file name to server.py - -|] - - LT.writeFile "client.py" $ templ configFilePath [lt| -import msgpackrpc -from types import * - -#{LT.concat $ map (genClient) spec} -|] - -genTypeDecl :: String -> Decl -> LT.Text - -genTypeDecl _ MPType {..} = [lt| -class #{tyName}: - @staticmethod - def from_msgpack(arg): - return #{fromMsgpack tyType "arg"} -|] - -genTypeDecl _ MPMessage {..} = - genMsg msgName msgFields False - -genTypeDecl _ MPException {..} = - genMsg excName excFields True - -genTypeDecl _ _ = "" - -genMsg :: ToText a => a -> [Field] -> Bool -> LT.Text -genMsg name flds isExc = - let fs = zipWith (\ix -> maybe ("_UNUSED" `mappend` T.pack (show ix)) fldName) [0 .. ] (sortField flds) - in [lt| -class #{name}#{e}: - def __init__(self, #{LT.intercalate ", " $ map g fs}): -#{LT.concat $ map f flds} - def to_msgpack(self): - return (#{LT.concat $ map typ flds} - ) - - @staticmethod - def from_msgpack(arg): - return #{name}( - #{LT.intercalate ",\n " $ map make_arg flds}) -|] - - where - e = if isExc then [lt|(Exception)|] else "" - f Field {..} = [lt| self.#{fldName} = #{fldName} -|] - typ Field {..} = [lt| - self.#{fldName},|] - make_arg Field {..} = - let fldId_str = T.concat $ map T.pack ["arg[", (show fldId), "]"] in - [lt|#{fromMsgpack fldType fldId_str}|] - g str = [lt|#{str}|] - -sortField :: [Field] -> [Maybe Field] -sortField flds = - flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> - find ((==ix). fldId) flds - -genClient :: Decl -> LT.Text -genClient MPService {..} = [lt| -class #{serviceName}: - def __init__ (self, host, port): - address = msgpackrpc.Address(host, port) - self.client = msgpackrpc.Client(address) -#{LT.concat $ map genMethodCall serviceMethods} -|] - where - genMethodCall Function {..} = - let arg_list = zipWith (\ix -> maybe ("_UNUSED" `mappend` T.pack (show ix)) fldName) [0 .. ] $ sortField methodArgs - args = LT.concat $ map (\x -> [lt|, #{x}|]) arg_list - in - case methodRetType of - Nothing -> [lt| - def #{methodName} (self#{args}): - self.client.call('#{methodName}'#{args}) -|] - Just ts -> [lt| - def #{methodName} (self#{args}): - retval = self.client.call('#{methodName}'#{args}) - return #{fromMsgpack ts "retval"} -|] - - genMethodCall _ = "" - -genClient _ = "" - -sanitize :: Char -> Char -sanitize '[' = '_' -sanitize ']' = '_' -sanitize c = c - -fromMsgpack :: Type -> T.Text -> LT.Text -fromMsgpack (TNullable t) name = fromMsgpack t name -fromMsgpack (TInt _ _) name = [lt|#{name}|] -fromMsgpack (TFloat False) name = [lt|#{name}|] -fromMsgpack (TFloat True) name = [lt|#{name}|] -fromMsgpack TBool name = [lt|#{name}|] -fromMsgpack TRaw name = [lt|#{name}|] -fromMsgpack TString name = [lt|#{name}|] -fromMsgpack (TList typ) name = - let - varname = T.append (T.pack "elem_") (T.map sanitize name) in - [lt|[#{fromMsgpack typ varname} for #{varname} in #{name}]|] - -fromMsgpack (TMap typ1 typ2) name = - let - keyname = T.append (T.pack "k_" ) $ T.map sanitize name - valname = T.append (T.pack "v_" ) $ T.map sanitize name - in - [lt|{#{fromMsgpack typ1 keyname} : #{fromMsgpack typ2 valname} for #{keyname},#{valname} in #{name}.items()}|] - -fromMsgpack (TUserDef className _) name = [lt|#{className}.from_msgpack(#{name})|] - -fromMsgpack (TTuple ts) name = - let elems = map (f name) (zip [0..] ts) in - [lt| (#{LT.intercalate ", " elems}) |] - where - f :: T.Text -> (Integer, Type) -> LT.Text - f n (i, (TUserDef className _ )) = [lt|#{className}.from_msgpack(#{n}[#{show i}]) |] - f n (i, _) = [lt|#{n}[#{show i}]|] - -fromMsgpack TObject name = [lt|#{name}|] - -templ :: FilePath -> LT.Text -> LT.Text -templ filepath content = [lt| -# This file is auto-generated from #{filepath} -# *** DO NOT EDIT *** - -#{content} -|] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs deleted file mode 100644 index 4225d65..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} - -module Language.MessagePack.IDL.CodeGen.Ruby ( - Config(..), - generate, - ) where - -import Data.Char -import Data.List -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LT -import System.FilePath -import Text.Shakespeare.Text -import System.Directory - -import Language.MessagePack.IDL.Syntax - -data Config - = Config - { configFilePath :: FilePath - , configModule :: String - } - deriving (Show, Eq) - -generate:: Config -> Spec -> IO () -generate Config {..} spec = do - createDirectoryIfMissing True (takeBaseName configFilePath); - setCurrentDirectory (takeBaseName configFilePath); - let - mods = LT.splitOn "::" $ LT.pack configModule - - LT.writeFile "types.rb" $ templ configFilePath [lt| -require 'rubygems' -require 'msgpack/rpc' -#{genModule mods $ LT.concat $ map (genTypeDecl "") spec } -|] - - LT.writeFile ("client.rb") $ templ configFilePath [lt| -require 'rubygems' -require 'msgpack/rpc' -require File.join(File.dirname(__FILE__), 'types') - -#{genModule (snoc mods "Client") $ LT.concat $ map genClient spec}|] - -genTypeDecl :: String -> Decl -> LT.Text -genTypeDecl _ MPType {..} = [lt| -class #{capitalizeT tyName} - def #{capitalizeT tyName}.from_tuple(tuple) - #{fromTuple tyType "tuple"} - end - def to_tuple(o) - o - end -end -|] - -genTypeDecl _ MPMessage {..} = - genMsg msgName msgFields False - -genTypeDecl _ MPException {..} = - genMsg excName excFields True - -genTypeDecl _ _ = "" - -genMsg :: T.Text -> [Field] -> Bool -> LT.Text -genMsg name flds isExc = [lt| -class #{capitalizeT name}#{deriveError} - def initialize(#{T.intercalate ", " fs}) - #{LT.intercalate "\n " $ map makeSubst fs} - end - def to_tuple - [#{LT.intercalate ",\n " $ map make_tuple flds}] - end - def to_msgpack(out = '') - to_tuple.to_msgpack(out) - end - def #{capitalizeT name}.from_tuple(tuple) - #{capitalizeT name}.new( - #{LT.intercalate ",\n " $ map make_arg flds} - ) - end -#{indent 2 $ genAccessors sorted_flds} -end -|]-- #{indent 2 $ LT.concat writers} - where - sorted_flds = sortField flds - fs = map (maybe undefined fldName) sorted_flds --- afs = LT.intercalate ",\n " $ map make_tuple flds - make_tuple Field {..} = - [lt|#{toTuple True fldType fldName}|] - deriveError = if isExc then [lt| < StandardError|] else "" - make_arg Field {..} = - let fldIdstr = T.concat $ map T.pack ["tuple[", (show fldId), "]"] - in [lt|#{fromTuple fldType fldIdstr}|] - -makeSubst :: T.Text -> LT.Text -makeSubst fld = [lt| @#{fld} = #{fld} |] - -toTuple :: Bool -> Type -> T.Text -> LT.Text -toTuple _ (TTuple ts) name = - let elems = map (f name) (zip [0..] ts) in - [lt| [#{LT.concat elems}] |] - where - f :: T.Text -> (Integer, Type) -> LT.Text - f n (i, (TUserDef _fg _ )) = [lt|#{n}[#{show i}].to_tuple}, |] - f n (i, _) = [lt|#{n}[#{show i}], |] - -toTuple True t name = [lt|@#{toTuple False t name}|] -toTuple _ (TNullable t) name = [lt|#{toTuple False t name}|] -toTuple _ (TInt _ _) name = [lt|#{name}|] -toTuple _ (TFloat _) name = [lt|#{name}|] -toTuple _ TBool name = [lt|#{name}|] -toTuple _ TRaw name = [lt|#{name}|] -toTuple _ TString name = [lt|#{name}|] -toTuple _ (TList typ) name = [lt|#{name}.map {|x| #{toTuple False typ "x"}}|] -toTuple _ (TMap typ1 typ2) name = - [lt|#{name}.each_with_object({}) {|(k,v),h| h[#{toTuple False typ1 "k"}] = #{toTuple False typ2 "v"}}|] -toTuple _ (TUserDef _ _) name = [lt|#{name}.to_tuple|] - -toTuple _ _ _ = "" - -fromTuple :: Type -> T.Text -> LT.Text -fromTuple (TNullable t) name = [lt|#{fromTuple t name}|] -fromTuple (TInt _ _) name = [lt|#{name}|] -fromTuple (TFloat _) name = [lt|#{name}|] -fromTuple TBool name = [lt|#{name}|] -fromTuple TRaw name = [lt|#{name}|] -fromTuple TString name = [lt|#{name}|] -fromTuple (TList typ) name = - [lt|#{name}.map { |x| #{fromTuple typ "x"} }|] - -fromTuple (TMap typ1 typ2) name = - [lt|#{name}.each_with_object({}) {|(k,v),h| h[#{fromTuple typ1 "k"}] = #{fromTuple typ2 "v"} }|] - -fromTuple (TUserDef className _) name = [lt|#{capitalizeT className}.from_tuple(#{name})|] - -fromTuple (TTuple ts) name = - let elems = map (f name) (zip [0..] ts) in - [lt| [#{LT.intercalate ", " elems}] |] - where - f :: T.Text -> (Integer, Type) -> LT.Text - f n (i, (TUserDef className _ )) = [lt|#{capitalizeT className}.from_tuple(#{n}[#{show i}]) |] - f n (i, _) = [lt|#{n}[#{show i}] |] - -fromTuple (TObject) name = [lt|#{name}|] - -capitalizeT :: T.Text -> T.Text -capitalizeT a = T.cons (toUpper $ T.head a) (T.tail a) - -sortField :: [Field] -> [Maybe Field] -sortField flds = - flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> find ((==ix). fldId) flds - -indent :: Int -> LT.Text -> LT.Text -indent ind lines = indentedConcat ind $ LT.lines lines - -indentedConcat :: Int -> [LT.Text] -> LT.Text -indentedConcat ind lines = - LT.dropAround (== '\n') $ LT.unlines $ map (indentLine ind) lines - -indentLine :: Int -> LT.Text -> LT.Text -indentLine _ "" = "" -indentLine ind line = mappend (LT.pack $ replicate ind ' ') line - -{- -extractJust :: [Maybe a] -> [a] -extractJust [] = [] -extractJust (Nothing:xs) = extractJust xs -extractJust (Just v:xs) = v : extractJust xs --} - -data AccessorType = Read | ReadWrite deriving Eq - -getAccessorType :: Type -> AccessorType -getAccessorType TBool = Read -getAccessorType (TMap _ _) = Read -getAccessorType (TUserDef _ _) = Read -getAccessorType _ = ReadWrite - -genAccessors :: [Maybe Field] -> LT.Text -genAccessors [] = "" -genAccessors fs = [lt| -#{genAccessors' Read "attr_reader" fs}#{genAccessors' ReadWrite "attr_accessor" fs}|] - -genAccessors' :: AccessorType -> String -> [Maybe Field] -> LT.Text -genAccessors' at an flds = gen $ map (maybe undefined fldName) $ filter fldTypeEq flds - where - gen [] = "" - gen fs = [lt| -#{an} #{T.intercalate ", " $ map (mappend ":") fs}|] - - fldTypeEq (Just Field {..}) = at == getAccessorType fldType - fldTypeEq Nothing = False - - --- TODO: Check when val is not null with TNullable --- TODO: Write single precision value on TFloat False -{- -genAttrWriter :: Field -> LT.Text -genAttrWriter Field {..} = genAttrWriter' fldType fldName - -genAttrWriter' :: Type -> T.Text -> LT.Text - -genAttrWriter' TBool n = [lt| -def #{n}=(val) - @#{n} = val.to_b -end -|] - -genAttrWriter' (TMap kt vt) n = [lt| -def #{n}=(val) - @#{n} = {} - val.each do |k, v| -#{indent 4 $ convert "k" "newk" kt} -#{indent 4 $ convert "v" "newv" vt} - end -end -|] - where - convert from to (TUserDef t p) = - genConvertingType from to (TUserDef t p) - convert from to _ = [lt|#{to} = #{from}|] -genAttrWriter' (TUserDef name types) n = [lt| -def #{n}=(val) -#{indent 2 $ convert "val" atn (TUserDef name types)} -end -|] - where - atn = [lt|@#{n}|] - convert from to (TUserDef t p) = - genConvertingType from to (TUserDef t p) -genAttrWriter' _ _ = "" --} - - -genClient :: Decl -> LT.Text -genClient MPService {..} = [lt| -class #{capitalizeT serviceName} - def initialize(host, port) - @cli = MessagePack::RPC::Client.new(host, port) - end#{LT.concat $ map genMethodCall serviceMethods} -end -|] - where - genMethodCall Function {..} = [lt| - def #{methodName}(#{defArgs}) -#{indent 4 $ genConvertingType' callStr "v" methodRetType} - end|] - where - defArgs = T.intercalate ", " $ map fldName methodArgs - callStr = [lt|@cli.call(#{callArgs})|] - callArgs = mappend ":" $ T.intercalate ", " $ methodName : sortedArgNames - sortedArgNames = map (maybe undefined fldName) $ sortField methodArgs - -genClient _ = "" - -genConvertingType :: LT.Text -> LT.Text -> Type -> LT.Text -genConvertingType unpacked _ (TUserDef t _) = [lt| -#{capitalizeT t}.from_tuple(#{unpacked})|] -genConvertingType _ _ _ = "" - -genConvertingType' :: LT.Text -> LT.Text -> Maybe Type -> LT.Text -genConvertingType' unpacked v (Just (TUserDef t p)) = [lt| -#{genConvertingType unpacked v (TUserDef t p)} -|] -genConvertingType' unpacked _ _ = [lt|#{unpacked}|] - -templ :: FilePath -> LT.Text -> LT.Text -templ filepath content = [lt|# This file is auto-generated from #{filepath} -# *** DO NOT EDIT *** -#{content} -|] - -genModule :: [LT.Text] -> LT.Text -> LT.Text -genModule modules content = f modules - where - f [] = [lt|#{content}|] - f (n:ns) = [lt|module #{n} -#{f ns} -end|] - -snoc :: [a] -> a -> [a] -snoc xs x = xs ++ [x] diff --git a/msgpack-idl/Language/MessagePack/IDL/Internal.hs b/msgpack-idl/Language/MessagePack/IDL/Internal.hs deleted file mode 100644 index 474a9b9..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/Internal.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Language.MessagePack.IDL.Internal ( - withDirectory - ) where - -import Control.Exception -import System.Directory - -withDirectory :: FilePath -> IO a -> IO a -withDirectory dir m = do - createDirectoryIfMissing True dir - bracket - getCurrentDirectory - setCurrentDirectory - (\_ -> setCurrentDirectory dir >> m) diff --git a/msgpack-idl/Language/MessagePack/IDL/Parser.hs b/msgpack-idl/Language/MessagePack/IDL/Parser.hs deleted file mode 100644 index fd55715..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/Parser.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-} - -module Language.MessagePack.IDL.Parser ( - idl, - ) where - -import Data.Maybe -import qualified Data.Text as T -import Text.Peggy -import Text.Peggy.CodeGen.TH - -import Language.MessagePack.IDL.Syntax - -genDecs $(peggyFile "mpidl.peggy") diff --git a/msgpack-idl/Language/MessagePack/IDL/Syntax.hs b/msgpack-idl/Language/MessagePack/IDL/Syntax.hs deleted file mode 100644 index 1838a69..0000000 --- a/msgpack-idl/Language/MessagePack/IDL/Syntax.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Language.MessagePack.IDL.Syntax where - -import Data.Data -import qualified Data.Text as T - -type Spec = [Decl] - -data Decl - = MPMessage - { msgName :: T.Text - , msgParam :: [T.Text] - , msgFields :: [Field] - } - | MPException - { excName :: T.Text - , excParam :: [T.Text] - , excSuper :: Maybe T.Text - , excFields :: [Field] - } - | MPType - { tyName :: T.Text - , tyType :: Type - } - | MPEnum - { enumName :: T.Text - , enumMem :: [(Int, T.Text)] - } - | MPService - { serviceName :: T.Text - , serviceVersion :: Maybe Int - , serviceMethods :: [Method] - } - deriving (Eq, Show, Data, Typeable) - -data Field - = Field - { fldId :: Int - , fldType :: Type - , fldName :: T.Text - , fldDefault :: Maybe Literal - } - deriving (Eq, Show, Data, Typeable) - -data Method - = Function - { methodInherit :: Bool - , methodName :: T.Text - , methodRetType :: Maybe Type - , methodArgs :: [Field] - } - | InheritName T.Text - | InheritAll - deriving (Eq, Show, Data, Typeable) - -data Type - = TInt Bool Int -- signed? bits - | TFloat Bool -- double prec? - | TBool - | TRaw - | TString - | TNullable Type - | TList Type - | TMap Type Type - | TTuple [Type] - | TUserDef T.Text [Type] - | TObject - deriving (Eq, Show, Data, Typeable) - -data Literal - = LInt Int - | LFloat Double - | LBool Bool - | LNull - | LString T.Text - deriving (Eq, Show, Data, Typeable) diff --git a/msgpack-idl/README.md b/msgpack-idl/README.md deleted file mode 100644 index 332c7ff..0000000 --- a/msgpack-idl/README.md +++ /dev/null @@ -1,66 +0,0 @@ -IDL compiler for MessagePack RPC -================================ - -# Install - -~~~ {.bash} -$ cabal update -$ cabal install msgpack-idl -~~~ - -If you use ghc <= 7.0.x, you may need to specify template-haskell's version. - -~~~ {.bash} -$ cabal install msgpack-idl --constraint='template-haskell == 2.5.*' -~~~ - -# Usage - -~~~ -msgpack-rpc 0.1 - -config [OPTIONS] IDLFILE LANG -MessagePack RPC IDL Compiler - -Common flags: - -o --output=DIR Output directory - -? --help Display help message - -V --version Print version information -~~~ - -# Tutorial - -* Prepare/Write msgspec file - -~~~ -message UserInfo { - 1: int uid - 2: string name - 3: int? flags = 1 -} - -enum Sites { - 0: SiteA - 1: SiteB - 2: SiteC -} - -message LogInLog { - 1: UserInfo user - 2: Sites site -} - -service Foo { - bool login(1: Sites site, 2: UserInfo) -} -~~~ - -* execute msgspec command for generating client/server code - -~~~ {.bash} -$ mprpc foo.msgspec cpp -o cpp -$ ls cpp -client.hpp -server.hpp -types.hpp -~~~ diff --git a/msgpack-idl/Setup.hs b/msgpack-idl/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/msgpack-idl/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/msgpack-idl/Specification.md b/msgpack-idl/Specification.md deleted file mode 100644 index f4c7ae8..0000000 --- a/msgpack-idl/Specification.md +++ /dev/null @@ -1,160 +0,0 @@ -MessagePack IDL Specification -============================= - -# Syntax of Specification File - -~~~ -<spec> <- <message> - / <exception> - / <type-alias> - / <enum> - / <service> -~~~ - -## message - -~~~ -message <name> ['<' <type-param>, ... '>'] { - <field>* -} -~~~ - -## exception - -* Similar to message definition. -* It can throw as an exception. - -~~~ -exception <name> ['<' <type-param>, ... '>'] [< <exception-name>] { - <field>* -} -~~~ - -## type alias - -* no type-parameter - -~~~ -type <name> = <type> -~~~ - -## enum - -~~~ -enum <name> { - <enum-id>: <enum-name> - ... -} -~~~ - -## service - -* multiple services can be defind -* One server contains several services - -~~~ -service <name> [: <version>] { - <method> - ... -} -~~~ - -## field - -~~~ -<field> = <field-id> : <type> <field-name> [ = <literal>] -~~~ - -## method - -~~~ -inherit * # inherit all -inherit <name> # inherit specified method -inherit <type> <name> (<field>, ...) # inherit specified method and check type -<type> <name> (<field>, ...) # define new-method -~~~ - -# Types - -* Primitive types - - `void` - - `object` - - `bool` - - integral types - - `byte` / `short` / `int` / `long` - - `ubyte` / `ushort` / `uint` / `ulong` - - fractional types - - `float` - - `double` - - `raw` - - `string` - -* Compound types - - `list<type>` - - `map<type, type>` - - `tuple<type, ...>` - - `<type>?` - - nullable type - -* User-defined types - - `<class-name><type, ...>` - -# Literals - -* bool - - `true` - - `false` - -* integral - - `0`, `1`, `-1`, ... - -* fractional - - `3.14`, `.9`, `-1.23`, `1e9`, `2.23e-2` - -* string - - `"Hello, World!"`, `"\n\r\t\u1234"` # unicode string - -* nullable - - `null` - -# include other files - -~~~ -include "foo.idl" -~~~ - -# Protocol extensions - -## Request - -* `(type, msgid, method-name, param)` - - same as normal msgpack-rpc - - calls <method-name> method in newest version of default service - -* `(type, msgid, (method-name, service?, versoin?), param)` - - extension of msgpack-idl - - can specify service name and version - - service name and version can be omitted - - this make one server can serve multiple services - -## Response - -* `(type, msgid, error, result)` - - same as normal msgpack-rpc - -# Semantics - -* Field - - `field-id` specifies an index of serialized array - - default value specified by `literal` is used when it is omitted - - field type is nullable - - it's value is omitted, it becomes to null. - - otherwise, type error will be occured - -* Version - - server invokes only method matches exact same as specified version. - - `inherit` inherits - - same service - - less version - - has specified method - - largest version's method diff --git a/msgpack-idl/exec/main.hs b/msgpack-idl/exec/main.hs deleted file mode 100644 index e0bbaf5..0000000 --- a/msgpack-idl/exec/main.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards #-} - -import Data.Version -import System.Console.CmdArgs -import Text.Peggy - -import Language.MessagePack.IDL -import Language.MessagePack.IDL.Internal -import qualified Language.MessagePack.IDL.CodeGen.Haskell as Haskell -import qualified Language.MessagePack.IDL.CodeGen.Cpp as Cpp -import qualified Language.MessagePack.IDL.CodeGen.Ruby as Ruby -import qualified Language.MessagePack.IDL.CodeGen.Java as Java -import qualified Language.MessagePack.IDL.CodeGen.Php as Php -import qualified Language.MessagePack.IDL.CodeGen.Python as Python -import qualified Language.MessagePack.IDL.CodeGen.Perl as Perl -import qualified Language.MessagePack.IDL.CodeGen.Erlang as Erlang - -import Paths_msgpack_idl - -data MPIDL - = Haskell - { output_dir :: FilePath - , module_name :: String - , filepath :: FilePath - } - | Cpp - { output_dir :: FilePath - , namespace :: String - , pficommon :: Bool - , filepath :: FilePath } - | Ruby - { output_dir :: FilePath - , modules :: String - , filepath :: FilePath } - | Java - { output_dir :: FilePath - , package :: String - , filepath :: FilePath - } - | Php - { output_dir :: FilePath - , filepath :: FilePath - } - | Python - { output_dir :: FilePath - , filepath :: FilePath - } - | Perl - { output_dir :: FilePath - , namespace :: String - , filepath :: FilePath } - | Erlang - { output_dir :: FilePath - , filepath :: FilePath } - deriving (Show, Eq, Data, Typeable) - -main :: IO () -main = do - conf <- cmdArgs $ - modes [ Haskell - { output_dir = def - , module_name = "" - , filepath = def &= argPos 0 - } - , Cpp - { output_dir = def - , namespace = "msgpack" - , pficommon = False - , filepath = def &= argPos 0 - } - , Ruby - { output_dir = def - , modules = "MessagePack" - , filepath = def &= argPos 0 - } - , Java - { output_dir = def - , package = "msgpack" - , filepath = def &= argPos 0 - } - , Php - { output_dir = def - , filepath = def &= argPos 0 - } - , Python - { output_dir = def - , filepath = def &= argPos 0 - } - , Perl - { output_dir = def - , namespace = "msgpack" - , filepath = def &= argPos 0 - } - , Erlang - { output_dir = def - , filepath = def &= argPos 0 - } - ] - &= help "MessagePack RPC IDL Compiler" - &= summary ("mpidl " ++ showVersion version) - - compile conf - -compile :: MPIDL -> IO () -compile conf = do - espec <- parseFile idl (filepath conf) - case espec of - Left err -> do - print err - Right spec -> do - print spec - withDirectory (output_dir conf) $ do - case conf of - Cpp {..} -> do - Cpp.generate (Cpp.Config filepath namespace pficommon) spec - - Haskell {..} -> do - Haskell.generate (Haskell.Config filepath) spec - - Java {..} -> do - Java.generate (Java.Config filepath package) spec - - Perl {..} -> do - Perl.generate (Perl.Config filepath namespace) spec - - Php {..} -> do - Php.generate (Php.Config filepath) spec - - Python {..} -> do - Python.generate (Python.Config filepath) spec - - Ruby {..} -> do - Ruby.generate (Ruby.Config filepath modules) spec - - Erlang {..} -> do - Erlang.generate (Erlang.Config filepath) spec - diff --git a/msgpack-idl/mpidl.peggy b/msgpack-idl/mpidl.peggy deleted file mode 100644 index 0f13574..0000000 --- a/msgpack-idl/mpidl.peggy +++ /dev/null @@ -1,87 +0,0 @@ -idl :: Spec = decl* !. - -decl :: Decl - = "message" identifier typeParam "{" field* "}" - { MPMessage $1 $2 $3 } - / "exception" identifier typeParam ("<" identifier)? "{" field* "}" - { MPException $1 $2 $3 $4 } - / "type" identifier "=" ftype - { MPType $1 $2 } - / "enum" identifier "{" (integer ":" identifier)* "}" - { MPEnum $1 $2 } - / "service" identifier (":" integer)? "{" method* "}" - { MPService $1 $2 $3 } - -typeParam :: [T.Text] - = "<" (identifier, ",") ">" - / "" { [] } - -method :: Method - = "inherit" identifier { InheritName $1 } - / "inherit" "*" { InheritAll } - / "inherit"? rtype identifier "(" (field , ",") ")" - { Function (isJust $1) $3 $2 $4 } - -field :: Field - = integer ":" ftype identifier ("=" literal)? - { Field $1 $2 $3 $4 } - -ftype :: Type - = ftypeNN "?" { TNullable $1 } - / ftypeNN - -rtype :: Maybe Type - = "void" { Nothing } - / ftype { Just $1 } - -ftypeNN :: Type - = "byte" { TInt True 8 } - / "short" { TInt True 16 } - / "int" { TInt True 32 } - / "long" { TInt True 64 } - / "ubyte" { TInt False 8 } - / "ushort" { TInt False 16 } - / "uint" { TInt False 32 } - / "ulong" { TInt False 64 } - / "float" { TFloat False } - / "double" { TFloat True } - / "bool" { TBool } - / "raw" { TRaw } - / "string" { TString } - / "object" { TObject } - - / "list" "<" ftype ">" { TList $1 } - / "map" "<" ftype "," ftype ">" { TMap $1 $2 } - / "tuple" "<" (ftype , ",") ">" { TTuple $1 } - - / identifier ("<" (ftype , ",") ">")? - { TUserDef $1 (fromMaybe [] $2) } - -literal ::: Literal - = integer { LInt $1 } - / "true" { LBool True } - / "false" { LBool False } - / "null" { LNull } - / '\"' charLit* '\"' { LString $ T.pack $1 } - -charLit :: Char - = '\\' escChar - / ![\'\"] . - -escChar :: Char - = 'n' { '\n' } - / 'r' { '\r' } - / 't' { '\t' } - / '\\' { '\\' } - / '\"' { '\"' } - / '\'' { '\'' } - -integer ::: Int - = [0-9]+ { read $1 } - -identifier ::: T.Text - = [a-zA-Z_][a-zA-Z0-9_]* { T.pack ($1 : $2) } - -skip :: () = [ \r\n\t] { () } / comment -comment :: () = '#' _:(!'\n' . { () })* '\n' { () } -delimiter :: () = [()[\]{}<>;:,./?] { () } diff --git a/msgpack-idl/msgpack-idl.cabal b/msgpack-idl/msgpack-idl.cabal deleted file mode 100644 index c10ff3a..0000000 --- a/msgpack-idl/msgpack-idl.cabal +++ /dev/null @@ -1,68 +0,0 @@ -name: msgpack-idl -version: 0.2.1 -synopsis: An IDL Compiler for MessagePack -description: An IDL Compiler for MessagePack <http://msgpack.org/> -homepage: http://msgpack.org/ -license: BSD3 -license-file: LICENSE -author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> -copyright: Copyright (c) 2011, Hideyuki Tanaka -category: Language -stability: Experimental -cabal-version: >=1.8 -build-type: Simple - -extra-source-files: mpidl.peggy - -source-repository head - type: git - location: git://github.com/msgpack/msgpack-haskell.git - -library - build-depends: base == 4.* - , bytestring >= 0.9 - , text >= 0.11 - , shakespeare-text == 1.0.* - , blaze-builder == 0.3.* - , template-haskell >= 2.5 && < 2.9 - , containers >= 0.4 - , filepath >= 1.1 && < 1.4 - , directory - , msgpack == 0.7.* - , peggy == 0.3.* - - ghc-options: -Wall - - exposed-modules: Language.MessagePack.IDL - Language.MessagePack.IDL.Check - Language.MessagePack.IDL.CodeGen.Cpp - Language.MessagePack.IDL.CodeGen.Haskell - Language.MessagePack.IDL.CodeGen.Java - Language.MessagePack.IDL.CodeGen.Perl - Language.MessagePack.IDL.CodeGen.Php - Language.MessagePack.IDL.CodeGen.Python - Language.MessagePack.IDL.CodeGen.Ruby - Language.MessagePack.IDL.CodeGen.Erlang - Language.MessagePack.IDL.Internal - Language.MessagePack.IDL.Parser - Language.MessagePack.IDL.Syntax - -executable mpidl - hs-source-dirs: exec - main-is: main.hs - - build-depends: base == 4.* - , directory >= 1.0 - , cmdargs == 0.10.* - , peggy == 0.3.* - , msgpack-idl - -test-suite mpidl-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: test.hs - - build-depends: base == 4.* - , hspec >= 1.1 - , msgpack-idl diff --git a/msgpack-idl/test/TODO.txt b/msgpack-idl/test/TODO.txt deleted file mode 100644 index 93c7a6a..0000000 --- a/msgpack-idl/test/TODO.txt +++ /dev/null @@ -1,19 +0,0 @@ - -[ ] empty - [ ] message - [ ] exception - [ ] service - -[ ] swap order of - [ ] message - [ ] argument - -[ ] including support - -[ ] versioning - [ ] inherit - -[ ] type-check - [ ] Python - [ ] Ruby - [ ] (Java) diff --git a/msgpack-idl/test/idls/empty.idl b/msgpack-idl/test/idls/empty.idl deleted file mode 100644 index 9e89281..0000000 --- a/msgpack-idl/test/idls/empty.idl +++ /dev/null @@ -1,8 +0,0 @@ -message empty_message { -} - -exception empty_error { -} - -service empty_service { -} diff --git a/msgpack-idl/test/test.hs b/msgpack-idl/test/test.hs deleted file mode 100644 index 6372586..0000000 --- a/msgpack-idl/test/test.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test.Hspec.Monadic - -main :: IO () -main = hspecX $ do - describe "parser" $ do - it "can parse xxx..." $ do - pending - - describe "checker" $ do - it "can check xxx..." $ do - pending - - describe "generator" $ do - describe "haskell" $ do - it "can generate client" $ do - pending - it "can communicate reference server" $ do - pending From d0c65fe60891ea67a702bbe8e982afe4bda0825c Mon Sep 17 00:00:00 2001 From: iphydf <iphydf@users.noreply.github.com> Date: Tue, 6 Sep 2016 12:54:35 +0100 Subject: [PATCH 24/75] Import msgpack back from the hstox repo. - Add Generic implementation. - Generalise fromObject to Monad (instead of just Maybe). - Add many more tests. - Fix Maybe encoding. --- README.md | 8 +- msgpack-rpc/msgpack-rpc.cabal | 53 --- msgpack-rpc/network-msgpack-rpc.cabal | 51 +++ msgpack-rpc/src/Network/MessagePack/Client.hs | 52 +-- msgpack-rpc/src/Network/MessagePack/Server.hs | 72 ++-- .../MessagePack/ServerSpec.hs} | 25 +- msgpack-rpc/test/testsuite.hs | 1 + msgpack/data-msgpack.cabal | 59 ++++ msgpack/msgpack.cabal | 55 --- msgpack/src/Data/MessagePack.hs | 40 ++- msgpack/src/Data/MessagePack/Assoc.hs | 16 +- msgpack/src/Data/MessagePack/Class.hs | 250 ++++++++++++++ msgpack/src/Data/MessagePack/Derive.hs | 145 -------- msgpack/src/Data/MessagePack/Generic.hs | 126 +++++++ msgpack/src/Data/MessagePack/Get.hs | 48 +-- msgpack/src/Data/MessagePack/Object.hs | 268 +++------------ msgpack/src/Data/MessagePack/Put.hs | 45 ++- msgpack/src/Data/MessagePack/Result.hs | 35 ++ msgpack/test/Data/MessagePackSpec.hs | 320 ++++++++++++++++++ msgpack/test/test.hs | 64 ---- msgpack/test/testsuite.hs | 1 + 21 files changed, 1077 insertions(+), 657 deletions(-) delete mode 100644 msgpack-rpc/msgpack-rpc.cabal create mode 100644 msgpack-rpc/network-msgpack-rpc.cabal rename msgpack-rpc/test/{test.hs => Network/MessagePack/ServerSpec.hs} (69%) create mode 100644 msgpack-rpc/test/testsuite.hs create mode 100644 msgpack/data-msgpack.cabal delete mode 100644 msgpack/msgpack.cabal create mode 100644 msgpack/src/Data/MessagePack/Class.hs delete mode 100644 msgpack/src/Data/MessagePack/Derive.hs create mode 100644 msgpack/src/Data/MessagePack/Generic.hs create mode 100644 msgpack/src/Data/MessagePack/Result.hs create mode 100644 msgpack/test/Data/MessagePackSpec.hs delete mode 100644 msgpack/test/test.hs create mode 100644 msgpack/test/testsuite.hs diff --git a/README.md b/README.md index 6399329..1e0bdc3 100644 --- a/README.md +++ b/README.md @@ -14,13 +14,13 @@ Execute following instructions: ~~~ {.bash} $ cabal update -$ cabal install msgpack -$ cabal install msgpack-rpc +$ cabal install data-msgpack +$ cabal install network-msgpack-rpc ~~~ # Document There are Haddoc documents on Hackage Database. -* <http://hackage.haskell.org/package/msgpack> -* <http://hackage.haskell.org/package/msgpack-rpc> +* <http://hackage.haskell.org/package/data-msgpack> +* <http://hackage.haskell.org/package/network-msgpack-rpc> diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal deleted file mode 100644 index 0f55430..0000000 --- a/msgpack-rpc/msgpack-rpc.cabal +++ /dev/null @@ -1,53 +0,0 @@ -name: msgpack-rpc -version: 1.0.0 -synopsis: A MessagePack-RPC Implementation -description: A MessagePack-RPC Implementation <http://msgpack.org/> -homepage: http://msgpack.org/ -license: BSD3 -license-file: LICENSE -author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> -copyright: (c) 2010-2015, Hideyuki Tanaka -category: Network -stability: Experimental -cabal-version: >=1.10 -build-type: Simple - -source-repository head - type: git - location: git://github.com/msgpack/msgpack-haskell.git - -library - default-language: Haskell2010 - hs-source-dirs: src - - exposed-modules: Network.MessagePack.Server - Network.MessagePack.Client - - build-depends: base >=4.5 && <5 - , bytestring >=0.10 - , text >=1.2 - , network >=2.6 - , random >=1.1 - , mtl >=2.1 - , monad-control >=1.0 - , conduit >=1.2 - , conduit-extra >=1.1 - , binary-conduit >=1.2 - , exceptions >=0.8 - , binary >=0.7 - , msgpack >=1.0 - -test-suite msgpack-rpc-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: test.hs - - build-depends: base - , mtl - , network - , async >=2.0 - , tasty >=0.10 - , tasty-hunit >=0.9 - , msgpack-rpc diff --git a/msgpack-rpc/network-msgpack-rpc.cabal b/msgpack-rpc/network-msgpack-rpc.cabal new file mode 100644 index 0000000..2665041 --- /dev/null +++ b/msgpack-rpc/network-msgpack-rpc.cabal @@ -0,0 +1,51 @@ +name: network-msgpack-rpc +version: 0.0.1 +synopsis: A MessagePack-RPC Implementation +description: A MessagePack-RPC Implementation <http://msgpack.org/> +homepage: http://msgpack.org/ +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Iphigenia Df <iphydf@gmail.com> +copyright: Copyright (c) 2009-2016, Hideyuki Tanaka +category: Data +stability: Experimental +cabal-version: >= 1.10 +build-type: Simple + +source-repository head + type: git + location: https://github.com/TokTok/msgpack-haskell.git + +library + default-language: Haskell2010 + hs-source-dirs: + src + exposed-modules: + Network.MessagePack.Client + Network.MessagePack.Server + build-depends: + base < 5 + , binary + , binary-conduit + , bytestring + , conduit + , conduit-extra + , data-msgpack + , exceptions + , monad-control + , mtl + , network + +test-suite testsuite + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: testsuite.hs + build-depends: + base < 5 + , async + , hspec + , mtl + , network + , network-msgpack-rpc diff --git a/msgpack-rpc/src/Network/MessagePack/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs index f1caf99..378e34d 100644 --- a/msgpack-rpc/src/Network/MessagePack/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------- -- | @@ -22,37 +23,40 @@ -- > 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.MessagePack.Client ( +module Network.MessagePack.Client -- * MessagePack Client type - Client, execClient, + ( Client + , execClient -- * Call RPC method - call, + , call -- * RPC error - RpcError(..), + , RpcError (..) ) where -import Control.Applicative -import Control.Exception -import Control.Monad -import Control.Monad.Catch +import Control.Applicative (Applicative) +import Control.Exception (Exception) +import Control.Monad () +import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.State.Strict as CMS import Data.Binary as Binary import qualified Data.ByteString as S import Data.Conduit import qualified Data.Conduit.Binary as CB -import Data.Conduit.Network +import Data.Conduit.Network (appSink, appSource, + clientSettings, + runTCPClient) import Data.Conduit.Serialization.Binary import Data.MessagePack -import Data.Typeable -import System.IO +import qualified Data.MessagePack.Result as R +import Data.Typeable (Typeable) newtype Client a = ClientT { runClient :: StateT Connection IO a } @@ -73,9 +77,9 @@ execClient host port m = -- | RPC error type data RpcError - = ServerError Object -- ^ Server error - | ResultTypeError String -- ^ Result type mismatch - | ProtocolError String -- ^ Protocol error + = ServerError Object -- ^ Server error + | ResultTypeError String Object -- ^ Result type mismatch + | ProtocolError String -- ^ Protocol error deriving (Show, Eq, Ord, Typeable) instance Exception RpcError @@ -84,14 +88,16 @@ class RpcType r where rpcc :: String -> [Object] -> r instance MessagePack o => RpcType (Client o) where - rpcc m args = do - res <- rpcCall m (reverse args) + rpcc name args = do + res <- rpcCall name (reverse args) case fromObject res of - Just r -> return r - Nothing -> throwM $ ResultTypeError "type mismatch" + R.Success ok -> + return ok + R.Failure msg -> + throwM $ ResultTypeError msg res instance (MessagePack o, RpcType r) => RpcType (o -> r) where - rpcc m args arg = rpcc m (toObject arg:args) + rpcc name args arg = rpcc name (toObject arg : args) rpcCall :: String -> [Object] -> Client Object rpcCall methodName args = ClientT $ do @@ -107,13 +113,11 @@ rpcCall methodName args = ClientT $ do when (rtype /= (1 :: Int)) $ throwM $ ProtocolError $ - "invalid response type (expect 1, but got " ++ show rtype ++ ")" + "invalid response type (expect 1, but got " ++ show rtype ++ "): " ++ show res when (rmsgid /= msgid) $ throwM $ ProtocolError $ - "message id mismatch: expect " - ++ show msgid ++ ", but got " - ++ show rmsgid + "message id mismatch: expect " ++ show msgid ++ ", but got " ++ show rmsgid case fromObject rerror of Nothing -> throwM $ ServerError rerror diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs index ea294ef..fa48842 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------- -- | @@ -31,14 +32,18 @@ -- -------------------------------------------------------------------- -module Network.MessagePack.Server ( +module Network.MessagePack.Server -- * RPC method types - Method, MethodType(..), - ServerT(..), Server, + ( Method + , MethodType (..) + , ServerT (..) + , Server + -- * Build a method - method, + , method + -- * Start RPC server - serve, + , serve ) where import Control.Applicative @@ -54,6 +59,8 @@ import Data.Conduit.Serialization.Binary import Data.List import Data.MessagePack import Data.Typeable +import Network.Socket (SocketOption (ReuseAddr), + setSocketOption) -- ^ MessagePack RPC method data Method m @@ -92,6 +99,7 @@ instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) case fromObject x of Nothing -> throwM $ ServerError "argument type error" Just r -> toBody (f r) xs + toBody _ [] = error "messagepack-rpc methodtype instance toBody failed" -- | Build a method method :: MethodType m f @@ -101,33 +109,39 @@ method :: MethodType m f 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) +serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch 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 () +serve port methods = + runGeneralTCPServer settings $ + \ad -> + do (rsrc,_) <- appSource ad $$+ return () + (_ :: Either ParseError ()) <- + try $ processRequests rsrc (appSink ad) + return () where + settings = + setAfterBind + (\s -> + setSocketOption s ReuseAddr 1) + (serverSettings port "*") processRequests rsrc sink = do - (rsrc', res) <- rsrc $$++ do - obj <- sinkGet get - case fromObject obj of - Nothing -> throwM $ ServerError "invalid request" - Just 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) - + (rsrc',res) <- + rsrc $$++ + do obj <- sinkGet get + case fromObject obj of + Nothing -> throwM $ ServerError "invalid request" + Just req -> lift $ getResponse (req :: Request) + _ <- CB.sourceLbs (pack res) $$ sink + processRequests rsrc' sink + getResponse (rtype,msgid,name,args) = do + when (rtype /= 0) $ + throwM $ ServerError $ "request type is not 0, got " ++ show rtype + ret <- callMethod name 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 + case find ((== name) . methodName) methods of + Nothing -> + throwM $ ServerError $ "method '" ++ name ++ "' not found" + Just m -> methodBody m args diff --git a/msgpack-rpc/test/test.hs b/msgpack-rpc/test/Network/MessagePack/ServerSpec.hs similarity index 69% rename from msgpack-rpc/test/test.hs rename to msgpack-rpc/test/Network/MessagePack/ServerSpec.hs index 4aa11bf..2d81ee7 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/Network/MessagePack/ServerSpec.hs @@ -1,22 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} +module Network.MessagePack.ServerSpec where + +import Test.Hspec import Control.Concurrent import Control.Concurrent.Async import Control.Monad.Trans -import Test.Tasty -import Test.Tasty.HUnit - import Network (withSocketsDo) + import Network.MessagePack.Client import Network.MessagePack.Server port :: Int port = 5000 -main :: IO () -main = withSocketsDo $ defaultMain $ - testGroup "simple service" - [ testCase "test" $ server `race_` (threadDelay 1000 >> client) ] + +spec :: Spec +spec = + describe "simple service" $ + it "test" $ withSocketsDo $ + server `race_` (threadDelay 1000 >> client) + server :: IO () server = @@ -31,12 +35,13 @@ server = echo :: String -> Server String echo s = return $ "***" ++ s ++ "***" + client :: IO () -client = execClient "localhost" port $ do +client = execClient "127.0.0.1" port $ do r1 <- add 123 456 - liftIO $ r1 @?= 123 + 456 + liftIO $ r1 `shouldBe` 123 + 456 r2 <- echo "hello" - liftIO $ r2 @?= "***hello***" + liftIO $ r2 `shouldBe` "***hello***" where add :: Int -> Int -> Client Int add = call "add" diff --git a/msgpack-rpc/test/testsuite.hs b/msgpack-rpc/test/testsuite.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/msgpack-rpc/test/testsuite.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/msgpack/data-msgpack.cabal b/msgpack/data-msgpack.cabal new file mode 100644 index 0000000..ea3dcca --- /dev/null +++ b/msgpack/data-msgpack.cabal @@ -0,0 +1,59 @@ +name: data-msgpack +version: 0.0.2 +synopsis: A Haskell implementation of MessagePack +description: A Haskell implementation of MessagePack <http://msgpack.org/> +homepage: http://msgpack.org/ +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Iphigenia Df <iphydf@gmail.com> +copyright: Copyright (c) 2009-2016, Hideyuki Tanaka +category: Data +stability: Experimental +cabal-version: >= 1.10 +build-type: Simple + +source-repository head + type: git + location: https://github.com/TokTok/msgpack-haskell.git + +library + default-language: Haskell2010 + hs-source-dirs: + src + exposed-modules: + Data.MessagePack + Data.MessagePack.Assoc + Data.MessagePack.Class + Data.MessagePack.Generic + Data.MessagePack.Get + Data.MessagePack.Object + Data.MessagePack.Put + Data.MessagePack.Result + build-depends: + base < 5 + , QuickCheck + , binary + , bytestring + , containers + , data-binary-ieee754 + , deepseq + , hashable + , text + , unordered-containers + +test-suite testsuite + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: testsuite.hs + build-depends: + base < 5 + , QuickCheck + , bytestring + , containers + , data-msgpack + , hashable + , hspec + , text + , unordered-containers diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal deleted file mode 100644 index 5b8b042..0000000 --- a/msgpack/msgpack.cabal +++ /dev/null @@ -1,55 +0,0 @@ -name: msgpack -version: 1.0.0 -synopsis: A Haskell implementation of MessagePack -description: A Haskell implementation of MessagePack <http://msgpack.org/> -homepage: http://msgpack.org/ -license: BSD3 -license-file: LICENSE -author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> -copyright: Copyright (c) 2009-2015, Hideyuki Tanaka -category: Data -stability: Experimental -cabal-version: >= 1.10 -build-type: Simple - -source-repository head - type: git - location: git://github.com/msgpack/msgpack-haskell.git - -library - default-language: Haskell2010 - hs-source-dirs: src - - exposed-modules: Data.MessagePack - Data.MessagePack.Assoc - Data.MessagePack.Object - Data.MessagePack.Get - Data.MessagePack.Put - - build-depends: base ==4.* - , mtl >=2.1 - , 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 - -test-suite msgpack-tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: test - - main-is: test.hs - - build-depends: base - , bytestring - , QuickCheck >=2.7 - , tasty >=0.10 - , tasty-quickcheck >=0.8 - , msgpack diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index 1819172..aae059d 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} -------------------------------------------------------------------- -- | -- Module : Data.MessagePack @@ -12,31 +13,38 @@ -- -------------------------------------------------------------------- -module Data.MessagePack ( +module Data.MessagePack -- * Simple interface to pack and unpack msgpack binary - pack, unpack, + ( pack + , unpack -- * Re-export modules -- $reexports - -- module X, - module Data.MessagePack.Assoc, - module Data.MessagePack.Get, - module Data.MessagePack.Object, - module Data.MessagePack.Put, + , module X ) where -import Data.Binary -import qualified Data.ByteString.Lazy as L +import Control.Applicative (Applicative) +import Control.Monad ((>=>)) +import Data.Binary (decodeOrFail, encode) +import qualified Data.ByteString.Lazy as L + +import Data.MessagePack.Assoc as X +import Data.MessagePack.Class as X +import Data.MessagePack.Generic () +import Data.MessagePack.Get as X +import Data.MessagePack.Object as X +import Data.MessagePack.Put as X -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 --- | Unpack MessagePack binary to a Haskell value. If it fails, it returns Nothing. -unpack :: MessagePack a => L.ByteString -> Maybe a -unpack = fromObject . decode +-- | Unpack MessagePack binary to a Haskell value. If it fails, it fails in the +-- Monad. In the Maybe monad, failure returns Nothing. +unpack :: (Applicative m, Monad m, MessagePack a) + => L.ByteString -> m a +unpack = eitherToM . decodeOrFail >=> fromObject + where + eitherToM (Left (_, _, msg)) = fail msg + eitherToM (Right (_, _, res)) = return res diff --git a/msgpack/src/Data/MessagePack/Assoc.hs b/msgpack/src/Data/MessagePack/Assoc.hs index 53f30c4..6f85741 100644 --- a/msgpack/src/Data/MessagePack/Assoc.hs +++ b/msgpack/src/Data/MessagePack/Assoc.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} -------------------------------------------------------------------- -- | @@ -15,15 +16,20 @@ -- -------------------------------------------------------------------- -module Data.MessagePack.Assoc ( - Assoc(..) +module Data.MessagePack.Assoc + ( Assoc (..) ) where -import Control.DeepSeq -import Data.Typeable +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) -- not defined for general Functor for performance reason. -- (ie. you would want to write custom instances for each type using specialized mapM-like functions) newtype Assoc a = Assoc { unAssoc :: a } - deriving (Show, Eq, Ord, Typeable, NFData) + deriving (Show, Read, Eq, Ord, Typeable, NFData) + +instance Arbitrary a => Arbitrary (Assoc a) where + arbitrary = Assoc <$> arbitrary diff --git a/msgpack/src/Data/MessagePack/Class.hs b/msgpack/src/Data/MessagePack/Class.hs new file mode 100644 index 0000000..427e566 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Class.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Object +-- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- MessagePack object definition +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Class + ( MessagePack (..) + , GMessagePack (..) + ) where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Arrow ((***)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Word (Word, Word16, Word32, Word64, Word8) +import GHC.Generics + +import Data.MessagePack.Assoc +import Data.MessagePack.Object + + +-- Generic serialisation. + +class GMessagePack f where + gToObject :: f a -> Object + gFromObject :: (Applicative m, Monad m) => Object -> m (f a) + + +class MessagePack a where + toObject :: a -> Object + fromObject :: (Applicative m, Monad m) => Object -> m a + + default toObject :: (Generic a, GMessagePack (Rep a)) + => a -> Object + toObject = genericToObject + default fromObject :: ( Applicative m, Monad m + , Generic a, GMessagePack (Rep a)) + => Object -> m a + fromObject = genericFromObject + + +genericToObject :: (Generic a, GMessagePack (Rep a)) + => a -> Object +genericToObject = gToObject . from + +genericFromObject :: ( Applicative m, Monad m + , Generic a, GMessagePack (Rep a)) + => Object -> m a +genericFromObject x = to <$> gFromObject x + + +-- Instances for integral types (Int etc.). + +toInt :: Integral a => a -> Int64 +toInt = fromIntegral + +fromInt :: Integral a => Int64 -> a +fromInt = fromIntegral + +instance MessagePack Int64 where + toObject = ObjectInt + fromObject = \case + ObjectInt n -> return n + _ -> fail "invalid encoding for integer type" + +instance MessagePack Int where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Int32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } + +instance MessagePack Word where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word8 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word16 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word32 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } +instance MessagePack Word64 where { toObject = toObject . toInt; fromObject o = fromInt <$> fromObject o } + + +-- Core instances. + +instance MessagePack Object where + toObject = id + fromObject = return + +instance MessagePack () where + toObject _ = ObjectArray [] + fromObject = \case + ObjectArray [] -> return () + _ -> fail "invalid encoding for ()" + +instance MessagePack Bool where + toObject = ObjectBool + fromObject = \case + ObjectBool b -> return b + _ -> fail "invalid encoding for Bool" + +instance MessagePack Float where + toObject = ObjectFloat + fromObject = \case + ObjectInt n -> return $ fromIntegral n + ObjectFloat f -> return f + ObjectDouble d -> return $ realToFrac d + _ -> fail "invalid encoding for Float" + +instance MessagePack Double where + toObject = ObjectDouble + fromObject = \case + ObjectInt n -> return $ fromIntegral n + ObjectFloat f -> return $ realToFrac f + ObjectDouble d -> return d + _ -> fail "invalid encoding for Double" + +-- Because of overlapping instance, this must be above [a]. +-- IncoherentInstances and TypeSynonymInstances are required for this to work. +instance MessagePack String where + toObject = toObject . T.pack + fromObject obj = T.unpack <$> fromObject obj + + +-- Instances for nullable types. + +instance MessagePack a => MessagePack (Maybe a) where + toObject = \case + Just a -> toObject a + Nothing -> ObjectNil + + fromObject = \case + ObjectNil -> return Nothing + obj -> Just <$> fromObject obj + + +-- Instances for binary and UTF-8 encoded string. + +instance MessagePack S.ByteString where + toObject = ObjectBin + fromObject = \case + ObjectBin r -> return r + _ -> fail "invalid encoding for ByteString" + +instance MessagePack L.ByteString where + toObject = ObjectBin . L.toStrict + fromObject obj = L.fromStrict <$> fromObject obj + +instance MessagePack T.Text where + toObject = ObjectStr + fromObject = \case + ObjectStr s -> return s + _ -> fail "invalid encoding for Text" + +instance MessagePack LT.Text where + toObject = toObject . LT.toStrict + fromObject obj = LT.fromStrict <$> fromObject obj + + +-- Instances for array-like data structures. + +instance MessagePack a => MessagePack [a] where + toObject = ObjectArray . map toObject + fromObject = \case + ObjectArray xs -> mapM fromObject xs + _ -> fail "invalid encoding for list" + + +-- Instances for map-like data structures. + +instance (MessagePack a, MessagePack b) => MessagePack (Assoc [(a, b)]) where + toObject (Assoc xs) = ObjectMap $ map (toObject *** toObject) xs + fromObject = \case + ObjectMap xs -> + Assoc <$> mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs + _ -> + fail "invalid encoding for Assoc" + +instance (MessagePack k, MessagePack v, Ord k) => MessagePack (Map.Map k v) where + toObject = toObject . Assoc . Map.toList + fromObject obj = Map.fromList . unAssoc <$> fromObject obj + +instance MessagePack v => MessagePack (IntMap.IntMap v) where + toObject = toObject . Assoc . IntMap.toList + fromObject obj = IntMap.fromList . unAssoc <$> fromObject obj + +instance (MessagePack k, MessagePack v, Hashable k, Eq k) => MessagePack (HashMap.HashMap k v) where + toObject = toObject . Assoc . HashMap.toList + fromObject obj = HashMap.fromList . unAssoc <$> fromObject obj + + +-- Instances for various tuple arities. + +instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where + toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] + fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where + toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] + fromObject (ObjectArray [a1, a2, a3]) = (,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4) => MessagePack (a1, a2, a3, a4) where + toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4] + fromObject (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5) => MessagePack (a1, a2, a3, a4, a5) where + toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5] + fromObject (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6) => MessagePack (a1, a2, a3, a4, a5, a6) where + toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7) => MessagePack (a1, a2, a3, a4, a5, a6, a7) where + toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 + fromObject _ = fail "invalid encoding for tuple" + +instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8, MessagePack a9) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8, a9) where + toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9] + fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 <*> fromObject a9 + fromObject _ = fail "invalid encoding for tuple" diff --git a/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..b45a4a1 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Generic.hs @@ -0,0 +1,126 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Data.MessagePack.Generic () where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Monad ((>=>)) +import Data.Bits (shiftR) +import Data.Word (Word64) +import GHC.Generics + +import Data.MessagePack.Class +import Data.MessagePack.Object (Object (..)) + + +instance GMessagePack U1 where + gToObject U1 = ObjectNil + gFromObject ObjectNil = return U1 + gFromObject _ = fail "invalid encoding for custom unit type" + +instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where + gToObject = toObject . prodToObject + gFromObject = fromObject >=> prodFromObject + +instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where + gToObject = sumToObject 0 size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + + gFromObject = \case + ObjectInt code -> checkSumFromObject0 size (fromIntegral code) + o -> fromObject o >>= uncurry (checkSumFromObject size) + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + +instance GMessagePack a => GMessagePack (M1 t c a) where + gToObject (M1 x) = gToObject x + gFromObject x = M1 <$> gFromObject x + +instance MessagePack a => GMessagePack (K1 i a) where + gToObject (K1 x) = toObject x + gFromObject o = K1 <$> fromObject o + + +-- Product type packing. + +class GProdPack f where + prodToObject :: f a -> [Object] + prodFromObject :: (Applicative m, Monad m) => [Object] -> m (f a) + + +instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where + prodToObject (a :*: b) = gToObject a : prodToObject b + prodFromObject (a:b) = (:*:) <$> gFromObject a <*> prodFromObject b + prodFromObject _ = fail "invalid encoding for product type" + +instance GMessagePack a => GProdPack (M1 t c a) where + prodToObject (M1 x) = [gToObject x] + prodFromObject [x] = M1 <$> gFromObject x + prodFromObject _ = fail "invalid encoding for product type" + + +-- Sum type packing. + +checkSumFromObject0 :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> m (f a) +checkSumFromObject0 size code + | code < size = sumFromObject code size ObjectNil + | otherwise = fail "invalid encoding for sum type" + + +checkSumFromObject :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a) +checkSumFromObject size code x + | code < size = sumFromObject code size x + | otherwise = fail "invalid encoding for sum type" + + +class GSumPack f where + sumToObject :: Word64 -> Word64 -> f a -> Object + sumFromObject :: (Applicative m, Monad m) => Word64 -> Word64 -> Object -> m (f a) + + +instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where + sumToObject code size = \case + L1 x -> sumToObject code sizeL x + R1 x -> sumToObject (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + sumFromObject code size x + | code < sizeL = L1 <$> sumFromObject code sizeL x + | otherwise = R1 <$> sumFromObject (code - sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + +instance GSumPack (C1 c U1) where + sumToObject code _ _ = toObject code + sumFromObject _ _ = gFromObject + + +instance GMessagePack a => GSumPack (C1 c a) where + sumToObject code _ x = toObject (code, gToObject x) + sumFromObject _ _ = gFromObject + + +-- Sum size. + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged { unTagged :: b } + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 2e36b9b..2c0454f 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} -------------------------------------------------------------------- -- | @@ -14,22 +15,31 @@ -- -------------------------------------------------------------------- -module Data.MessagePack.Get( - getNil, getBool, getInt, getFloat, getDouble, - getStr, getBin, getArray, getMap, getExt, +module Data.MessagePack.Get + ( getNil + , getBool + , getInt + , getFloat + , getDouble + , getStr + , getBin + , getArray + , getMap + , getExt ) where -import Control.Applicative -import Control.Monad -import Data.Binary -import Data.Binary.Get -import Data.Binary.IEEE754 -import Data.Bits +import Control.Applicative (empty, (<$), (<$>), (<*>), (<|>)) +import Control.Monad (guard, replicateM) +import Data.Binary (Get) +import Data.Binary.Get (getByteString, getWord16be, getWord32be, + getWord64be, getWord8) +import Data.Binary.IEEE754 (getFloat32be, getFloat64be) +import Data.Bits ((.&.)) import qualified Data.ByteString as S -import Data.Int +import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +import Data.Word (Word8) getNil :: Get () getNil = tag 0xC0 @@ -39,7 +49,7 @@ getBool = False <$ tag 0xC2 <|> True <$ tag 0xC3 -getInt :: Get Int +getInt :: Get Int64 getInt = getWord8 >>= \case c | c .&. 0x80 == 0x00 -> @@ -73,7 +83,7 @@ getStr = do _ -> empty bs <- getByteString len case T.decodeUtf8' bs of - Left _ -> empty + Left _ -> empty Right v -> return v getBin :: Get S.ByteString @@ -85,7 +95,7 @@ getBin = do _ -> empty getByteString len -getArray :: Get a -> Get (V.Vector a) +getArray :: Get a -> Get [a] getArray g = do len <- getWord8 >>= \case t | t .&. 0xF0 == 0x90 -> @@ -93,9 +103,9 @@ getArray g = do 0xDC -> fromIntegral <$> getWord16be 0xDD -> fromIntegral <$> getWord32be _ -> empty - V.replicateM len g + replicateM len g -getMap :: Get a -> Get b -> Get (V.Vector (a, b)) +getMap :: Get a -> Get b -> Get [(a, b)] getMap k v = do len <- getWord8 >>= \case t | t .&. 0xF0 == 0x80 -> @@ -103,7 +113,7 @@ getMap k v = do 0xDE -> fromIntegral <$> getWord16be 0xDF -> fromIntegral <$> getWord32be _ -> empty - V.replicateM len $ (,) <$> k <*> v + replicateM len $ (,) <$> k <*> v getExt :: Get (Word8, S.ByteString) getExt = do @@ -116,7 +126,7 @@ getExt = do 0xC7 -> fromIntegral <$> getWord8 0xC8 -> fromIntegral <$> getWord16be 0xC9 -> fromIntegral <$> getWord32be - _ -> empty + _ -> empty (,) <$> getWord8 <*> getByteString len getInt8 :: Get Int8 diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 824e65b..e00eab8 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -1,52 +1,28 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +module Data.MessagePack.Object (Object (..)) where + +import Control.Applicative ((<$), (<$>), (<*>), (<|>)) +import Control.DeepSeq (NFData (..)) +import Data.Binary (Binary (get, put), Get, Put) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int (Int64) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Typeable (Typeable) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Prelude hiding (putStr) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) +import qualified Test.QuickCheck.Gen as Gen --------------------------------------------------------------------- --- | --- Module : Data.MessagePack.Object --- Copyright : (c) Hideyuki Tanaka, 2009-2015 --- License : BSD3 --- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- MessagePack object definition --- --------------------------------------------------------------------- - -module Data.MessagePack.Object( - -- * MessagePack Object - Object(..), - - -- * MessagePack Serializable Types - MessagePack(..), - ) where - -import Control.Applicative -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.Lazy as LT -import Data.Typeable -import qualified Data.Vector as V - -import Data.MessagePack.Assoc import Data.MessagePack.Get import Data.MessagePack.Put -import Prelude hiding (putStr) -- | Object Representation of MessagePack data. data Object @@ -54,7 +30,7 @@ data Object -- ^ represents nil | ObjectBool !Bool -- ^ represents true or false - | ObjectInt {-# UNPACK #-} !Int + | ObjectInt {-# UNPACK #-} !Int64 -- ^ represents an integer | ObjectFloat {-# UNPACK #-} !Float -- ^ represents a floating point number @@ -64,20 +40,21 @@ data Object -- ^ extending Raw type represents a UTF-8 string | ObjectBin !S.ByteString -- ^ extending Raw type represents a byte array - | ObjectArray !(V.Vector Object) + | ObjectArray ![Object] -- ^ represents a sequence of objects - | ObjectMap !(V.Vector (Object, Object)) + | ObjectMap ![(Object, Object)] -- ^ represents key-value pairs of objects | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString -- ^ represents a tuple of an integer and a byte array where -- the integer represents type information and the byte array represents data. - deriving (Show, Eq, Ord, Typeable) + deriving (Read, Show, Eq, Ord, Typeable, Generic) + +instance NFData Object + +instance Binary Object where + get = getObject + put = putObject -instance NFData Object where - rnf obj = case obj of - ObjectArray a -> rnf a - ObjectMap m -> rnf m - _ -> () getObject :: Get Object getObject = @@ -105,170 +82,29 @@ putObject = \case ObjectMap m -> putMap putObject putObject m ObjectExt b r -> putExt b r -instance Binary Object where - get = getObject - put = putObject - -class MessagePack a where - toObject :: a -> Object - fromObject :: Object -> Maybe a - --- core instances - -instance MessagePack Object where - toObject = id - fromObject = Just - -instance MessagePack () where - toObject _ = ObjectNil - fromObject = \case - ObjectNil -> Just () - _ -> Nothing - -instance MessagePack Int where - toObject = ObjectInt - fromObject = \case - ObjectInt n -> Just n - _ -> Nothing - -instance MessagePack Bool where - toObject = ObjectBool - fromObject = \case - ObjectBool b -> Just b - _ -> Nothing - -instance MessagePack Float where - toObject = ObjectFloat - fromObject = \case - ObjectInt n -> Just $ fromIntegral n - ObjectFloat f -> Just f - ObjectDouble d -> Just $ realToFrac d - _ -> Nothing - -instance MessagePack Double where - toObject = ObjectDouble - fromObject = \case - ObjectInt n -> Just $ fromIntegral n - ObjectFloat f -> Just $ realToFrac f - ObjectDouble d -> Just d - _ -> Nothing - -instance MessagePack S.ByteString where - toObject = ObjectBin - fromObject = \case - ObjectBin r -> Just r - _ -> Nothing - --- Because of overlapping instance, this must be above [a] -instance MessagePack String where - toObject = toObject . 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 - -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 - -instance MessagePack a => MessagePack (Maybe a) where - toObject = \case - Just a -> toObject a - Nothing -> ObjectNil - - fromObject = \case - ObjectNil -> Just Nothing - obj -> fromObject obj - --- UTF8 string like - -instance MessagePack L.ByteString where - toObject = ObjectBin . L.toStrict - fromObject obj = L.fromStrict <$> fromObject obj - -instance MessagePack T.Text where - toObject = ObjectStr - fromObject = \case - ObjectStr s -> Just s - _ -> Nothing - -instance MessagePack LT.Text where - toObject = toObject . LT.toStrict - fromObject obj = LT.fromStrict <$> fromObject obj - --- array like - -instance MessagePack a => MessagePack [a] where - toObject = toObject . V.fromList - fromObject obj = V.toList <$> fromObject obj - --- map like - -instance (MessagePack k, MessagePack v) => MessagePack (Assoc [(k, v)]) where - toObject = toObject . Assoc . 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 - fromObject obj = Map.fromList . unAssoc <$> fromObject obj - -instance MessagePack v => MessagePack (IntMap.IntMap v) where - toObject = toObject . Assoc . IntMap.toList - fromObject obj = IntMap.fromList . unAssoc <$> fromObject obj - -instance (MessagePack k, MessagePack v, Hashable k, Eq k) => MessagePack (HashMap.HashMap k v) where - toObject = toObject . Assoc . HashMap.toList - fromObject obj = HashMap.fromList . unAssoc <$> fromObject obj - --- tuples - -instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where - toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] - fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2 - fromObject _ = Nothing - -instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where - toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] - fromObject (ObjectArray [a1, a2, a3]) = (,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 - fromObject _ = Nothing - -instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4) => MessagePack (a1, a2, a3, a4) where - toObject (a1, a2, a3, a4) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4] - fromObject (ObjectArray [a1, a2, a3, a4]) = (,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 - fromObject _ = Nothing -instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5) => MessagePack (a1, a2, a3, a4, a5) where - toObject (a1, a2, a3, a4, a5) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5] - fromObject (ObjectArray [a1, a2, a3, a4, a5]) = (,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 - fromObject _ = Nothing +instance Arbitrary Object where + arbitrary = Gen.sized $ \n -> Gen.oneof + [ return ObjectNil + , ObjectBool <$> arbitrary + , ObjectInt <$> arbitrary + , ObjectFloat <$> arbitrary + , ObjectDouble <$> arbitrary + , ObjectStr <$> arbitrary + , ObjectBin <$> arbitrary + , ObjectArray <$> Gen.resize (n `div` 2) arbitrary + , ObjectMap <$> Gen.resize (n `div` 4) arbitrary + , ObjectExt <$> arbitrary <*> arbitrary + ] -instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6) => MessagePack (a1, a2, a3, a4, a5, a6) where - toObject (a1, a2, a3, a4, a5, a6) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6] - fromObject (ObjectArray [a1, a2, a3, a4, a5, a6]) = (,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 - fromObject _ = Nothing +instance Arbitrary S.ByteString where + arbitrary = S.pack <$> arbitrary -instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7) => MessagePack (a1, a2, a3, a4, a5, a6, a7) where - toObject (a1, a2, a3, a4, a5, a6, a7) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7] - fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7]) = (,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 - fromObject _ = Nothing +instance Arbitrary L.ByteString where + arbitrary = L.pack <$> arbitrary -instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8) where - toObject (a1, a2, a3, a4, a5, a6, a7, a8) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8] - fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8]) = (,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 - fromObject _ = Nothing +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary -instance (MessagePack a1, MessagePack a2, MessagePack a3, MessagePack a4, MessagePack a5, MessagePack a6, MessagePack a7, MessagePack a8, MessagePack a9) => MessagePack (a1, a2, a3, a4, a5, a6, a7, a8, a9) where - toObject (a1, a2, a3, a4, a5, a6, a7, a8, a9) = ObjectArray [toObject a1, toObject a2, toObject a3, toObject a4, toObject a5, toObject a6, toObject a7, toObject a8, toObject a9] - fromObject (ObjectArray [a1, a2, a3, a4, a5, a6, a7, a8, a9]) = (,,,,,,,,) <$> fromObject a1 <*> fromObject a2 <*> fromObject a3 <*> fromObject a4 <*> fromObject a5 <*> fromObject a6 <*> fromObject a7 <*> fromObject a8 <*> fromObject a9 - fromObject _ = Nothing +instance Arbitrary LT.Text where + arbitrary = LT.pack <$> arbitrary diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 321e58d..bb5d1bb 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Trustworthy #-} -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Put @@ -12,19 +13,29 @@ -- -------------------------------------------------------------------- -module Data.MessagePack.Put ( - putNil, putBool, putInt, putFloat, putDouble, - putStr, putBin, putArray, putMap, putExt, +module Data.MessagePack.Put + ( putNil + , putBool + , putInt + , putFloat + , putDouble + , putStr + , putBin + , putArray + , putMap + , putExt ) where -import Data.Binary -import Data.Binary.IEEE754 -import Data.Binary.Put -import Data.Bits +import Data.Binary (Put) +import Data.Binary.IEEE754 (putFloat32be, putFloat64be) +import Data.Binary.Put (putByteString, putWord16be, putWord32be, + putWord64be, putWord8, putWord8) +import Data.Bits ((.|.)) import qualified Data.ByteString as S +import Data.Int (Int64) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +import Data.Word (Word8) import Prelude hiding (putStr) @@ -35,10 +46,10 @@ putBool :: Bool -> Put putBool False = putWord8 0xC2 putBool True = putWord8 0xC3 -putInt :: Int -> Put +putInt :: Int64 -> Put putInt n | -32 <= n && n <= 127 = - putWord8 $ fromIntegral n + putWord8 (fromIntegral n) | 0 <= n && n < 0x100 = putWord8 0xCC >> putWord8 (fromIntegral n) | 0 <= n && n < 0x10000 = @@ -58,7 +69,7 @@ putInt n putFloat :: Float -> Put putFloat f = do - putWord8 0xCB + putWord8 0xCA putFloat32be f putDouble :: Double -> Put @@ -91,27 +102,27 @@ putBin bs = do putWord8 0xC6 >> putWord32be (fromIntegral len) putByteString bs -putArray :: (a -> Put) -> V.Vector a -> Put +putArray :: (a -> Put) -> [a] -> Put putArray p xs = do - case V.length xs of + case 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 + mapM_ p xs -putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put +putMap :: (a -> Put) -> (b -> Put) -> [(a, b)] -> Put putMap p q xs = do - case V.length xs of + case 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 + mapM_ (\(a, b) -> p a >> q b) xs putExt :: Word8 -> S.ByteString -> Put putExt typ dat = do diff --git a/msgpack/src/Data/MessagePack/Result.hs b/msgpack/src/Data/MessagePack/Result.hs new file mode 100644 index 0000000..d2bc5d2 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Result.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE Safe #-} +module Data.MessagePack.Result where + +import Control.Applicative (Applicative, pure, (<$>), (<*>)) +import Test.QuickCheck.Arbitrary (Arbitrary (..)) +import qualified Test.QuickCheck.Gen as Gen + + +data Result a + = Success a + | Failure String + deriving (Read, Show, Eq, Functor) + + +instance Applicative Result where + pure = Success + + Success f <*> x = fmap f x + Failure msg <*> _ = Failure msg + + +instance Monad Result where + return = pure + fail = Failure + + Success x >>= f = f x + Failure msg >>= _ = Failure msg + + +instance Arbitrary a => Arbitrary (Result a) where + arbitrary = Gen.oneof + [ Success <$> arbitrary + , Failure <$> arbitrary + ] diff --git a/msgpack/test/Data/MessagePackSpec.hs b/msgpack/test/Data/MessagePackSpec.hs new file mode 100644 index 0000000..dc414ca --- /dev/null +++ b/msgpack/test/Data/MessagePackSpec.hs @@ -0,0 +1,320 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +module Data.MessagePackSpec where + +import Test.Hspec +import Test.QuickCheck +import qualified Test.QuickCheck.Gen as Gen + +import Control.Applicative ((<$>), (<*>)) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy as LT +import Data.Word (Word, Word16, Word32, Word64, + Word8) +import GHC.Generics (Generic) + +import Data.MessagePack +import qualified Data.MessagePack.Result as R + + +data Unit = Unit + deriving (Eq, Show, Generic) + +instance MessagePack Unit + + +data Record = Record Int Int Int + deriving (Eq, Show, Generic) + +instance MessagePack Record + + +data Foo + = Foo1 + | Foo2 Int + | Foo3 Int + | Foo4 Int + | Foo5 Int + | Foo6 { unFoo3 :: Int } + | Foo7 (Maybe Foo) + | Foo8 Int + | Foo9 Int Int + | Foo10 Int Int Int + deriving (Eq, Show, Generic) + +instance MessagePack Foo + +instance Arbitrary Foo where + arbitrary = Gen.oneof + [ return Foo1 + , Foo2 <$> arbitrary + , Foo3 <$> arbitrary + , Foo4 <$> arbitrary + , Foo5 <$> arbitrary + , Foo6 <$> arbitrary + , Foo7 <$> arbitrary + , Foo8 <$> arbitrary + , Foo9 <$> arbitrary <*> arbitrary + , Foo10 <$> arbitrary <*> arbitrary <*> arbitrary + ] + + +instance (Hashable k, Ord k, Eq k, Arbitrary k, Arbitrary v) + => Arbitrary (HashMap.HashMap k v) where + arbitrary = HashMap.fromList . Map.assocs <$> arbitrary + + +mid :: MessagePack a => a -> a +mid = Maybe.fromJust . unpack . pack + + +intMid :: Int64 -> Int64 +intMid = mid + + +coerce :: (MessagePack a, MessagePack b) => a -> Maybe b +coerce = unpack . pack + + +checkMessage :: Show a => R.Result a -> Expectation +checkMessage (R.Success res) = + expectationFailure $ "unexpected success: " ++ show res +checkMessage (R.Failure msg) = + msg `shouldContain` "invalid encoding for " + + +spec :: Spec +spec = do + describe "unpack" $ + it "does not throw exceptions on arbitrary data" $ + property $ \bs -> + case unpack bs of + Just "" -> return () :: IO () + _ -> return () :: IO () + + describe "failures" $ + it "should contain the same start of the failure message for all types" $ do + checkMessage (unpack (pack $ ObjectInt (-1)) :: R.Result Foo) + checkMessage (unpack (pack [ObjectInt (-1), ObjectInt 0]) :: R.Result Foo) + checkMessage (unpack (pack $ ObjectArray []) :: R.Result Record) + checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result Record) + checkMessage (unpack (pack "") :: R.Result Unit) + checkMessage (unpack (pack "") :: R.Result Record) + checkMessage (unpack (pack "") :: R.Result ()) + checkMessage (unpack (pack ()) :: R.Result Int) + checkMessage (unpack (pack ()) :: R.Result Bool) + checkMessage (unpack (pack ()) :: R.Result Float) + checkMessage (unpack (pack ()) :: R.Result Double) + checkMessage (unpack (pack ()) :: R.Result S.ByteString) + checkMessage (unpack (pack ()) :: R.Result LT.Text) + checkMessage (unpack (pack "") :: R.Result [String]) + checkMessage (unpack (pack "") :: R.Result (Assoc [(Int, Int)])) + checkMessage (unpack (pack ()) :: R.Result (Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int)) + checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int, Int)) + + describe "type coercion" $ do + it "bool<-int" $ + property $ \(a :: Int) -> coerce a `shouldBe` (Nothing :: Maybe Bool) + + it "int<-bool" $ + property $ \(a :: Bool) -> coerce a `shouldBe` (Nothing :: Maybe Int) + + it "float<-int" $ + property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Float) + it "float<-double" $ + property $ \(a :: Double) -> coerce a `shouldBe` Just (realToFrac a :: Float) + it "float<-string" $ + property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Float) + + it "double<-int" $ + property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Double) + it "double<-float" $ + property $ \(a :: Float) -> coerce a `shouldBe` Just (realToFrac a :: Double) + it "double<-string" $ + property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Double) + + it "bin<-string" $ + property $ \(a :: S.ByteString) -> coerce a `shouldBe` (Nothing :: Maybe String) + + it "string<-bin" $ + property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe S.ByteString) + + describe "Identity Properties" $ do + let sizes = [0xf, 0x10, 0x1f, 0x20, 0xff, 0x100, 0xffff, 0x10000] + + it "unit encoding" $ + Unit `shouldBe` mid Unit + + it "map encodings" $ do + let rt n = let a = IntMap.fromList [(x, -x) | x <- [0..n]] in a `shouldBe` mid a + mapM_ rt sizes + + it "list encodings" $ do + let rt n = let a = replicate n "hello" in a `shouldBe` mid a + mapM_ rt sizes + + it "string encodings" $ do + let rt n = let a = replicate n 'a' in a `shouldBe` mid a + mapM_ rt sizes + + it "bytestring encodings" $ do + let rt n = let a = S.pack $ replicate n 'a' in a `shouldBe` mid a + mapM_ rt sizes + + it "ext encodings" $ do + let rt n = let a = ObjectExt 0 $ S.pack $ replicate n 'a' in a `shouldBe` mid a + mapM_ rt [0..20] + mapM_ rt sizes + + it "int encodings" $ do + (-0x7fffffffffffffff) `shouldBe` intMid (-0x7fffffffffffffff) + (-0x80000000) `shouldBe` intMid (-0x80000000) + (-0x7fffffff) `shouldBe` intMid (-0x7fffffff) + (-0x8000) `shouldBe` intMid (-0x8000) + (-0x7fff) `shouldBe` intMid (-0x7fff) + (-1) `shouldBe` intMid (-1) + 0 `shouldBe` intMid 0 + 1 `shouldBe` intMid 1 + 0x7fff `shouldBe` intMid 0x7fff + 0x8000 `shouldBe` intMid 0x8000 + 0x7fffffff `shouldBe` intMid 0x7fffffff + 0x80000000 `shouldBe` intMid 0x80000000 + 0x7fffffffffffffff `shouldBe` intMid 0x7fffffffffffffff + + it "int" $ property $ \(a :: Int ) -> a `shouldBe` mid a + it "int8" $ property $ \(a :: Int8 ) -> a `shouldBe` mid a + it "int16" $ property $ \(a :: Int16 ) -> a `shouldBe` mid a + it "int32" $ property $ \(a :: Int32 ) -> a `shouldBe` mid a + it "int64" $ property $ \(a :: Int64 ) -> a `shouldBe` mid a + it "word" $ property $ \(a :: Word ) -> a `shouldBe` mid a + it "word8" $ property $ \(a :: Word8 ) -> a `shouldBe` mid a + it "word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a + it "word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a + it "word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a + + it "ext" $ + property $ \(n, a) -> ObjectExt n a `shouldBe` mid (ObjectExt n a) + it "nil" $ + property $ \(a :: ()) -> a `shouldBe` mid a + it "bool" $ + property $ \(a :: Bool) -> a `shouldBe` mid a + it "float" $ + property $ \(a :: Float) -> a `shouldBe` mid a + it "double" $ + property $ \(a :: Double) -> a `shouldBe` mid a + it "string" $ + property $ \(a :: String) -> a `shouldBe` mid a + it "bytestring" $ + property $ \(a :: S.ByteString) -> a `shouldBe` mid a + it "lazy-bytestring" $ + property $ \(a :: L.ByteString) -> a `shouldBe` mid a + it "lazy-text" $ + property $ \(a :: LT.Text) -> a `shouldBe` mid a + it "maybe int" $ + property $ \(a :: (Maybe Int)) -> a `shouldBe` mid a + it "[int]" $ + property $ \(a :: [Int]) -> a `shouldBe` mid a + it "[string]" $ + property $ \(a :: [String]) -> a `shouldBe` mid a + it "(int, int)" $ + property $ \(a :: (Int, Int)) -> a `shouldBe` mid a + it "(int, int, int)" $ + property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a + it "(int, int, int, int)" $ + property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(int, int, int, int, int)" $ + property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(int, int, int, int, int, int)" $ + property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(int, int, int, int, int, int, int)" $ + property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(int, int, int, int, int, int, int, int)" $ + property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(int, int, int, int, int, int, int, int, int)" $ + property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "[(int, double)]" $ + property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a + it "[(string, string)]" $ + property $ \(a :: [(String, String)]) -> a `shouldBe` mid a + it "Assoc [(string, int)]" $ + property $ \(a :: Assoc [(String, Int)]) -> a `shouldBe` mid a + it "Map String Int" $ + property $ \(a :: Map.Map String Int) -> a `shouldBe` mid a + it "IntMap Int" $ + property $ \(a :: IntMap.IntMap Int) -> a `shouldBe` mid a + it "HashMap String Int" $ + property $ \(a :: HashMap.HashMap String Int) -> a `shouldBe` mid a + it "maybe int" $ + property $ \(a :: Maybe Int) -> a `shouldBe` mid a + it "maybe nil" $ + property $ \(a :: Maybe ()) -> a `shouldBe` mid a + + -- FIXME: this test is also failing + -- + -- it should probably be decoded somewhat specially with ObjectExt ? + -- + -- it "maybe maybe int" $ + -- property $ \(a :: Maybe (Maybe Int)) -> a `shouldBe` mid a + -- + -- by looking at msgpack specification it looks like Haskells Maybe + -- type should be probably decoded with custom ObjectExt + -- + it "maybe bool" $ + property $ \(a :: Maybe Bool) -> a `shouldBe` mid a + it "maybe double" $ + property $ \(a :: Maybe Double) -> a `shouldBe` mid a + it "maybe string" $ + property $ \(a :: Maybe String) -> a `shouldBe` mid a + it "maybe bytestring" $ + property $ \(a :: Maybe S.ByteString) -> a `shouldBe` mid a + it "maybe lazy-bytestring" $ + property $ \(a :: Maybe L.ByteString) -> a `shouldBe` mid a + it "maybe [int]" $ + property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a + it "maybe [string]" $ + property $ \(a :: Maybe [String]) -> a `shouldBe` mid a + it "maybe (int, int)" $ + property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a + it "maybe (int, int, int)" $ + property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a + it "maybe (int, int, int, int)" $ + property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a + it "maybe (int, int, int, int, int)" $ + property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "maybe [(int, double)]" $ + property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a + it "maybe [(string, string)]" $ + property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a + it "maybe (Assoc [(string, int)])" $ + property $ \(a :: Maybe (Assoc [(String, Int)])) -> a `shouldBe` mid a + + it "generics" $ + property $ \(a :: Foo) -> a `shouldBe` mid a + it "arbitrary message" $ + property $ \(a :: Object) -> a `shouldBe` mid a + + describe "show" $ do + it "Foo" $ do + show (toObject Foo1) `shouldBe` "ObjectInt 0" + show (toObject $ Foo3 3) `shouldBe` "ObjectArray [ObjectInt 2,ObjectInt 3]" + show (toObject $ Foo9 3 5) `shouldBe` "ObjectArray [ObjectInt 8,ObjectArray [ObjectInt 3,ObjectInt 5]]" + show (toObject $ Foo10 3 5 7) `shouldBe` "ObjectArray [ObjectInt 9,ObjectArray [ObjectInt 3,ObjectInt 5,ObjectInt 7]]" + + it "Record" $ + show (toObject $ Record 3 5 7) `shouldBe` "ObjectArray [ObjectInt 3,ObjectInt 5,ObjectInt 7]" diff --git a/msgpack/test/test.hs b/msgpack/test/test.hs deleted file mode 100644 index f6d62f2..0000000 --- a/msgpack/test/test.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 - -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 - ] diff --git a/msgpack/test/testsuite.hs b/msgpack/test/testsuite.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/msgpack/test/testsuite.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From 34536ad372c6b4ec877827638e320127edef6cd2 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 08:23:13 +0100 Subject: [PATCH 25/75] Setup CI and some quickfixes --- .gitignore | 3 +++ .travis.yml | 31 +++++++++++++++++++++++++++++ cabal.project | 6 ++++++ msgpack-rpc/msgpack-rpc.cabal | 8 ++++---- msgpack/msgpack.cabal | 2 +- msgpack/src/Data/MessagePack/Get.hs | 12 +++++------ 6 files changed, 51 insertions(+), 11 deletions(-) create mode 100644 .travis.yml create mode 100644 cabal.project diff --git a/.gitignore b/.gitignore index 3ec9cb5..44bc0c0 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,6 @@ tmp/ /msgpack-aeson/cabal.sandbox.config /msgpack-aeson/.cabal-sandbox/ /.stack-work/ +/dist-newstyle/ +/.ghc.environment.* +/cabal.project.local diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..d456b56 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,31 @@ +# 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 +ghc: + - "8.6.4" + - "8.4.4" + - "8.2.2" + - "8.0.2" + - "7.10.3" + - "7.8.4" +# - "7.6.3" +# - "7.4.2" +# - "7.0.4" + +install: + - cabal --version + - ghc --version + +script: + - cabal v2-update + - cabal v2-build all +#- cabal check + - cabal v2-sdist all diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..3289f5e --- /dev/null +++ b/cabal.project @@ -0,0 +1,6 @@ +packages: + msgpack + msgpack-aeson + msgpack-rpc +-- msgpack-idl +-- msgpack-idl-web diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index 0f55430..2c6f7cf 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -30,10 +30,10 @@ library , network >=2.6 , random >=1.1 , mtl >=2.1 - , monad-control >=1.0 - , conduit >=1.2 - , conduit-extra >=1.1 - , binary-conduit >=1.2 + , monad-control >=1.0 && < 1.1 + , conduit >=1.2 && < 1.3 + , conduit-extra >=1.1 && < 1.3 + , binary-conduit >=1.2 && < 1.3 , exceptions >=0.8 , binary >=0.7 , msgpack >=1.0 diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 5b8b042..a7becbf 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -37,7 +37,7 @@ library , vector >=0.10 , blaze-builder >=0.4 , deepseq >=1.3 - , binary >=0.7 + , binary >=0.8.1.0 , data-binary-ieee754 test-suite msgpack-tests diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 2e36b9b..12e540f 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -22,7 +22,7 @@ module Data.MessagePack.Get( import Control.Applicative import Control.Monad import Data.Binary -import Data.Binary.Get +import Data.Binary.Get as Bin import Data.Binary.IEEE754 import Data.Bits import qualified Data.ByteString as S @@ -50,10 +50,10 @@ getInt = 0xCD -> fromIntegral <$> getWord16be 0xCE -> fromIntegral <$> getWord32be 0xCF -> fromIntegral <$> getWord64be - 0xD0 -> fromIntegral <$> getInt8 - 0xD1 -> fromIntegral <$> getInt16be - 0xD2 -> fromIntegral <$> getInt32be - 0xD3 -> fromIntegral <$> getInt64be + 0xD0 -> fromIntegral <$> Bin.getInt8 + 0xD1 -> fromIntegral <$> Bin.getInt16be + 0xD2 -> fromIntegral <$> Bin.getInt32be + 0xD3 -> fromIntegral <$> Bin.getInt64be _ -> empty getFloat :: Get Float @@ -73,7 +73,7 @@ getStr = do _ -> empty bs <- getByteString len case T.decodeUtf8' bs of - Left _ -> empty + Left _ -> empty Right v -> return v getBin :: Get S.ByteString From d200bcd8a28642c30d2c383eaab9e01f3c69ad7b Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 08:30:14 +0100 Subject: [PATCH 26/75] Tweak README --- README.md | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 6399329..41f4ed3 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ -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 an implementation of msgpack for Haskell. +This is an implementation of [MessagePack](https://en.wikipedia.org/wiki/MessagePack) for [Haskell](https://www.haskell.org). It containes: @@ -20,7 +20,9 @@ $ cabal install msgpack-rpc # Document -There are Haddoc documents on Hackage Database. +[Haddock](https://www.haskell.org/haddock) documentation can be found on Hackage: * <http://hackage.haskell.org/package/msgpack> * <http://hackage.haskell.org/package/msgpack-rpc> +* <http://hackage.haskell.org/package/msgpack-aeson> +* <http://hackage.haskell.org/package/msgpack-idl> From db978e0b72b37fd5b9e3dbe38df6c9e7dea1def5 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 08:48:47 +0100 Subject: [PATCH 27/75] Enable testsuites and validate lower bounds in CI This makes the package descriptions more accurate and also adds a "floor"-freeze file for CI so we don't accidentally introduce regressions which invalidate the lower bounds. --- .gitignore | 36 +++++++++----------- .travis.yml | 26 +++++++++------ cabal.project | 2 ++ cabal.project.floor-ghc-7.8.4 | 22 +++++++++++++ msgpack-aeson/msgpack-aeson.cabal | 51 +++++++++++++++++------------ msgpack-rpc/msgpack-rpc.cabal | 48 ++++++++++++++------------- msgpack-rpc/test/test.hs | 2 +- msgpack/msgpack.cabal | 49 +++++++++++++++------------ msgpack/src/Data/MessagePack/Get.hs | 11 ++++--- 9 files changed, 146 insertions(+), 101 deletions(-) create mode 100644 cabal.project.floor-ghc-7.8.4 diff --git a/.gitignore b/.gitignore index 44bc0c0..bb4e4ab 100644 --- a/.gitignore +++ b/.gitignore @@ -1,21 +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 -/msgpack-aeson/cabal.sandbox.config -/msgpack-aeson/.cabal-sandbox/ -/.stack-work/ -/dist-newstyle/ -/.ghc.environment.* -/cabal.project.local +*~ +*# +*.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 index d456b56..8e241f1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,23 +9,29 @@ cache: - $HOME/.cabal/store cabal: 2.4 -ghc: - - "8.6.4" - - "8.4.4" - - "8.2.2" - - "8.0.2" - - "7.10.3" - - "7.8.4" -# - "7.6.3" -# - "7.4.2" -# - "7.0.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/cabal.project b/cabal.project index 3289f5e..dc73f9d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,5 @@ +tests: True + packages: msgpack msgpack-aeson diff --git a/cabal.project.floor-ghc-7.8.4 b/cabal.project.floor-ghc-7.8.4 new file mode 100644 index 0000000..bb79495 --- /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.1.3.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.0.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/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index 4d8595e..1cf55eb 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -1,45 +1,54 @@ +cabal-version: 1.12 name: msgpack-aeson version: 0.1.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: tanaka.hideyuki@gmail.com +maintainer: Herbert Valerio Riedel <hvr@gnu.org> copyright: (c) 2015 Hideyuki Tanaka category: Data build-type: Simple --- extra-source-files: -cabal-version: >=1.10 + +source-repository head + type: git + location: http://github.com/msgpack/msgpack-haskell.git + subdir: msgpack-aeson library - exposed-modules: Data.MessagePack.Aeson - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 - , aeson >=0.8 - , bytestring >=0.10 - , msgpack >=1.0 - , scientific >=0.3 - , text >=1.2 - , unordered-containers >=0.2 - , vector >=0.10 - , deepseq hs-source-dirs: src + exposed-modules: Data.MessagePack.Aeson + + build-depends: base >= 4.7 && < 4.13 + , aeson >= 0.8.0.2 && < 0.12 + || >= 1.0 && < 1.5 + , bytestring >= 0.10.4 && < 0.11 + , msgpack >= 1.0.0 && < 1.1 + , scientific >= 0.3.2 && < 0.4 + , text >= 1.2 && < 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: base - , msgpack + build-depends: msgpack-aeson + -- inherited constraints via `msgpack-aeson` + , base , aeson - , msgpack-aeson - , tasty - , tasty-hunit + , msgpack + -- test-specific dependencies + , tasty == 1.2.* + , tasty-hunit == 0.10.* - hs-source-dirs: test default-language: Haskell2010 diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index 2c6f7cf..a0323ac 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -1,21 +1,23 @@ +cabal-version: 1.12 name: msgpack-rpc version: 1.0.0 + synopsis: A MessagePack-RPC Implementation description: A MessagePack-RPC Implementation <http://msgpack.org/> homepage: http://msgpack.org/ +bug-reports: https://github.com/msgpack/msgpack-haskell/issues license: BSD3 license-file: LICENSE author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> +maintainer: Herbert Valerio Riedel <hvr@gnu.org> copyright: (c) 2010-2015, Hideyuki Tanaka category: Network -stability: Experimental -cabal-version: >=1.10 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 @@ -24,19 +26,19 @@ library exposed-modules: Network.MessagePack.Server Network.MessagePack.Client - build-depends: base >=4.5 && <5 - , bytestring >=0.10 - , text >=1.2 - , network >=2.6 - , random >=1.1 - , mtl >=2.1 - , monad-control >=1.0 && < 1.1 - , conduit >=1.2 && < 1.3 - , conduit-extra >=1.1 && < 1.3 - , binary-conduit >=1.2 && < 1.3 - , exceptions >=0.8 - , binary >=0.7 - , msgpack >=1.0 + build-depends: base >= 4.5 && < 4.13 + , bytestring >= 0.10.4 && < 0.11 + , text >= 1.2 && < 1.3 + , network >= 2.6 && < 2.9 + || >= 3.0 && < 3.1 + , mtl >= 2.1.3.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.0.0 && < 1.1 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/test/test.hs b/msgpack-rpc/test/test.hs index 4aa11bf..be4f51b 100644 --- a/msgpack-rpc/test/test.hs +++ b/msgpack-rpc/test/test.hs @@ -6,9 +6,9 @@ import Control.Monad.Trans import Test.Tasty import Test.Tasty.HUnit -import Network (withSocketsDo) import Network.MessagePack.Client import Network.MessagePack.Server +import Network.Socket (withSocketsDo) port :: Int port = 5000 diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index a7becbf..bf7cf8c 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -1,24 +1,27 @@ +cabal-version: 1.12 name: msgpack version: 1.0.0 + synopsis: A Haskell implementation of MessagePack description: A Haskell implementation of MessagePack <http://msgpack.org/> homepage: http://msgpack.org/ +bug-reports: https://github.com/msgpack/msgpack-haskell/issues license: BSD3 license-file: LICENSE author: Hideyuki Tanaka -maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> +maintainer: Herbert Valerio Riedel <hvr@gnu.org> copyright: Copyright (c) 2009-2015, Hideyuki Tanaka category: Data -stability: Experimental -cabal-version: >= 1.10 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 library default-language: Haskell2010 + other-extensions: LambdaCase, OverloadedLists hs-source-dirs: src exposed-modules: Data.MessagePack @@ -27,18 +30,19 @@ library Data.MessagePack.Get Data.MessagePack.Put - build-depends: base ==4.* - , mtl >=2.1 - , 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.8.1.0 - , data-binary-ieee754 + build-depends: base >= 4.7 && < 4.13 + , mtl >= 2.1.3.1 && < 2.3 + , bytestring >= 0.10.4 && < 0.11 + , text >= 1.2 && < 1.3 + , containers >= 0.5.5 && < 0.7 + , unordered-containers >= 0.2.5 && < 0.3 + , hashable >= 1.1.2.4 && < 1.3 + , vector >= 0.10.11 && < 0.13 + , deepseq >= 1.3 && < 1.5 + , binary >= 0.7.1 && < 0.9 + , data-binary-ieee754 >= 0.4.4 && < 0.5 + + ghc-options: -Wall test-suite msgpack-tests type: exitcode-stdio-1.0 @@ -47,9 +51,12 @@ test-suite msgpack-tests main-is: test.hs - build-depends: base + build-depends: msgpack + -- inherited constraints via `msgpack` + , base , bytestring - , QuickCheck >=2.7 - , tasty >=0.10 - , tasty-quickcheck >=0.8 - , msgpack + -- test-specific dependencies + , async == 2.2.* + , tasty == 1.2.* + , tasty-quickcheck == 0.10.* + , QuickCheck == 2.12.* diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 12e540f..d048a5c 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -22,7 +22,8 @@ module Data.MessagePack.Get( import Control.Applicative import Control.Monad import Data.Binary -import Data.Binary.Get as Bin +import Data.Binary.Get (getByteString, getWord16be, getWord32be, + getWord64be) import Data.Binary.IEEE754 import Data.Bits import qualified Data.ByteString as S @@ -50,10 +51,10 @@ getInt = 0xCD -> fromIntegral <$> getWord16be 0xCE -> fromIntegral <$> getWord32be 0xCF -> fromIntegral <$> getWord64be - 0xD0 -> fromIntegral <$> Bin.getInt8 - 0xD1 -> fromIntegral <$> Bin.getInt16be - 0xD2 -> fromIntegral <$> Bin.getInt32be - 0xD3 -> fromIntegral <$> Bin.getInt64be + 0xD0 -> fromIntegral <$> getInt8 + 0xD1 -> fromIntegral <$> getInt16be + 0xD2 -> fromIntegral <$> getInt32be + 0xD3 -> fromIntegral <$> getInt64be _ -> empty getFloat :: Get Float From b1931a91bdd9c46d5e46afc8e606f1d60771cf04 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 08:54:26 +0100 Subject: [PATCH 28/75] Enable `Generic` instance for `Object` --- msgpack/src/Data/MessagePack/Object.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 824e65b..e867de5 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE LambdaCase #-} @@ -41,6 +42,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable import qualified Data.Vector as V +import GHC.Generics (Generic) import Data.MessagePack.Assoc import Data.MessagePack.Get @@ -71,7 +73,7 @@ data Object | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString -- ^ represents a tuple of an integer and a byte array where -- the integer represents type information and the byte array represents data. - deriving (Show, Eq, Ord, Typeable) + deriving (Show, Eq, Ord, Typeable, Generic) instance NFData Object where rnf obj = case obj of @@ -236,7 +238,7 @@ instance (MessagePack k, MessagePack v, Hashable k, Eq k) => MessagePack (HashMa instance (MessagePack a1, MessagePack a2) => MessagePack (a1, a2) where toObject (a1, a2) = ObjectArray [toObject a1, toObject a2] fromObject (ObjectArray [a1, a2]) = (,) <$> fromObject a1 <*> fromObject a2 - fromObject _ = Nothing + fromObject _ = Nothing instance (MessagePack a1, MessagePack a2, MessagePack a3) => MessagePack (a1, a2, a3) where toObject (a1, a2, a3) = ObjectArray [toObject a1, toObject a2, toObject a3] From dacf936e75601bec7216b7b13f9b918f983f1a5e Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:27:10 +0100 Subject: [PATCH 29/75] Update (c) headers --- msgpack/LICENSE | 6 ++++-- msgpack/msgpack.cabal | 19 ++++++++++++++++--- msgpack/src/Data/MessagePack.hs | 9 +++------ msgpack/src/Data/MessagePack/Get.hs | 12 +++++------- msgpack/src/Data/MessagePack/Object.hs | 7 ++----- msgpack/src/Data/MessagePack/Put.hs | 9 +++------ 6 files changed, 33 insertions(+), 29 deletions(-) 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 <copyright holder> BE LIABLE FOR ANY diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index bf7cf8c..4552cb5 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -1,16 +1,28 @@ cabal-version: 1.12 name: msgpack -version: 1.0.0 +version: 1.0.1.0 synopsis: A Haskell implementation of MessagePack -description: A Haskell implementation of MessagePack <http://msgpack.org/> +description: + A Haskell implementation of the <http://msgpack.org/ MessagePack> data interchange format. + MessagePack is a binary format which aims to be compact and supports encoding a superset of the <http://json.org/ JSON> data-model. + . + == Related Packages + . + A JSON adapter for the <https://hackage.haskell.org/package/aeson aeson> library is provided by the <https://hackage.haskell.org/package/msgpack-aeson msgpack-aeson> package. + . + The <http://hackage.haskell.org/package/msgpack-rpc msgpack-rpc> 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: Herbert Valerio Riedel <hvr@gnu.org> -copyright: Copyright (c) 2009-2015, Hideyuki Tanaka +copyright: Copyright (c) Hideyuki Tanaka 2009-2015, + (c) Herbert Valerio Riedel 2019 + category: Data build-type: Simple @@ -22,6 +34,7 @@ source-repository head library default-language: Haskell2010 other-extensions: LambdaCase, OverloadedLists + default-extensions: Trustworthy hs-source-dirs: src exposed-modules: Data.MessagePack diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index 1819172..339e3a8 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -1,14 +1,12 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable +-- Simple interface to encode\/decode to\/from the [MessagePack](https://msgpack.org/) format. -- --- Simple interface to pack and unpack MessagePack data. -- -------------------------------------------------------------------- @@ -18,7 +16,6 @@ module Data.MessagePack ( -- * Re-export modules -- $reexports - -- module X, module Data.MessagePack.Assoc, module Data.MessagePack.Get, module Data.MessagePack.Object, diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index d048a5c..383933e 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -3,19 +3,17 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Get --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- --- MessagePack Deserializer using @Data.Binary@ +-- MessagePack Deserializer using "Data.Binary" -- -------------------------------------------------------------------- module Data.MessagePack.Get( - getNil, getBool, getInt, getFloat, getDouble, + getNil, getBool, getFloat, getDouble, + getInt, getWord, getInt64, getWord64, getStr, getBin, getArray, getMap, getExt, ) where diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index b1ce937..226f20b 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -9,13 +9,10 @@ -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Object --- Copyright : (c) Hideyuki Tanaka, 2009-2015 +-- Copyright : © Hideyuki Tanaka 2009-2015 +-- , © Herbert Valerio Riedel 2019 -- License : BSD3 -- --- Maintainer: tanaka.hideyuki@gmail.com --- Stability : experimental --- Portability: portable --- -- MessagePack object definition -- -------------------------------------------------------------------- diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index bb27e8c..c3bb61d 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -1,14 +1,11 @@ -------------------------------------------------------------------- -- | -- 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". -- -------------------------------------------------------------------- From 026409a3d6d7f4710ca37871090776fad2606d36 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:31:42 +0100 Subject: [PATCH 30/75] Add `Read` instance to Object & Assoc --- msgpack/src/Data/MessagePack/Assoc.hs | 2 +- msgpack/src/Data/MessagePack/Object.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Assoc.hs b/msgpack/src/Data/MessagePack/Assoc.hs index 53f30c4..4d552fa 100644 --- a/msgpack/src/Data/MessagePack/Assoc.hs +++ b/msgpack/src/Data/MessagePack/Assoc.hs @@ -26,4 +26,4 @@ import Data.Typeable -- (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/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 226f20b..3ee8b4c 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -70,7 +70,7 @@ data Object | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString -- ^ represents a tuple of an integer and a byte array where -- the integer represents type information and the byte array represents data. - deriving (Show, Eq, Ord, Typeable, Generic) + deriving (Show, Read, Eq, Ord, Typeable, Generic) instance NFData Object where rnf obj = case obj of From f421c6309f1f9090c006d81091b252058cd37694 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:33:03 +0100 Subject: [PATCH 31/75] Silence SafeHaskell warning --- msgpack/msgpack.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 4552cb5..e4bd512 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -57,6 +57,9 @@ library ghc-options: -Wall + if impl(ghc >= 7.10) + ghc-options: -fno-warn-trustworthy-safe + test-suite msgpack-tests type: exitcode-stdio-1.0 default-language: Haskell2010 From 1836c9f314706e44dc67df685937429e2684592c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:34:37 +0100 Subject: [PATCH 32/75] Add `MessagePack` instance for `ShortByteString` --- msgpack/src/Data/MessagePack/Object.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 3ee8b4c..5c00117 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -31,7 +31,8 @@ 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.ByteString.Short as SBS +import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map @@ -196,6 +197,11 @@ instance MessagePack L.ByteString where toObject = ObjectBin . L.toStrict fromObject obj = L.fromStrict <$> fromObject obj +-- | @since 1.0.1.0 +instance MessagePack SBS.ShortByteString where + toObject = ObjectBin . SBS.fromShort + fromObject obj = SBS.toShort <$> fromObject obj + instance MessagePack T.Text where toObject = ObjectStr fromObject = \case From c66630d69a0444caff181ccd05280481f93ceb0f Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:35:25 +0100 Subject: [PATCH 33/75] Add a couple docstrings --- msgpack/src/Data/MessagePack/Object.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 5c00117..1de0278 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -105,20 +105,24 @@ putObject = \case ObjectMap m -> putMap putObject putObject m ObjectExt b r -> putExt b r +-- | This 'Binary' instance encodes\/decodes to\/from MessagePack format instance Binary Object where get = getObject put = putObject +-- | Class for converting between MessagePack 'Object's and native Haskell types. class MessagePack a where toObject :: a -> Object fromObject :: Object -> Maybe a -- core instances +-- | The trivial identity 'MessagePack' instance instance MessagePack Object where toObject = id fromObject = Just +-- | Encodes as 'ObjectNil' instance MessagePack () where toObject _ = ObjectNil fromObject = \case @@ -182,6 +186,9 @@ instance (MessagePack a, MessagePack b) => MessagePack (Assoc (V.Vector (a, b))) -- nullable +-- | 'Maybe's are encoded as nullable types, i.e. 'Nothing' is encoded as @nil@. +-- +-- __NOTE__: Encoding nested 'Maybe's or 'Maybe's enclosing types which encode to @nil@ (such as '()') will break round-tripping instance MessagePack a => MessagePack (Maybe a) where toObject = \case Just a -> toObject a From a47f4f025c904f17107ae504eebbc8f74ac7b530 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:47:21 +0100 Subject: [PATCH 34/75] Add {put,get}{Word,Int}64 primitives Previously there was only `{put,get}Int` which is lossy for `Word64` data and/or when `Int` is not 64bit wide. --- msgpack/src/Data/MessagePack.hs | 2 +- msgpack/src/Data/MessagePack/Get.hs | 98 +++++++++++++++++++++++++---- msgpack/src/Data/MessagePack/Put.hs | 58 ++++++++++------- msgpack/test/test.hs | 4 ++ 4 files changed, 128 insertions(+), 34 deletions(-) diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index 339e3a8..1894fa8 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -22,7 +22,7 @@ module Data.MessagePack ( module Data.MessagePack.Put, ) where -import Data.Binary +import Data.Binary (decode, encode) import qualified Data.ByteString.Lazy as L import Data.MessagePack.Assoc diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 383933e..478b4db 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -22,7 +22,7 @@ import Control.Monad import Data.Binary import Data.Binary.Get (getByteString, getWord16be, getWord32be, getWord64be) -import Data.Binary.IEEE754 +import Data.Binary.IEEE754 (getFloat32be, getFloat64be) import Data.Bits import qualified Data.ByteString as S import Data.Int @@ -35,26 +35,99 @@ getNil = tag 0xC0 getBool :: Get Bool getBool = - False <$ tag 0xC2 <|> - True <$ tag 0xC3 + getWord8 >>= \case + 0xC2 -> return False + 0xC3 -> return True + + _ -> empty +-- | Deserialize an integer into an 'Int' +-- +-- __WARNING__: Currently this function silently wraps around integers to make them fit into an 'Int'. This will be changed in the next major version (i.e. @msgpack-1.1.0@). getInt :: Get Int getInt = getWord8 >>= \case - c | c .&. 0x80 == 0x00 -> - return $ fromIntegral c - | c .&. 0xE0 == 0xE0 -> - return $ fromIntegral (fromIntegral c :: Int8) + c | c .&. 0x80 == 0x00 -> return $ fromIntegral c + | c .&. 0xE0 == 0xE0 -> return $ fromIntegral (fromIntegral c :: Int8) + 0xCC -> fromIntegral <$> getWord8 0xCD -> fromIntegral <$> getWord16be 0xCE -> fromIntegral <$> getWord32be 0xCF -> fromIntegral <$> getWord64be + 0xD0 -> fromIntegral <$> getInt8 0xD1 -> fromIntegral <$> getInt16be 0xD2 -> fromIntegral <$> getInt32be 0xD3 -> fromIntegral <$> getInt64be + + _ -> empty + +-- | Deserialize an integer into a 'Word' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Word' type. +-- +-- @since 1.0.1.0 +getWord :: Get Word +getWord + | maxWord == maxBound = fromIntegral <$> getWord64 + | otherwise = do + w <- getWord64 + if w <= maxWord + then return (fromIntegral w) + else empty + where + maxWord :: Word64 + maxWord = fromIntegral (maxBound :: Word) + +-- | Deserialize an integer into an 'Int64' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int64' type. +-- +-- @since 1.0.1.0 +getInt64 :: Get Int64 +getInt64 = + getWord8 >>= \case + c | c .&. 0x80 == 0x00 -> return $ fromIntegral c + | c .&. 0xE0 == 0xE0 -> return $ fromIntegral (fromIntegral c :: Int8) + + 0xCC -> fromIntegral <$> getWord8 + 0xCD -> fromIntegral <$> getWord16be + 0xCE -> fromIntegral <$> getWord32be + 0xCF -> do + x <- fromIntegral <$> getWord64be + if x >= 0 then return x else empty + + 0xD0 -> fromIntegral <$> getInt8 + 0xD1 -> fromIntegral <$> getInt16be + 0xD2 -> fromIntegral <$> getInt32be + 0xD3 -> getInt64be + _ -> empty +-- | Deserialize an integer into a 'Word' +-- +-- This operation will fail if the encoded integer doesn't fit into the value range of the 'Word64' type. +-- +-- @since 1.0.1.0 +getWord64 :: Get Word64 +getWord64 = + getWord8 >>= \case + c | c .&. 0x80 == 0x00 -> return $ fromIntegral c + | c .&. 0xE0 == 0xE0 -> return $ fromIntegral (fromIntegral c :: Int8) + + 0xCC -> fromIntegral <$> getWord8 + 0xCD -> fromIntegral <$> getWord16be + 0xCE -> fromIntegral <$> getWord32be + 0xCF -> getWord64be + + 0xD0 -> do { x <- getInt8 ; if x >= 0 then return (fromIntegral x) else empty } + 0xD1 -> do { x <- getInt16be ; if x >= 0 then return (fromIntegral x) else empty } + 0xD2 -> do { x <- getInt32be ; if x >= 0 then return (fromIntegral x) else empty } + 0xD3 -> do { x <- getInt64be ; if x >= 0 then return (fromIntegral x) else empty } + + _ -> empty + + getFloat :: Get Float getFloat = tag 0xCA >> getFloat32be @@ -118,6 +191,12 @@ getExt = do _ -> empty (,) <$> getWord8 <*> getByteString len +tag :: Word8 -> Get () +tag t = do + b <- getWord8 + guard $ t == b + +-- internal helpers for operations missing from older `binary` versions getInt8 :: Get Int8 getInt8 = fromIntegral <$> getWord8 @@ -129,8 +208,3 @@ getInt32be = fromIntegral <$> getWord32be getInt64be :: Get Int64 getInt64be = fromIntegral <$> getWord64be - -tag :: Word8 -> Get () -tag t = do - b <- getWord8 - guard $ t == b diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index c3bb61d..19af1e7 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -10,15 +10,17 @@ -------------------------------------------------------------------- module Data.MessagePack.Put ( - putNil, putBool, putInt, putFloat, putDouble, + putNil, putBool, putFloat, putDouble, + putInt, putWord, putInt64, putWord64, putStr, putBin, putArray, putMap, putExt, ) where import Data.Binary -import Data.Binary.IEEE754 +import Data.Binary.IEEE754 (putFloat32be, putFloat64be) import Data.Binary.Put import Data.Bits import qualified Data.ByteString as S +import Data.Int import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V @@ -33,25 +35,39 @@ putBool False = putWord8 0xC2 putBool True = putWord8 0xC3 putInt :: Int -> Put -putInt n - | -32 <= n && n <= 127 = - putWord8 $ fromIntegral n - | 0 <= n && n < 0x100 = - putWord8 0xCC >> putWord8 (fromIntegral n) - | 0 <= n && n < 0x10000 = - putWord8 0xCD >> putWord16be (fromIntegral n) - | 0 <= n && n < 0x100000000 = - putWord8 0xCE >> putWord32be (fromIntegral n) - | 0 <= n = - putWord8 0xCF >> putWord64be (fromIntegral n) - | -0x80 <= n = - putWord8 0xD0 >> putWord8 (fromIntegral n) - | -0x8000 <= n = - putWord8 0xD1 >> putWord16be (fromIntegral n) - | -0x80000000 <= n = - putWord8 0xD2 >> putWord32be (fromIntegral n) - | otherwise = - putWord8 0xD3 >> putWord64be (fromIntegral n) +putInt n = putInt64 (fromIntegral n) + +-- | @since 1.0.1.0 +putWord :: Word -> Put +putWord n = putWord64 (fromIntegral n) + +-- | @since 1.0.1.0 +putInt64 :: Int64 -> Put +putInt64 n + -- positive fixnum stores 7-bit positive integer + -- negative fixnum stores 5-bit negative integer + | -32 <= n && n <= 127 = putWord8 $ fromIntegral n + + -- unsigned int encoding + | n >= 0 = putWord64 (fromIntegral n) + + -- signed int encoding + | -0x80 <= n = putWord8 0xD0 >> putWord8 (fromIntegral n) + | -0x8000 <= n = putWord8 0xD1 >> putWord16be (fromIntegral n) + | -0x80000000 <= n = putWord8 0xD2 >> putWord32be (fromIntegral n) + | otherwise = putWord8 0xD3 >> putWord64be (fromIntegral n) + +-- | @since 1.0.1.0 +putWord64 :: Word64 -> Put +putWord64 n + -- positive fixnum stores 7-bit positive integer + | n < 0x80 = putWord8 $ fromIntegral n + + -- unsigned int encoding + | n < 0x100 = putWord8 0xCC >> putWord8 (fromIntegral n) + | n < 0x10000 = putWord8 0xCD >> putWord16be (fromIntegral n) + | n < 0x100000000 = putWord8 0xCE >> putWord32be (fromIntegral n) + | otherwise = putWord8 0xCF >> putWord64be (fromIntegral n) putFloat :: Float -> Put putFloat f = do diff --git a/msgpack/test/test.hs b/msgpack/test/test.hs index 2afa0e3..a659aa8 100644 --- a/msgpack/test/test.hs +++ b/msgpack/test/test.hs @@ -49,6 +49,8 @@ tests = \(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)" $ @@ -65,4 +67,6 @@ tests = \(a :: [(String, String)]) -> a == mid a , testProperty "Assoc [(string, int)]" $ \(a :: Assoc [(String, Int)]) -> a == mid a + , testProperty "maybe (Int,Bool,String)" $ + \(a :: (Maybe ((),Maybe Int,Maybe Float,Maybe Bool,Maybe Double,Maybe String))) -> a == mid a ] From 43ee6def0c2d2b24707f5e3011d703e36e6cad76 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:51:55 +0100 Subject: [PATCH 35/75] Unlit Setup.hs --- msgpack/Setup.hs | 2 ++ msgpack/Setup.lhs | 3 --- 2 files changed, 2 insertions(+), 3 deletions(-) create mode 100644 msgpack/Setup.hs delete mode 100644 msgpack/Setup.lhs 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 From d39fd6c946471ba85958bdd249613693aad89f2c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Mar 2019 23:59:29 +0100 Subject: [PATCH 36/75] Add changelog --- msgpack/CHANGES.md | 11 +++++++++++ msgpack/msgpack.cabal | 2 ++ 2 files changed, 13 insertions(+) create mode 100644 msgpack/CHANGES.md diff --git a/msgpack/CHANGES.md b/msgpack/CHANGES.md new file mode 100644 index 0000000..f1a7ed9 --- /dev/null +++ b/msgpack/CHANGES.md @@ -0,0 +1,11 @@ +## 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 +- 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` diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index e4bd512..2bd9bb3 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -26,6 +26,8 @@ copyright: Copyright (c) Hideyuki Tanaka 2009-2015, category: Data build-type: Simple +extra-source-files: CHANGES.md + source-repository head type: git location: http://github.com/msgpack/msgpack-haskell.git From a5d3172ad24244cc1ca4451a486b3c3f141d5716 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Thu, 28 Mar 2019 00:31:11 +0100 Subject: [PATCH 37/75] Update changelog --- msgpack/CHANGES.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/msgpack/CHANGES.md b/msgpack/CHANGES.md index f1a7ed9..a10162e 100644 --- a/msgpack/CHANGES.md +++ b/msgpack/CHANGES.md @@ -2,10 +2,12 @@ - Fix incorrect MessagePack tag when encoding single-precision `Float`s - Fix looping/hanging `MessagePack (Maybe a)` instance -- Add support for binary-0.8 +- 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 From e8eb1e2f2fca205b89994d2b1fe42ab97c9d6be3 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Thu, 28 Mar 2019 00:57:48 +0100 Subject: [PATCH 38/75] Add MPInteger type impl TODO: write testcases --- msgpack/msgpack.cabal | 1 + msgpack/src/Data/MessagePack/Integer.hs | 243 ++++++++++++++++++++++++ msgpack/src/Data/MessagePack/Put.hs | 3 +- 3 files changed, 246 insertions(+), 1 deletion(-) create mode 100644 msgpack/src/Data/MessagePack/Integer.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 2bd9bb3..01dc759 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -41,6 +41,7 @@ library exposed-modules: Data.MessagePack Data.MessagePack.Assoc + Data.MessagePack.Integer Data.MessagePack.Object Data.MessagePack.Get Data.MessagePack.Put diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs new file mode 100644 index 0000000..0e1ad92 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module : Data.MessagePack.Integer +-- Copyright : © Herbert Valerio Riedel 2019 +-- License : BSD3 +-- +-- Type representing MessagePack integers +-- +module Data.MessagePack.Integer + ( MPInteger + , ToMPInteger(..) + , FromMPInteger(..) + + , putMPInteger + , getMPInteger + ) where + +import Control.Applicative +import Control.DeepSeq (NFData (rnf)) +import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), + throw) +import Data.Int +import Data.Word + +import Data.Binary (Binary (get, put)) +import Data.Binary.Get (Get, getWord16be, getWord32be, + getWord64be, getWord8) +import Data.Binary.Put (Put, putWord16be, putWord32be, + putWord64be, putWord8) +import Data.Bits + +-- | 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) + +-- NB: only valid if isW64 is true +toW64 :: Int64 -> Word64 +toW64 = fromIntegral + + +class ToMPInteger a where + toMPInteger :: a -> MPInteger + +instance ToMPInteger Word64 where + toMPInteger w = MPInteger (i<0) i + where + i = fromIntegral w + +instance ToMPInteger Int64 where + toMPInteger = MPInteger False + +instance ToMPInteger Int8 where toMPInteger i = MPInteger False (fromIntegral i) +instance ToMPInteger Int16 where toMPInteger i = MPInteger False (fromIntegral i) +instance ToMPInteger Int32 where toMPInteger i = MPInteger False (fromIntegral i) +instance ToMPInteger Int where toMPInteger i = MPInteger False (fromIntegral i) + +instance ToMPInteger Word8 where toMPInteger w = MPInteger False (fromIntegral w) +instance ToMPInteger Word16 where toMPInteger w = MPInteger False (fromIntegral w) +instance ToMPInteger Word32 where toMPInteger w = MPInteger False (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 Word64 where + fromMPInteger (MPInteger True w) = Just (toW64 w) + fromMPInteger (MPInteger False i) + | i < 0 = Nothing + | otherwise = Just (toW64 i) + +instance FromMPInteger Int64 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = Just i + + + +-- 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. + + +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 NFData MPInteger where + rnf (MPInteger _ _) = () + +-- | This instance will throw the respective arithmetic 'Underflow' and 'Overflow' exception if the range of 'MPInteger' is exceeded. +instance Num MPInteger where + fromInteger i + | i < toInteger (minBound :: Int64) = throw Underflow + | i <= toInteger (maxBound :: Int64) = MPInteger False (fromInteger i) + | i <= toInteger (maxBound :: Word64) = MPInteger True (fromInteger i) + | otherwise = throw Overflow + + 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 +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 = putWord8 (fromIntegral i) + + -- unsigned int encoding + | i >= 0 = case () of + _ | i < 0x100 -> putWord8 0xCC >> putWord8 (fromIntegral i) + | i < 0x10000 -> putWord8 0xCD >> putWord16be (fromIntegral i) + | i < 0x100000000 -> putWord8 0xCE >> putWord32be (fromIntegral i) + | otherwise -> putWord8 0xCF >> putWord64be (fromIntegral i) + + -- signed int encoding + | -0x80 <= i = putWord8 0xD0 >> putWord8 (fromIntegral i) + | -0x8000 <= i = putWord8 0xD1 >> putWord16be (fromIntegral i) + | -0x80000000 <= i = putWord8 0xD2 >> putWord32be (fromIntegral i) + | otherwise = putWord8 0xD3 >> putWord64be (fromIntegral i) +putMPInteger (MPInteger True w) = putWord8 0xCF >> putWord64be (toW64 w) + +-- | Deserializes 'MPInteger' from MessagePack +-- +-- This operation will only fail if a non-integer MessagePack tag is encountered. +getMPInteger :: Get MPInteger +getMPInteger = getWord8 >>= \case + -- positive fixnum stores 7-bit positive integer + -- negative fixnum stores 5-bit negative integer + c | c .&. 0x80 == 0x00 -> pure $! toMPInteger (c :: Word8) + | c .&. 0xE0 == 0xE0 -> pure $! toMPInteger (fromIntegral c :: Int8) + + 0xCC -> toMPInteger <$> getWord8 + 0xCD -> toMPInteger <$> getWord16be + 0xCE -> toMPInteger <$> getWord32be + 0xCF -> toMPInteger <$> getWord64be + + 0xD0 -> toMPInteger <$> (fromIntegral <$> getWord8 :: Get Int8) + 0xD1 -> toMPInteger <$> (fromIntegral <$> getWord16be :: Get Int16) + 0xD2 -> toMPInteger <$> (fromIntegral <$> getWord32be :: Get Int32) + 0xD3 -> toMPInteger <$> (fromIntegral <$> getWord64be :: Get Int64) + + _ -> empty + diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 19af1e7..a1d4438 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -17,7 +17,8 @@ module Data.MessagePack.Put ( import Data.Binary import Data.Binary.IEEE754 (putFloat32be, putFloat64be) -import Data.Binary.Put +import Data.Binary.Put (putByteString, putWord16be, putWord32be, + putWord64be, putWord8) import Data.Bits import qualified Data.ByteString as S import Data.Int From 894f0e5e09daf4c31ed70f7fd8b4ad52285110f3 Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@gmail.com> Date: Sat, 30 Mar 2019 04:59:35 -0400 Subject: [PATCH 39/75] remove orphans from the Aeson integration (#76) --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 81 +++++++-------------- msgpack-aeson/test/test.hs | 7 +- 2 files changed, 29 insertions(+), 59 deletions(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index 1c51262..a18fdd1 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -4,17 +4,10 @@ {-# LANGUAGE LambdaCase #-} -- | Aeson bridge for MessagePack - module Data.MessagePack.Aeson ( -- * Conversion functions toAeson, fromAeson, - -- * MessagePack instance for Aeson.Value - -- $msgpackInstance - - -- * ToJSON and FromJSON instance for MessagePack.Object - -- $aesonInstances - -- * Wrapper instances AsMessagePack(..), AsAeson(..), @@ -28,7 +21,7 @@ import Control.Applicative import Control.Arrow import Control.DeepSeq import Data.Aeson as A -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as L (ByteString) import Data.Data import qualified Data.HashMap.Strict as HM import Data.Maybe @@ -37,24 +30,24 @@ import Data.Scientific import qualified Data.Text.Encoding as T import qualified Data.Vector as V --- | Convert MessagePack Object to Aeson Value. --- If the value unable to convert, it returns Nothing -toAeson :: MP.Object -> Maybe Value +-- | Convert 'MP.Object' to JSON 'Value' +toAeson :: MP.Object -> A.Result Value toAeson = \case - ObjectNil -> Just Null - ObjectBool b -> Just $ Bool b - ObjectInt n -> Just $ Number $ fromIntegral n - ObjectFloat f -> Just $ Number $ realToFrac f - ObjectDouble d -> Just $ Number $ realToFrac d - ObjectStr t -> Just $ String t - ObjectBin b -> String <$> either (const Nothing) Just (T.decodeUtf8' b) + 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 -> String <$> either (fail . show) pure (T.decodeUtf8' b) ObjectArray v -> Array <$> V.mapM toAeson v ObjectMap m -> A.Object . HM.fromList . V.toList - <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> toAeson v) m - ObjectExt _ _ -> Nothing + <$> V.mapM (\(k, v) -> (,) <$> from k <*> toAeson v) m + where from = maybe (fail "bad object") pure . MP.fromObject + ObjectExt _ _ -> fail "ObjectExt is not supported" --- | Convert Aeson Value to MessagePack Object +-- | Convert JSON 'Value' to 'MP.Object' fromAeson :: Value -> MP.Object fromAeson = \case Null -> ObjectNil @@ -67,28 +60,12 @@ fromAeson = \case Array v -> ObjectArray $ V.map fromAeson v A.Object o -> ObjectMap $ V.fromList $ map (toObject *** fromAeson) $ HM.toList o --- $msgpackInstance --- > instance MessagePack Value -instance MessagePack Value where - fromObject = toAeson - toObject = fromAeson - --- $aesonInstances --- > instance ToJSON Object --- > instance FromJSON Object -instance ToJSON MP.Object where - -- When fail to convert, it returns `Null` - toJSON = fromMaybe Null .toAeson - -instance FromJSON MP.Object where - parseJSON = return . fromAeson - -- | 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 <$> (fromJSON' =<< toAeson o) + fromObject o = AsMessagePack <$> (\case { A.Error _ -> Nothing; A.Success x -> Just x } $ (fromJSON =<< toAeson o)) toObject = fromAeson . toJSON . getAsMessagePack -- | Wrapper for using MessagePack values as Aeson value. @@ -96,31 +73,23 @@ newtype AsAeson a = AsAeson { getAsAeson :: a } deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) instance MessagePack a => ToJSON (AsAeson a) where - toJSON = fromMaybe Null . toAeson . toObject . getAsAeson + toJSON = \case { A.Error _ -> Null; A.Success x -> x } . toAeson . toObject . getAsAeson instance MessagePack a => FromJSON (AsAeson a) where parseJSON = maybe empty (return . AsAeson) . fromObject . fromAeson --- | Pack Aeson value to MessagePack binary +-- | Encode to MessagePack via "Data.Aeson"'s 'ToJSON' instances packAeson :: ToJSON a => a -> L.ByteString -packAeson = pack . toJSON +packAeson = pack . fromAeson . toJSON --- | Unpack Aeson value from MessagePack binary -unpackAeson :: FromJSON a => L.ByteString -> Maybe a -unpackAeson b = fromJSON' =<< unpack b +-- | Decode from MessagePack via "Data.Aeson"'s 'FromJSON' instances +unpackAeson :: FromJSON a => L.ByteString -> Result a +unpackAeson b = fromJSON =<< toAeson =<< maybe (fail "unpackAeson") pure (unpack b) --- | Encode MessagePack value to JSON +-- | Encode MessagePack value to JSON document encodeMessagePack :: MessagePack a => a -> L.ByteString encodeMessagePack = encode . toJSON . AsAeson --- | Decode MessagePack value from JSON -decodeMessagePack :: MessagePack a => L.ByteString -> Maybe a -decodeMessagePack b = getAsAeson <$> (fromJSON' =<< decode b) - -fromJSON' :: FromJSON a => Value -> Maybe a -fromJSON' = resultToMaybe . fromJSON - -resultToMaybe :: Result a -> Maybe a -resultToMaybe = \case - Success a -> Just a - _ -> Nothing +-- | 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)) diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs index dea108b..7242b71 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +import Control.Applicative import Control.Monad import Data.Aeson import Data.Aeson.TH @@ -49,9 +50,9 @@ test v = do roundTrip :: (Show a, Eq a, ToJSON a, FromJSON a) => a -> IO () roundTrip v = do - let mp = pack (AsMessagePack v) - v' = unpack mp - v' @?= Just (AsMessagePack v) + let mp = packAeson v + v' = unpackAeson mp + v' @?= pure v main :: IO () main = From 6e105c48db0f20ca1dffeaff9b4d0160b3b18c26 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Fri, 29 Mar 2019 00:02:32 +0100 Subject: [PATCH 40/75] Import @kawanet's test-suite data Copied from https://github.com/kawanet/msgpack-test-suite (version 1.0.0 / e04f6edeaae589c768d6b70fcce80aa786b7800e) --- msgpack/test/data/10.nil.yaml | 6 ++ msgpack/test/data/11.bool.yaml | 11 ++ msgpack/test/data/12.binary.yaml | 22 ++++ msgpack/test/data/20.number-positive.yaml | 120 ++++++++++++++++++++++ msgpack/test/data/21.number-negative.yaml | 68 ++++++++++++ msgpack/test/data/22.number-float.yaml | 15 +++ msgpack/test/data/23.number-bignum.yaml | 64 ++++++++++++ msgpack/test/data/30.string-ascii.yaml | 30 ++++++ msgpack/test/data/31.string-utf8.yaml | 31 ++++++ msgpack/test/data/32.string-emoji.yaml | 13 +++ msgpack/test/data/40.array.yaml | 35 +++++++ msgpack/test/data/41.map.yaml | 22 ++++ msgpack/test/data/42.nested.yaml | 29 ++++++ msgpack/test/data/50.timestamp.yaml | 98 ++++++++++++++++++ msgpack/test/data/60.ext.yaml | 40 ++++++++ msgpack/test/data/README.md | 31 ++++++ 16 files changed, 635 insertions(+) create mode 100644 msgpack/test/data/10.nil.yaml create mode 100644 msgpack/test/data/11.bool.yaml create mode 100644 msgpack/test/data/12.binary.yaml create mode 100644 msgpack/test/data/20.number-positive.yaml create mode 100644 msgpack/test/data/21.number-negative.yaml create mode 100644 msgpack/test/data/22.number-float.yaml create mode 100644 msgpack/test/data/23.number-bignum.yaml create mode 100644 msgpack/test/data/30.string-ascii.yaml create mode 100644 msgpack/test/data/31.string-utf8.yaml create mode 100644 msgpack/test/data/32.string-emoji.yaml create mode 100644 msgpack/test/data/40.array.yaml create mode 100644 msgpack/test/data/41.map.yaml create mode 100644 msgpack/test/data/42.nested.yaml create mode 100644 msgpack/test/data/50.timestamp.yaml create mode 100644 msgpack/test/data/60.ext.yaml create mode 100644 msgpack/test/data/README.md 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. +``` From 28f85a464ab76d71e2d5b759f62db7d9ff72caee Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 09:26:36 +0100 Subject: [PATCH 41/75] Improve 'MPInteger' implementation And introduce less error-prone symbols for tag constants --- msgpack/msgpack.cabal | 2 + msgpack/src/Data/MessagePack/Integer.hs | 164 +++++++++++++++--------- msgpack/src/Data/MessagePack/Tags.hs | 83 ++++++++++++ 3 files changed, 189 insertions(+), 60 deletions(-) create mode 100644 msgpack/src/Data/MessagePack/Tags.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 50d192e..a561e6f 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -47,6 +47,8 @@ library Data.MessagePack.Get Data.MessagePack.Put + other-modules: Data.MessagePack.Tags + build-depends: base >= 4.7 && < 4.13 , mtl >= 2.1.3.1 && < 2.3 , bytestring >= 0.10.4 && < 0.11 diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs index 0e1ad92..4e629bb 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.MessagePack.Integer @@ -11,24 +13,26 @@ module Data.MessagePack.Integer ( MPInteger , ToMPInteger(..) , FromMPInteger(..) + , fromIntegerTry , putMPInteger , getMPInteger ) where import Control.Applicative -import Control.DeepSeq (NFData (rnf)) -import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), - throw) +import Control.DeepSeq (NFData (rnf)) +import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), + throw) import Data.Int import Data.Word -import Data.Binary (Binary (get, put)) -import Data.Binary.Get (Get, getWord16be, getWord32be, - getWord64be, getWord8) -import Data.Binary.Put (Put, putWord16be, putWord32be, - putWord64be, putWord8) -import Data.Bits +import Data.Binary (Binary (get, put)) +import Data.Binary.Get (Get, getWord16be, getWord32be, + getWord64be, getWord8) +import Data.Binary.Put (Put, putWord16be, putWord32be, + putWord64be, putWord8) + +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`. @@ -38,36 +42,30 @@ data MPInteger = MPInteger {- isW64 -} !Bool {- value -} {-# UNPACK #-} !Int64 deriving (Eq,Ord) +-- 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 = fromIntegral - class ToMPInteger a where toMPInteger :: a -> MPInteger -instance ToMPInteger Word64 where - toMPInteger w = MPInteger (i<0) i - where - i = fromIntegral w - -instance ToMPInteger Int64 where - toMPInteger = MPInteger False - instance ToMPInteger Int8 where toMPInteger i = MPInteger False (fromIntegral i) instance ToMPInteger Int16 where toMPInteger i = MPInteger False (fromIntegral i) instance ToMPInteger Int32 where toMPInteger i = MPInteger False (fromIntegral i) +instance ToMPInteger Int64 where toMPInteger = MPInteger False instance ToMPInteger Int where toMPInteger i = MPInteger False (fromIntegral i) instance ToMPInteger Word8 where toMPInteger w = MPInteger False (fromIntegral w) instance ToMPInteger Word16 where toMPInteger w = MPInteger False (fromIntegral w) instance ToMPInteger Word32 where toMPInteger w = MPInteger False (fromIntegral w) - -instance ToMPInteger Word where - toMPInteger w = MPInteger (i<0) i - where - i = fromIntegral 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 -- @@ -78,24 +76,64 @@ instance ToMPInteger Word where class FromMPInteger a where fromMPInteger :: MPInteger -> Maybe a +instance FromMPInteger Word where + fromMPInteger (MPInteger isW64 i) + | 0 <= i || isW64 + , toW64 i <= maxW = Just $! fromIntegral i + | otherwise = Nothing + where + maxW = fromIntegral (maxBound :: Word) :: Word64 + instance FromMPInteger Word64 where - fromMPInteger (MPInteger True w) = Just (toW64 w) + fromMPInteger (MPInteger True w) = Just $! toW64 w fromMPInteger (MPInteger False i) - | i < 0 = Nothing - | otherwise = Just (toW64 i) + | 0 <= i = Just (toW64 i) + | otherwise = Nothing + +instance FromMPInteger Word32 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = int64toInt i + +instance FromMPInteger Word16 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = int64toInt i + +instance FromMPInteger Word8 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = int64toInt i + +----- + +instance FromMPInteger Int where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = int64toInt 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) = int64toInt i +instance FromMPInteger Int16 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = int64toInt i --- 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. +instance FromMPInteger Int8 where + fromMPInteger (MPInteger True _) = Nothing + fromMPInteger (MPInteger False i) = int64toInt i +{-# INLINE int64toInt #-} +int64toInt :: forall i . (Integral i, Bounded i) => Int64 -> Maybe i +int64toInt i + | minI <= i, i <= maxI = Just $! fromIntegral i + | otherwise = Nothing + where + minI = fromIntegral (minBound :: i) :: Int64 + maxI = fromIntegral (maxBound :: i) :: Int64 + +---------------------------------------------------------------------------- instance Bounded MPInteger where minBound = MPInteger False minBound @@ -110,16 +148,25 @@ 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 - | i < toInteger (minBound :: Int64) = throw Underflow - | i <= toInteger (maxBound :: Int64) = MPInteger False (fromInteger i) - | i <= toInteger (maxBound :: Word64) = MPInteger True (fromInteger i) - | otherwise = throw Overflow + 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` @@ -128,7 +175,6 @@ instance Num MPInteger where | v == minBound = MPInteger False v | otherwise = throw Underflow - -- addition MPInteger False 0 + x = x x + MPInteger False 0 = x @@ -207,17 +253,17 @@ putMPInteger (MPInteger False i) -- unsigned int encoding | i >= 0 = case () of - _ | i < 0x100 -> putWord8 0xCC >> putWord8 (fromIntegral i) - | i < 0x10000 -> putWord8 0xCD >> putWord16be (fromIntegral i) - | i < 0x100000000 -> putWord8 0xCE >> putWord32be (fromIntegral i) - | otherwise -> putWord8 0xCF >> putWord64be (fromIntegral i) + _ | 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 (fromIntegral i) -- signed int encoding - | -0x80 <= i = putWord8 0xD0 >> putWord8 (fromIntegral i) - | -0x8000 <= i = putWord8 0xD1 >> putWord16be (fromIntegral i) - | -0x80000000 <= i = putWord8 0xD2 >> putWord32be (fromIntegral i) - | otherwise = putWord8 0xD3 >> putWord64be (fromIntegral i) -putMPInteger (MPInteger True w) = putWord8 0xCF >> putWord64be (toW64 w) + | -0x80 <= i = putWord8 TAG_int8 >> putWord8 (fromIntegral i) + | -0x8000 <= i = putWord8 TAG_int16 >> putWord16be (fromIntegral i) + | -0x80000000 <= i = putWord8 TAG_int32 >> putWord32be (fromIntegral i) + | otherwise = putWord8 TAG_int64 >> putWord64be (fromIntegral i) +putMPInteger (MPInteger True w) = putWord8 TAG_uint64 >> putWord64be (toW64 w) -- | Deserializes 'MPInteger' from MessagePack -- @@ -226,18 +272,16 @@ getMPInteger :: Get MPInteger getMPInteger = getWord8 >>= \case -- positive fixnum stores 7-bit positive integer -- negative fixnum stores 5-bit negative integer - c | c .&. 0x80 == 0x00 -> pure $! toMPInteger (c :: Word8) - | c .&. 0xE0 == 0xE0 -> pure $! toMPInteger (fromIntegral c :: Int8) - - 0xCC -> toMPInteger <$> getWord8 - 0xCD -> toMPInteger <$> getWord16be - 0xCE -> toMPInteger <$> getWord32be - 0xCF -> toMPInteger <$> getWord64be + c | is_TAG_fixint c -> pure $! toMPInteger (fromIntegral c :: Int8) - 0xD0 -> toMPInteger <$> (fromIntegral <$> getWord8 :: Get Int8) - 0xD1 -> toMPInteger <$> (fromIntegral <$> getWord16be :: Get Int16) - 0xD2 -> toMPInteger <$> (fromIntegral <$> getWord32be :: Get Int32) - 0xD3 -> toMPInteger <$> (fromIntegral <$> getWord64be :: Get Int64) + TAG_uint8 -> toMPInteger <$> getWord8 + TAG_uint16 -> toMPInteger <$> getWord16be + TAG_uint32 -> toMPInteger <$> getWord32be + TAG_uint64 -> toMPInteger <$> getWord64be - _ -> empty + TAG_int8 -> toMPInteger <$> (fromIntegral <$> getWord8 :: Get Int8) + TAG_int16 -> toMPInteger <$> (fromIntegral <$> getWord16be :: Get Int16) + TAG_int32 -> toMPInteger <$> (fromIntegral <$> getWord32be :: Get Int32) + TAG_int64 -> toMPInteger <$> (fromIntegral <$> getWord64be :: Get Int64) + _ -> empty diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs new file mode 100644 index 0000000..481bf1d --- /dev/null +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +#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 Data.Bits ((.&.)) +import Data.Word (Word8) + +-- | 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 + +pattern TAG_fixmap = 0x80 -- 0b1000xxxx [0x80 .. 0x8f] +pattern TAG_MASK_fixmap = 0xf0 -- 0b11110000 + +pattern TAG_fixarray = 0x90 -- 0b1001xxxx [0x90 .. 0x9f] +pattern TAG_MASK_fixarray = 0xf0 -- 0b11110000 + +pattern TAG_fixstr = 0xa0 -- 0b101xxxxx [0xa0 .. 0xbf] +pattern TAG_MASK_fixstr = 0xe0 -- 0b11100000 + +pattern TAG_nil = 0xc0 -- 0b11000000 +-- reserved = 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 From 8c41f6aa2b7184c358eece418a1e0f81d73cf4e6 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 12:16:03 +0100 Subject: [PATCH 42/75] Don't export the redundant 'putMPInteger'/'getMPInteger' entrypoints --- msgpack/src/Data/MessagePack/Integer.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs index 4e629bb..9666b82 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -14,9 +14,6 @@ module Data.MessagePack.Integer , ToMPInteger(..) , FromMPInteger(..) , fromIntegerTry - - , putMPInteger - , getMPInteger ) where import Control.Applicative @@ -236,6 +233,13 @@ instance Integral MPInteger where ---------------------------------------------------------------------------- -- | 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 From 5fcad275ad7a7d40417fbb596b1b46cd85e81dc0 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 12:32:31 +0100 Subject: [PATCH 43/75] Major refactoring of Data.MessagePack.Put module - Replace tag number literals with symbols from `Data.MessagePack.Tags` - Implement 'put{Int,Word}` operations in terms of `MPInteger` - Adds a new `putExt'` operation - Enforce max 2^32-1-byte datasize encoding limit in `putExt` operation --- msgpack/src/Data/MessagePack/Put.hs | 148 +++++++++++++--------------- 1 file changed, 68 insertions(+), 80 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index a1d4438..4c90d32 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -12,131 +12,119 @@ module Data.MessagePack.Put ( putNil, putBool, putFloat, putDouble, putInt, putWord, putInt64, putWord64, - putStr, putBin, putArray, putMap, putExt, + putStr, putBin, putArray, putMap, putExt, putExt' ) where import Data.Binary -import Data.Binary.IEEE754 (putFloat32be, putFloat64be) -import Data.Binary.Put (putByteString, putWord16be, putWord32be, - putWord64be, putWord8) +import Data.Binary.IEEE754 (putFloat32be, putFloat64be) +import Data.Binary.Put (putByteString, putWord16be, + putWord32be) import Data.Bits -import qualified Data.ByteString as S +import qualified Data.ByteString as S import Data.Int -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V -import Prelude hiding (putStr) +import Prelude hiding (putStr) + +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 = putInt64 (fromIntegral n) +putInt = put . toMPInteger -- | @since 1.0.1.0 putWord :: Word -> Put -putWord n = putWord64 (fromIntegral n) +putWord = put . toMPInteger -- | @since 1.0.1.0 putInt64 :: Int64 -> Put -putInt64 n - -- positive fixnum stores 7-bit positive integer - -- negative fixnum stores 5-bit negative integer - | -32 <= n && n <= 127 = putWord8 $ fromIntegral n - - -- unsigned int encoding - | n >= 0 = putWord64 (fromIntegral n) - - -- signed int encoding - | -0x80 <= n = putWord8 0xD0 >> putWord8 (fromIntegral n) - | -0x8000 <= n = putWord8 0xD1 >> putWord16be (fromIntegral n) - | -0x80000000 <= n = putWord8 0xD2 >> putWord32be (fromIntegral n) - | otherwise = putWord8 0xD3 >> putWord64be (fromIntegral n) +putInt64 = put . toMPInteger -- | @since 1.0.1.0 putWord64 :: Word64 -> Put -putWord64 n - -- positive fixnum stores 7-bit positive integer - | n < 0x80 = putWord8 $ fromIntegral n - - -- unsigned int encoding - | n < 0x100 = putWord8 0xCC >> putWord8 (fromIntegral n) - | n < 0x10000 = putWord8 0xCD >> putWord16be (fromIntegral n) - | n < 0x100000000 = putWord8 0xCE >> putWord32be (fromIntegral n) - | otherwise = putWord8 0xCF >> putWord64be (fromIntegral n) +putWord64 = put . toMPInteger putFloat :: Float -> Put -putFloat f = do - putWord8 0xCA - putFloat32be f +putFloat f = putWord8 TAG_float32 >> putFloat32be f putDouble :: Double -> Put -putDouble d = do - putWord8 0xCB - putFloat64be d +putDouble d = putWord8 TAG_float64 >> putFloat64be d putStr :: T.Text -> Put putStr t = do let bs = T.encodeUtf8 t case S.length bs of - len | len <= 31 -> - putWord8 $ 0xA0 .|. fromIntegral len - | len < 0x100 -> - putWord8 0xD9 >> putWord8 (fromIntegral len) - | len < 0x10000 -> - putWord8 0xDA >> putWord16be (fromIntegral len) - | otherwise -> - putWord8 0xDB >> putWord32be (fromIntegral len) + 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 case S.length bs of - len | len < 0x100 -> - putWord8 0xC4 >> putWord8 (fromIntegral len) - | len < 0x10000 -> - putWord8 0xC5 >> putWord16be (fromIntegral len) - | otherwise -> - putWord8 0xC6 >> putWord32be (fromIntegral len) + 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) + len | len < 16 -> putWord8 (TAG_fixarray .|. fromIntegral len) + | len < 0x10000 -> putWord8 TAG_array16 >> putWord16be (fromIntegral len) + | otherwise -> putWord8 TAG_array32 >> putWord32be (fromIntegral len) V.mapM_ p xs 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 + 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 :: Word8 -> S.ByteString -> Put -putExt typ dat = do - case S.length dat of - 1 -> putWord8 0xD4 - 2 -> putWord8 0xD5 - 4 -> putWord8 0xD6 - 8 -> putWord8 0xD7 - 16 -> putWord8 0xD8 - len | len < 0x100 -> putWord8 0xC7 >> putWord8 (fromIntegral len) - | len < 0x10000 -> putWord8 0xC8 >> putWord16be (fromIntegral len) - | otherwise -> putWord8 0xC9 >> putWord32be (fromIntegral len) +putExt typ dat + | Just sz <- int2w32 (S.length dat) = putExt' typ (sz, putByteString dat) + | otherwise = fail "putExt: data exceeds 2^32-1 byte limit of MessagePack" + +-- | @since 1.1.0.0 +putExt' :: Word8 -- ^ type-tag of extended data + -> (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) putWord8 typ - putByteString dat + putdat + +-- TODO: switch to @int-cast@ package +int2w32 :: Int -> Maybe Word32 +int2w32 j + | j < 0 = Nothing + | intLargerThanWord32, j > maxI = Nothing + | otherwise = Just $! fromIntegral j + where + intLargerThanWord32 = not (maxI < (0 `asTypeOf` j)) + maxI = fromIntegral (maxBound :: Word32) From b851490bf7e5b1fdc08c9432ffdb1051cdd84762 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 17:12:21 +0100 Subject: [PATCH 44/75] Add missing size-overflow checks --- msgpack/src/Data/MessagePack/Put.hs | 40 +++++++++++++++++------------ 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 4c90d32..0f3427b 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -------------------------------------------------------------------- -- | -- Module : Data.MessagePack.Put @@ -15,9 +17,10 @@ module Data.MessagePack.Put ( putStr, putBin, putArray, putMap, putExt, putExt' ) where +import Control.Applicative import Data.Binary import Data.Binary.IEEE754 (putFloat32be, putFloat64be) -import Data.Binary.Put (putByteString, putWord16be, +import Data.Binary.Put (PutM, putByteString, putWord16be, putWord32be) import Data.Bits import qualified Data.ByteString as S @@ -65,7 +68,7 @@ putDouble d = putWord8 TAG_float64 >> putFloat64be d putStr :: T.Text -> Put putStr t = do let bs = T.encodeUtf8 t - case S.length bs of + 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) @@ -74,7 +77,7 @@ putStr t = do putBin :: S.ByteString -> Put putBin bs = do - case S.length bs of + 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) @@ -82,7 +85,7 @@ putBin bs = do putArray :: (a -> Put) -> V.Vector a -> Put putArray p xs = do - case V.length xs of + toSizeM ("putArray: data exceeds 2^32-1 element limit of MessagePack") (V.length xs) >>= \case len | len < 16 -> putWord8 (TAG_fixarray .|. fromIntegral len) | len < 0x10000 -> putWord8 TAG_array16 >> putWord16be (fromIntegral len) | otherwise -> putWord8 TAG_array32 >> putWord32be (fromIntegral len) @@ -90,7 +93,7 @@ putArray p xs = do putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put putMap p q xs = do - case V.length xs of + 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) @@ -98,9 +101,9 @@ putMap p q xs = do -- | __NOTE__: MessagePack is limited to maximum extended data payload size of \( 2^{32}-1 \) bytes. putExt :: Word8 -> S.ByteString -> Put -putExt typ dat - | Just sz <- int2w32 (S.length dat) = putExt' typ (sz, putByteString dat) - | otherwise = fail "putExt: data exceeds 2^32-1 byte limit of MessagePack" +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' :: Word8 -- ^ type-tag of extended data @@ -119,12 +122,17 @@ putExt' typ (sz,putdat) = do putWord8 typ putdat --- TODO: switch to @int-cast@ package -int2w32 :: Int -> Maybe Word32 -int2w32 j - | j < 0 = Nothing - | intLargerThanWord32, j > maxI = Nothing - | otherwise = Just $! fromIntegral j +---------------------------------------------------------------------------- + +toSizeM :: String -> Int -> PutM Word32 +toSizeM label len0 = maybe (fail label) pure (int2w32 len0) where - intLargerThanWord32 = not (maxI < (0 `asTypeOf` j)) - maxI = fromIntegral (maxBound :: Word32) + -- TODO: switch to @int-cast@ package + int2w32 :: Int -> Maybe Word32 + int2w32 j + | j < 0 = Nothing + | intLargerThanWord32, j > maxI = Nothing + | otherwise = Just $! fromIntegral j + where + intLargerThanWord32 = not (maxI < (0 `asTypeOf` j)) + maxI = fromIntegral (maxBound :: Word32) From 592bd4c4cc87035deaf7265f3e70a6f078203c99 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 17:20:48 +0100 Subject: [PATCH 45/75] Major refactoring of Data.MessagePack.Get module Do the respective changes done for `.Put` (see 5fcad275ad7a7d40417fbb596b1b46cd85e81dc0 and b851490bf7e5b1fdc08c9432ffdb1051cdd84762) for `.Get` --- msgpack/src/Data/MessagePack/Get.hs | 227 +++++++++++---------------- msgpack/src/Data/MessagePack/Tags.hs | 25 ++- 2 files changed, 115 insertions(+), 137 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 478b4db..8ae7cbd 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} -------------------------------------------------------------------- -- | @@ -14,53 +15,51 @@ module Data.MessagePack.Get( getNil, getBool, getFloat, getDouble, getInt, getWord, getInt64, getWord64, - getStr, getBin, getArray, getMap, getExt, + getStr, getBin, getArray, getMap, getExt, getExt' ) where import Control.Applicative import Control.Monad import Data.Binary -import Data.Binary.Get (getByteString, getWord16be, getWord32be, - getWord64be) -import Data.Binary.IEEE754 (getFloat32be, getFloat64be) -import Data.Bits -import qualified Data.ByteString as S +import Data.Binary.Get (getByteString, getWord16be, + getWord32be) +import Data.Binary.IEEE754 (getFloat32be, getFloat64be) +import qualified Data.ByteString as S import Data.Int -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V + +import Data.MessagePack.Integer +import Data.MessagePack.Tags getNil :: Get () -getNil = tag 0xC0 +getNil = tag TAG_nil getBool :: Get Bool getBool = getWord8 >>= \case - 0xC2 -> return False - 0xC3 -> return True + TAG_false -> return False + TAG_true -> return True + _ -> empty - _ -> empty +getFloat :: Get Float +getFloat = tag TAG_float32 >> getFloat32be + +getDouble :: Get Double +getDouble = tag TAG_float64 >> getFloat64be + +-- local helper for single-tag decoders +tag :: Word8 -> Get () +tag t = do { b <- getWord8; guard (t == b) } -- | Deserialize an integer into an 'Int' -- --- __WARNING__: Currently this function silently wraps around integers to make them fit into an 'Int'. This will be changed in the next major version (i.e. @msgpack-1.1.0@). +-- 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 = - 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 +getInt = maybe empty pure =<< fromMPInteger <$> get -- | Deserialize an integer into a 'Word' -- @@ -68,16 +67,7 @@ getInt = -- -- @since 1.0.1.0 getWord :: Get Word -getWord - | maxWord == maxBound = fromIntegral <$> getWord64 - | otherwise = do - w <- getWord64 - if w <= maxWord - then return (fromIntegral w) - else empty - where - maxWord :: Word64 - maxWord = fromIntegral (maxBound :: Word) +getWord = maybe empty pure =<< fromMPInteger <$> get -- | Deserialize an integer into an 'Int64' -- @@ -85,24 +75,7 @@ getWord -- -- @since 1.0.1.0 getInt64 :: Get Int64 -getInt64 = - getWord8 >>= \case - c | c .&. 0x80 == 0x00 -> return $ fromIntegral c - | c .&. 0xE0 == 0xE0 -> return $ fromIntegral (fromIntegral c :: Int8) - - 0xCC -> fromIntegral <$> getWord8 - 0xCD -> fromIntegral <$> getWord16be - 0xCE -> fromIntegral <$> getWord32be - 0xCF -> do - x <- fromIntegral <$> getWord64be - if x >= 0 then return x else empty - - 0xD0 -> fromIntegral <$> getInt8 - 0xD1 -> fromIntegral <$> getInt16be - 0xD2 -> fromIntegral <$> getInt32be - 0xD3 -> getInt64be - - _ -> empty +getInt64 = maybe empty pure =<< fromMPInteger <$> get -- | Deserialize an integer into a 'Word' -- @@ -110,40 +83,19 @@ getInt64 = -- -- @since 1.0.1.0 getWord64 :: Get Word64 -getWord64 = - getWord8 >>= \case - c | c .&. 0x80 == 0x00 -> return $ fromIntegral c - | c .&. 0xE0 == 0xE0 -> return $ fromIntegral (fromIntegral c :: Int8) - - 0xCC -> fromIntegral <$> getWord8 - 0xCD -> fromIntegral <$> getWord16be - 0xCE -> fromIntegral <$> getWord32be - 0xCF -> getWord64be - - 0xD0 -> do { x <- getInt8 ; if x >= 0 then return (fromIntegral x) else empty } - 0xD1 -> do { x <- getInt16be ; if x >= 0 then return (fromIntegral x) else empty } - 0xD2 -> do { x <- getInt32be ; if x >= 0 then return (fromIntegral x) else empty } - 0xD3 -> do { x <- getInt64be ; if x >= 0 then return (fromIntegral x) else empty } - - _ -> empty - - -getFloat :: Get Float -getFloat = tag 0xCA >> getFloat32be - -getDouble :: Get Double -getDouble = tag 0xCB >> getFloat64be +getWord64 = maybe empty pure =<< fromMPInteger <$> get getStr :: Get T.Text getStr = do len <- getWord8 >>= \case - t | t .&. 0xE0 == 0xA0 -> - return $ fromIntegral $ t .&. 0x1F - 0xD9 -> fromIntegral <$> getWord8 - 0xDA -> fromIntegral <$> getWord16be - 0xDB -> fromIntegral <$> getWord32be - _ -> empty - bs <- getByteString len + t | Just sz <- is_TAG_fixstr t -> pure sz + TAG_str8 -> fromIntegral <$> getWord8 + TAG_str16 -> fromIntegral <$> getWord16be + TAG_str32 -> getWord32be + _ -> empty + + len' <- fromSizeM "getStr: data exceeds capacity of ByteString/Text" len + bs <- getByteString len' case T.decodeUtf8' bs of Left _ -> empty Right v -> return v @@ -151,60 +103,65 @@ getStr = do getBin :: Get S.ByteString getBin = do len <- getWord8 >>= \case - 0xC4 -> fromIntegral <$> getWord8 - 0xC5 -> fromIntegral <$> getWord16be - 0xC6 -> fromIntegral <$> getWord32be - _ -> empty - getByteString len + TAG_bin8 -> fromIntegral <$> getWord8 + TAG_bin16 -> fromIntegral <$> getWord16be + TAG_bin32 -> getWord32be + _ -> empty + len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len + getByteString len' 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 + t | Just sz <- is_TAG_fixarray t -> pure sz + TAG_array16 -> fromIntegral <$> getWord16be + TAG_array32 -> getWord32be + _ -> empty + len' <- fromSizeM "getArray: data exceeds capacity of Vector" len + V.replicateM len' g 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 + t | Just sz <- is_TAG_fixmap t -> pure sz + TAG_map16 -> fromIntegral <$> getWord16be + TAG_map32 -> getWord32be + _ -> empty + len' <- fromSizeM "getMap: data exceeds capacity of Vector" len + V.replicateM len' $ (,) <$> k <*> v getExt :: Get (Word8, S.ByteString) -getExt = do - len <- getWord8 >>= \case - 0xD4 -> return 1 - 0xD5 -> return 2 - 0xD6 -> return 4 - 0xD7 -> return 8 - 0xD8 -> return 16 - 0xC7 -> fromIntegral <$> getWord8 - 0xC8 -> fromIntegral <$> getWord16be - 0xC9 -> fromIntegral <$> getWord32be - _ -> empty - (,) <$> getWord8 <*> getByteString len - -tag :: Word8 -> Get () -tag t = do - b <- getWord8 - guard $ t == b - --- internal helpers for operations missing from older `binary` versions -getInt8 :: Get Int8 -getInt8 = fromIntegral <$> getWord8 +getExt = getExt' $ \typ len -> do + len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len + (,) typ <$> getByteString len' -getInt16be :: Get Int16 -getInt16be = fromIntegral <$> getWord16be - -getInt32be :: Get Int32 -getInt32be = fromIntegral <$> getWord32be - -getInt64be :: Get Int64 -getInt64be = fromIntegral <$> getWord64be +-- | @since 1.1.0.0 +getExt' :: (Word8 -> Word32 -> Get a) -> Get a +getExt' getdat = do + len <- getWord8 >>= \case + TAG_fixext1 -> return 1 + TAG_fixext2 -> return 2 + TAG_fixext4 -> return 4 + TAG_fixext8 -> return 8 + TAG_fixext16 -> return 16 + TAG_ext8 -> fromIntegral <$> getWord8 + TAG_ext16 -> fromIntegral <$> getWord16be + TAG_ext32 -> getWord32be + _ -> empty + typ <- getWord8 + getdat typ len + +fromSizeM :: String -> Word32 -> Get Int +fromSizeM label sz = maybe (fail label) pure (intFromW32 sz) + where + -- TODO: switch to @int-cast@ package + intFromW32 :: Word32 -> Maybe Int + intFromW32 w + | intLargerThanWord32 = Just $! j + | w > maxW = Nothing + | otherwise = Just $! j + where + j = fromIntegral w + intLargerThanWord32 = not (maxI < (0 :: Int)) + maxI = fromIntegral (maxBound :: Word32) + maxW = fromIntegral (maxBound :: Int) diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs index 481bf1d..7cf2866 100644 --- a/msgpack/src/Data/MessagePack/Tags.hs +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -16,8 +16,8 @@ -- module Data.MessagePack.Tags where -import Data.Bits ((.&.)) -import Data.Word (Word8) +import Data.Bits (complement, (.&.)) +import Data.Word -- | Test whether tag is a fixint is_TAG_fixint :: Word8 -> Bool @@ -31,12 +31,33 @@ 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 $! fromIntegral (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 $! fromIntegral (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 $! fromIntegral (t .&. complement TAG_MASK_fixstr) + | otherwise = Nothing +{-# INLINE is_TAG_fixstr #-} + pattern TAG_fixstr = 0xa0 -- 0b101xxxxx [0xa0 .. 0xbf] pattern TAG_MASK_fixstr = 0xe0 -- 0b11100000 From 0323c38af8c9c44202ab87791999f81dfbeadb4f Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 17:43:42 +0100 Subject: [PATCH 46/75] Refactor `Data.MessagePack.Object` - Change `ObjectInt` to use properly round-trip-able `MPInteger` type instead of `Int` - Document 32-bit-size-limits of MessagePack - Add `MessagePack` instances for all fixed-size `Data.{Word,Int}` types --- msgpack/src/Data/MessagePack/Object.hs | 144 +++++++++++++++++++------ 1 file changed, 114 insertions(+), 30 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 3e634be..18ef1a4 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -17,7 +17,7 @@ -- -------------------------------------------------------------------- -module Data.MessagePack.Object( +module Data.MessagePack.Object ( -- * MessagePack Object Object(..), @@ -29,48 +29,63 @@ import Control.Applicative import Control.Arrow import Control.DeepSeq import Data.Binary -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 qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Lazy 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 Data.Int +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT import Data.Typeable -import qualified Data.Vector as V -import GHC.Generics (Generic) +import qualified Data.Vector as V +import GHC.Generics (Generic) import Data.MessagePack.Assoc import Data.MessagePack.Get +import Data.MessagePack.Integer import Data.MessagePack.Put -import Prelude hiding (putStr) +import Prelude hiding (putStr) + -- | Object Representation of MessagePack data. +-- +-- @since 1.1.0.0 data Object = ObjectNil -- ^ represents nil | ObjectBool !Bool -- ^ represents true or false - | ObjectInt {-# UNPACK #-} !Int - -- ^ represents an integer + | 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 -- ^ represents a floating point number | ObjectStr !T.Text - -- ^ extending Raw type represents a UTF-8 string + -- ^ represents an UTF-8 string + -- + -- __NOTE__: MessagePack is limited to maximum UTF-8 encoded size of \( 2^{32}-1 \) octets. | ObjectBin !S.ByteString - -- ^ extending Raw type represents a byte array + -- ^ 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)) -- ^ represents key-value pairs of objects + -- + -- __NOTE__: MessagePack is limited to maximum of \( 2^{32}-1 \) map entries. | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString -- ^ represents a tuple of an integer and a byte array where -- the integer represents type information and the byte array represents data. + -- + -- __NOTE__: MessagePack is limited to maximum data size of \( 2^{32}-1 \) bytes. deriving (Show, Read, Eq, Ord, Typeable, Generic) instance NFData Object where @@ -83,7 +98,7 @@ getObject :: Get Object getObject = ObjectNil <$ getNil <|> ObjectBool <$> getBool - <|> ObjectInt <$> getInt + <|> ObjectInt <$> get <|> ObjectFloat <$> getFloat <|> ObjectDouble <$> getDouble <|> ObjectStr <$> getStr @@ -96,7 +111,7 @@ 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 ObjectStr t -> putStr t @@ -129,37 +144,106 @@ instance MessagePack () where ObjectNil -> Just () _ -> Nothing -instance MessagePack Int where +instance MessagePack Bool where + toObject = ObjectBool + fromObject = \case + ObjectBool b -> Just b + _ -> Nothing + +---------------------------------------------------------------------------- + +-- | @since 1.1.0.0 +instance MessagePack MPInteger where toObject = ObjectInt fromObject = \case ObjectInt n -> Just n _ -> Nothing +-- | @since 1.1.0.0 instance MessagePack Word64 where - toObject = ObjectInt . fromIntegral -- FIXME + toObject = ObjectInt . toMPInteger fromObject = \case - ObjectInt n -> Just (fromIntegral n) -- FIXME + ObjectInt n -> fromMPInteger n _ -> Nothing -instance MessagePack Bool where - toObject = ObjectBool +-- | @since 1.1.0.0 +instance MessagePack Word32 where + toObject = ObjectInt . toMPInteger fromObject = \case - ObjectBool b -> Just b - _ -> Nothing + ObjectInt n -> fromMPInteger n + _ -> Nothing + +-- | @since 1.1.0.0 +instance MessagePack Word16 where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +-- | @since 1.1.0.0 +instance MessagePack Word8 where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +-- | @since 1.1.0.0 +instance MessagePack Word where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + + +-- | @since 1.1.0.0 +instance MessagePack Int64 where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +-- | @since 1.1.0.0 +instance MessagePack Int32 where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +-- | @since 1.1.0.0 +instance MessagePack Int16 where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +-- | @since 1.1.0.0 +instance MessagePack Int8 where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +instance MessagePack Int where + toObject = ObjectInt . toMPInteger + fromObject = \case + ObjectInt n -> fromMPInteger n + _ -> Nothing + +---------------------------------------------------------------------------- instance MessagePack Float where toObject = ObjectFloat fromObject = \case - ObjectInt n -> Just $ fromIntegral n + ObjectInt n -> Just $! fromIntegral n ObjectFloat f -> Just f - ObjectDouble d -> Just $ realToFrac d + ObjectDouble d -> Just $! realToFrac d _ -> Nothing instance MessagePack Double where toObject = ObjectDouble fromObject = \case - ObjectInt n -> Just $ fromIntegral n - ObjectFloat f -> Just $ realToFrac f + ObjectInt n -> Just $! fromIntegral n + ObjectFloat f -> Just $! realToFrac f ObjectDouble d -> Just d _ -> Nothing From cb4927eb452381fe4b92458c75b701d339b4ec88 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 17:57:37 +0100 Subject: [PATCH 47/75] Add support for MessagePack timestamps --- msgpack/msgpack.cabal | 2 + msgpack/src/Data/MessagePack/Tags.hs | 4 + msgpack/src/Data/MessagePack/Timestamp.hs | 213 ++++++++++++++++++++++ 3 files changed, 219 insertions(+) create mode 100644 msgpack/src/Data/MessagePack/Timestamp.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index a561e6f..cd2c328 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -43,6 +43,7 @@ library Data.MessagePack.Assoc Data.MessagePack.Generic Data.MessagePack.Integer + Data.MessagePack.Timestamp Data.MessagePack.Object Data.MessagePack.Get Data.MessagePack.Put @@ -60,6 +61,7 @@ library , deepseq >= 1.3 && < 1.5 , binary >= 0.7.1 && < 0.9 , data-binary-ieee754 >= 0.4.4 && < 0.5 + , time >= 1.4.2 && < 1.9 ghc-options: -Wall diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs index 7cf2866..51b7ec3 100644 --- a/msgpack/src/Data/MessagePack/Tags.hs +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -102,3 +102,7 @@ pattern TAG_array32 = 0xdd -- 0b11011101 pattern TAG_map16 = 0xde -- 0b11011110 pattern TAG_map32 = 0xdf -- 0b11011111 + +-- used by "Data.MessagePack.Timestamp" +pattern XTAG_Timestamp = 0xff + diff --git a/msgpack/src/Data/MessagePack/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs new file mode 100644 index 0000000..506f334 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -0,0 +1,213 @@ +{-# 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 Control.Applicative +import Control.DeepSeq (NFData (rnf)) +import Control.Monad +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin +import qualified Data.Binary.Put as Bin +import Data.Bits +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Fixed +import Data.Int +import qualified Data.Time.Clock as Time +import qualified Data.Time.Clock.POSIX as Time +import Data.Word + +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) + +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 + _ -> Nothing + +-- helpers for 'MessagePack' instance +mptsEncode :: MPTimestamp -> S.ByteString +mptsEncode = L.toStrict . Bin.runPut . snd . mptsPutExtData + +mptsDecode :: S.ByteString -> Maybe MPTimestamp +mptsDecode bs = runGet' bs (mptsGetExtData (fromIntegral $ S.length bs)) -- FIXME: overflow-check + +runGet' :: S.ByteString -> Bin.Get a -> Maybe a +runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of + Bin.Done bs _ x + | S.null bs -> pure x + | otherwise -> fail "trailing data" + Bin.Partial _ -> fail "eof" + Bin.Fail _ _ msg -> fail msg + +-- | 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, 0 <= sec, sec <= 0xffffffff = (4, Bin.putWord32be (fromIntegral sec)) + | 0 <= sec, sec <= 0x3ffffffff = (8, do + let s' = ((fromIntegral ns :: Word64) `shiftL` 34) .|. (fromIntegral sec) + Bin.putWord64be s') + | otherwise = (12, do + Bin.putWord32be ns + Bin.putWord64be (fromIntegral sec)) + +mptsGetExtData :: Word32 -> Bin.Get MPTimestamp +mptsGetExtData = \case + 4 -> do + s <- Bin.getWord32be + pure $! MPTimestamp (fromIntegral 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.getWord64be + when (ns > 999999999) $ fail "invalid nanosecond value" + pure $! MPTimestamp (fromIntegral s) ns + + _ -> fail "unsupported timestamp encoding" From f100e0902c5ed923cc2bef2696f6371a75e999c8 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 18:21:54 +0100 Subject: [PATCH 48/75] Refactor and extend msgpack:test:msgpack-tests This also makes use of the testsuite data imported in 6e105c48db0f20ca1dffeaff9b4d0160b3b18c26 --- msgpack/msgpack.cabal | 30 +++++++++- msgpack/test/DataCases.hs | 116 +++++++++++++++++++++++++++++++++++++ msgpack/test/Properties.hs | 89 ++++++++++++++++++++++++++++ msgpack/test/test.hs | 88 +++++++--------------------- 4 files changed, 256 insertions(+), 67 deletions(-) create mode 100644 msgpack/test/DataCases.hs create mode 100644 msgpack/test/Properties.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index cd2c328..cc4b4d9 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -26,7 +26,24 @@ copyright: Copyright (c) Hideyuki Tanaka 2009-2015, category: Data build-type: Simple -extra-source-files: CHANGES.md +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 @@ -74,13 +91,24 @@ test-suite msgpack-tests hs-source-dirs: test main-is: test.hs + other-modules: Properties + DataCases + + ghc-options: -Wall build-depends: msgpack -- inherited constraints via `msgpack` , base + , binary , bytestring + , 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.12.* diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs new file mode 100644 index 0000000..eec6120 --- /dev/null +++ b/msgpack/test/DataCases.hs @@ -0,0 +1,116 @@ +{-# 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.Monoid (mempty) +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 +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 Just 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 = 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 = mempty + | 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/Properties.hs b/msgpack/test/Properties.hs new file mode 100644 index 0000000..80896ff --- /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 = fromJust . 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/test.hs b/msgpack/test/test.hs index a659aa8..159ea6f 100644 --- a/msgpack/test/test.hs +++ b/msgpack/test/test.hs @@ -1,72 +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 "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 "(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 "maybe (Int,Bool,String)" $ - \(a :: (Maybe ((),Maybe Int,Maybe Float,Maybe Bool,Maybe Double,Maybe String))) -> 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 ]) From a8fe8c39e69f8ad06b6a6724ca4f9eacbb7d8c85 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 19:31:57 +0100 Subject: [PATCH 49/75] Introduce "Compat.Binary" compat-layer This also renders the dependency on `data-binary-ieee754` redundant --- msgpack/msgpack.cabal | 3 +- msgpack/src/Compat/Binary.hs | 74 +++++++++++++++++++++++ msgpack/src/Data/MessagePack/Get.hs | 5 +- msgpack/src/Data/MessagePack/Integer.hs | 9 +-- msgpack/src/Data/MessagePack/Object.hs | 3 +- msgpack/src/Data/MessagePack/Put.hs | 6 +- msgpack/src/Data/MessagePack/Timestamp.hs | 17 +----- 7 files changed, 83 insertions(+), 34 deletions(-) create mode 100644 msgpack/src/Compat/Binary.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index cc4b4d9..dd6f491 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -66,6 +66,7 @@ library Data.MessagePack.Put other-modules: Data.MessagePack.Tags + Compat.Binary build-depends: base >= 4.7 && < 4.13 , mtl >= 2.1.3.1 && < 2.3 @@ -77,8 +78,8 @@ library , vector >= 0.10.11 && < 0.13 , deepseq >= 1.3 && < 1.5 , binary >= 0.7.1 && < 0.9 - , data-binary-ieee754 >= 0.4.4 && < 0.5 , time >= 1.4.2 && < 1.9 + , array >= 0.5.0 && < 0.6 ghc-options: -Wall diff --git a/msgpack/src/Compat/Binary.hs b/msgpack/src/Compat/Binary.hs new file mode 100644 index 0000000..c28f162 --- /dev/null +++ b/msgpack/src/Compat/Binary.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Compat layer for "Data.Binary" +-- +-- Supports @binary-0.7.1@ and later +module Compat.Binary + ( Binary(put, get) + + , runPut', runPut, PutM, Put + , runGet', runGet, Get + + , getWord64be, putWord64be + , getWord32be, putWord32be + , getWord16be, putWord16be + , getWord8 , putWord8 + + , getFloat32be, putFloat32be + , getFloat64be, putFloat64be + + , getByteString, putByteString + + -- convenience + , Data.Word.Word, Word8, Word16, Word32, Word64 + , Data.Int.Int, Int8, Int16, Int32, Int64 + ) where + +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 +import Data.Binary.Get +import Data.Binary.Put +import Data.Int +import Data.Word +import GHC.ST (ST, runST) + + +runGet' :: BS.ByteString -> Get a -> Maybe a +runGet' bs0 g = case pushEndOfInput (runGetIncremental g `pushChunk` bs0) of + Done bs _ x + | BS.null bs -> return x + | otherwise -> fail "trailing data" + Partial _ -> fail "eof" + Fail _ _ msg -> fail msg + +runPut' :: Put -> BS.ByteString +runPut' = BL.toStrict . runPut + + +-- 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 = putWord32be (runST (cast x)) + +putFloat64be :: Double -> Put +putFloat64be x = putWord64be (runST (cast x)) + +getFloat32be :: Get Float +getFloat32be = do + x <- getWord32be + return (runST (cast x)) + +getFloat64be :: Get Double +getFloat64be = do + x <- 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/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 8ae7cbd..f933ace 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -20,16 +20,13 @@ module Data.MessagePack.Get( import Control.Applicative import Control.Monad -import Data.Binary -import Data.Binary.Get (getByteString, getWord16be, - getWord32be) -import Data.Binary.IEEE754 (getFloat32be, getFloat64be) import qualified Data.ByteString as S import Data.Int import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V +import Compat.Binary import Data.MessagePack.Integer import Data.MessagePack.Tags diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs index 9666b82..eaa0a78 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -20,15 +20,8 @@ import Control.Applicative import Control.DeepSeq (NFData (rnf)) import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), throw) -import Data.Int -import Data.Word - -import Data.Binary (Binary (get, put)) -import Data.Binary.Get (Get, getWord16be, getWord32be, - getWord64be, getWord8) -import Data.Binary.Put (Put, putWord16be, putWord32be, - putWord64be, putWord8) +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] \). diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 18ef1a4..c415f7e 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -28,7 +28,6 @@ module Data.MessagePack.Object ( import Control.Applicative import Control.Arrow import Control.DeepSeq -import Data.Binary import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Short as SBS @@ -48,6 +47,8 @@ import Data.MessagePack.Get import Data.MessagePack.Integer import Data.MessagePack.Put +import Compat.Binary + import Prelude hiding (putStr) diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 0f3427b..53f4107 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -18,19 +18,15 @@ module Data.MessagePack.Put ( ) where import Control.Applicative -import Data.Binary -import Data.Binary.IEEE754 (putFloat32be, putFloat64be) -import Data.Binary.Put (PutM, putByteString, putWord16be, - putWord32be) import Data.Bits import qualified Data.ByteString as S -import Data.Int import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V import Prelude hiding (putStr) +import Compat.Binary import Data.MessagePack.Integer import Data.MessagePack.Tags diff --git a/msgpack/src/Data/MessagePack/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs index 506f334..740e9d4 100644 --- a/msgpack/src/Data/MessagePack/Timestamp.hs +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -28,18 +28,13 @@ module Data.MessagePack.Timestamp import Control.Applicative import Control.DeepSeq (NFData (rnf)) import Control.Monad -import qualified Data.Binary as Bin -import qualified Data.Binary.Get as Bin -import qualified Data.Binary.Put as Bin import Data.Bits import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import Data.Fixed -import Data.Int import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time -import Data.Word +import Compat.Binary as Bin import Data.MessagePack.Get import Data.MessagePack.Object import Data.MessagePack.Put @@ -160,19 +155,11 @@ instance MessagePack MPTimestamp where -- helpers for 'MessagePack' instance mptsEncode :: MPTimestamp -> S.ByteString -mptsEncode = L.toStrict . Bin.runPut . snd . mptsPutExtData +mptsEncode = runPut' . snd . mptsPutExtData mptsDecode :: S.ByteString -> Maybe MPTimestamp mptsDecode bs = runGet' bs (mptsGetExtData (fromIntegral $ S.length bs)) -- FIXME: overflow-check -runGet' :: S.ByteString -> Bin.Get a -> Maybe a -runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of - Bin.Done bs _ x - | S.null bs -> pure x - | otherwise -> fail "trailing data" - Bin.Partial _ -> fail "eof" - Bin.Fail _ _ msg -> fail msg - -- | This 'Binary' instance encodes\/decodes to\/from MessagePack format instance Bin.Binary MPTimestamp where get = getExt' $ \typ sz -> do From ffcf9043350b183031a6b18ea1606f5ad5de03fd Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 20:59:37 +0100 Subject: [PATCH 50/75] Leverage `int-cast` for statically checked int conversions This reduces the amount of `fromIntegral` conversions that need to be audited by humans... --- msgpack/msgpack.cabal | 1 + msgpack/src/Compat/Binary.hs | 79 +++++++++++++++++------ msgpack/src/Data/MessagePack/Get.hs | 31 +++------ msgpack/src/Data/MessagePack/Integer.hs | 76 +++++++++------------- msgpack/src/Data/MessagePack/Put.hs | 13 +--- msgpack/src/Data/MessagePack/Tags.hs | 9 +-- msgpack/src/Data/MessagePack/Timestamp.hs | 19 +++--- 7 files changed, 120 insertions(+), 108 deletions(-) diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index dd6f491..92f13e0 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -79,6 +79,7 @@ library , deepseq >= 1.3 && < 1.5 , binary >= 0.7.1 && < 0.9 , time >= 1.4.2 && < 1.9 + , int-cast >= 0.1.1 && < 0.3 , array >= 0.5.0 && < 0.6 ghc-options: -Wall diff --git a/msgpack/src/Compat/Binary.hs b/msgpack/src/Compat/Binary.hs index c28f162..8a7b1a3 100644 --- a/msgpack/src/Compat/Binary.hs +++ b/msgpack/src/Compat/Binary.hs @@ -6,65 +6,106 @@ module Compat.Binary ( Binary(put, get) - , runPut', runPut, PutM, Put - , runGet', runGet, Get + , runPut', Bin.runPut, Bin.PutM, Put + , runGet', Bin.runGet, Get - , getWord64be, putWord64be - , getWord32be, putWord32be - , getWord16be, putWord16be - , getWord8 , putWord8 + , 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 - , getByteString, putByteString + , Bin.getByteString, Bin.putByteString -- convenience , Data.Word.Word, Word8, Word16, Word32, Word64 , Data.Int.Int, Int8, Int16, Int32, Int64 ) where +import Control.Applicative import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL +import Data.IntCast import Data.Array.ST (MArray, STUArray, newArray, readArray) import Data.Array.Unsafe (castSTUArray) -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put +import Data.Binary (Binary (get, put), Get, Put) +import qualified Data.Binary.Get as Bin +import qualified Data.Binary.Put as Bin import Data.Int import Data.Word import GHC.ST (ST, runST) runGet' :: BS.ByteString -> Get a -> Maybe a -runGet' bs0 g = case pushEndOfInput (runGetIncremental g `pushChunk` bs0) of - Done bs _ x +runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of + Bin.Done bs _ x | BS.null bs -> return x | otherwise -> fail "trailing data" - Partial _ -> fail "eof" - Fail _ _ msg -> fail msg + Bin.Partial _ -> fail "eof" + Bin.Fail _ _ msg -> fail msg runPut' :: Put -> BS.ByteString -runPut' = BL.toStrict . runPut +runPut' = BL.toStrict . Bin.runPut + + +-- 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 = putWord32be (runST (cast x)) +putFloat32be x = Bin.putWord32be (runST (cast x)) putFloat64be :: Double -> Put -putFloat64be x = putWord64be (runST (cast x)) +putFloat64be x = Bin.putWord64be (runST (cast x)) getFloat32be :: Get Float getFloat32be = do - x <- getWord32be + x <- Bin.getWord32be return (runST (cast x)) getFloat64be :: Get Double getFloat64be = do - x <- getWord64be + 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 diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index f933ace..e3c3019 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -22,6 +22,7 @@ import Control.Applicative import Control.Monad import qualified Data.ByteString as S import Data.Int +import Data.IntCast import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V @@ -86,8 +87,8 @@ getStr :: Get T.Text getStr = do len <- getWord8 >>= \case t | Just sz <- is_TAG_fixstr t -> pure sz - TAG_str8 -> fromIntegral <$> getWord8 - TAG_str16 -> fromIntegral <$> getWord16be + TAG_str8 -> intCast <$> getWord8 + TAG_str16 -> intCast <$> getWord16be TAG_str32 -> getWord32be _ -> empty @@ -100,8 +101,8 @@ getStr = do getBin :: Get S.ByteString getBin = do len <- getWord8 >>= \case - TAG_bin8 -> fromIntegral <$> getWord8 - TAG_bin16 -> fromIntegral <$> getWord16be + TAG_bin8 -> intCast <$> getWord8 + TAG_bin16 -> intCast <$> getWord16be TAG_bin32 -> getWord32be _ -> empty len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len @@ -111,7 +112,7 @@ getArray :: Get a -> Get (V.Vector a) getArray g = do len <- getWord8 >>= \case t | Just sz <- is_TAG_fixarray t -> pure sz - TAG_array16 -> fromIntegral <$> getWord16be + TAG_array16 -> intCast <$> getWord16be TAG_array32 -> getWord32be _ -> empty len' <- fromSizeM "getArray: data exceeds capacity of Vector" len @@ -121,7 +122,7 @@ getMap :: Get a -> Get b -> Get (V.Vector (a, b)) getMap k v = do len <- getWord8 >>= \case t | Just sz <- is_TAG_fixmap t -> pure sz - TAG_map16 -> fromIntegral <$> getWord16be + TAG_map16 -> intCast <$> getWord16be TAG_map32 -> getWord32be _ -> empty len' <- fromSizeM "getMap: data exceeds capacity of Vector" len @@ -141,24 +142,12 @@ getExt' getdat = do TAG_fixext4 -> return 4 TAG_fixext8 -> return 8 TAG_fixext16 -> return 16 - TAG_ext8 -> fromIntegral <$> getWord8 - TAG_ext16 -> fromIntegral <$> getWord16be + TAG_ext8 -> intCast <$> getWord8 + TAG_ext16 -> intCast <$> getWord16be TAG_ext32 -> getWord32be _ -> empty typ <- getWord8 getdat typ len fromSizeM :: String -> Word32 -> Get Int -fromSizeM label sz = maybe (fail label) pure (intFromW32 sz) - where - -- TODO: switch to @int-cast@ package - intFromW32 :: Word32 -> Maybe Int - intFromW32 w - | intLargerThanWord32 = Just $! j - | w > maxW = Nothing - | otherwise = Just $! j - where - j = fromIntegral w - intLargerThanWord32 = not (maxI < (0 :: Int)) - maxI = fromIntegral (maxBound :: Word32) - maxW = fromIntegral (maxBound :: 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 index eaa0a78..c5a499c 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -20,6 +20,7 @@ import Control.Applicative import Control.DeepSeq (NFData (rnf)) import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), throw) +import Data.IntCast import Compat.Binary import Data.MessagePack.Tags @@ -40,20 +41,20 @@ data MPInteger = MPInteger {- isW64 -} !Bool -- NB: only valid if isW64 is true toW64 :: Int64 -> Word64 -toW64 = fromIntegral +toW64 = intCastIso class ToMPInteger a where toMPInteger :: a -> MPInteger -instance ToMPInteger Int8 where toMPInteger i = MPInteger False (fromIntegral i) -instance ToMPInteger Int16 where toMPInteger i = MPInteger False (fromIntegral i) -instance ToMPInteger Int32 where toMPInteger i = MPInteger False (fromIntegral i) +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 (fromIntegral i) +instance ToMPInteger Int where toMPInteger i = MPInteger False (intCast i) -instance ToMPInteger Word8 where toMPInteger w = MPInteger False (fromIntegral w) -instance ToMPInteger Word16 where toMPInteger w = MPInteger False (fromIntegral w) -instance ToMPInteger Word32 where toMPInteger w = MPInteger False (fromIntegral w) +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 @@ -67,36 +68,30 @@ class FromMPInteger a where fromMPInteger :: MPInteger -> Maybe a instance FromMPInteger Word where - fromMPInteger (MPInteger isW64 i) - | 0 <= i || isW64 - , toW64 i <= maxW = Just $! fromIntegral i - | otherwise = Nothing - where - maxW = fromIntegral (maxBound :: Word) :: Word64 + 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) - | 0 <= i = Just (toW64 i) - | otherwise = Nothing + 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) = int64toInt i + fromMPInteger (MPInteger False i) = intCastMaybe i instance FromMPInteger Word16 where fromMPInteger (MPInteger True _) = Nothing - fromMPInteger (MPInteger False i) = int64toInt i + fromMPInteger (MPInteger False i) = intCastMaybe i instance FromMPInteger Word8 where fromMPInteger (MPInteger True _) = Nothing - fromMPInteger (MPInteger False i) = int64toInt i + fromMPInteger (MPInteger False i) = intCastMaybe i ----- instance FromMPInteger Int where fromMPInteger (MPInteger True _) = Nothing - fromMPInteger (MPInteger False i) = int64toInt i + fromMPInteger (MPInteger False i) = intCastMaybe i instance FromMPInteger Int64 where fromMPInteger (MPInteger True _) = Nothing @@ -104,24 +99,15 @@ instance FromMPInteger Int64 where instance FromMPInteger Int32 where fromMPInteger (MPInteger True _) = Nothing - fromMPInteger (MPInteger False i) = int64toInt i + fromMPInteger (MPInteger False i) = intCastMaybe i instance FromMPInteger Int16 where fromMPInteger (MPInteger True _) = Nothing - fromMPInteger (MPInteger False i) = int64toInt i + fromMPInteger (MPInteger False i) = intCastMaybe i instance FromMPInteger Int8 where fromMPInteger (MPInteger True _) = Nothing - fromMPInteger (MPInteger False i) = int64toInt i - -{-# INLINE int64toInt #-} -int64toInt :: forall i . (Integral i, Bounded i) => Int64 -> Maybe i -int64toInt i - | minI <= i, i <= maxI = Just $! fromIntegral i - | otherwise = Nothing - where - minI = fromIntegral (minBound :: i) :: Int64 - maxI = fromIntegral (maxBound :: i) :: Int64 + fromMPInteger (MPInteger False i) = intCastMaybe i ---------------------------------------------------------------------------- @@ -246,20 +232,20 @@ 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 = putWord8 (fromIntegral i) + | -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 (fromIntegral i) + | otherwise -> putWord8 TAG_uint64 >> putWord64be (intCastIso i) -- equivalent to 'putInt64be i' -- signed int encoding - | -0x80 <= i = putWord8 TAG_int8 >> putWord8 (fromIntegral i) - | -0x8000 <= i = putWord8 TAG_int16 >> putWord16be (fromIntegral i) - | -0x80000000 <= i = putWord8 TAG_int32 >> putWord32be (fromIntegral i) - | otherwise = putWord8 TAG_int64 >> putWord64be (fromIntegral i) + | -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 @@ -269,16 +255,16 @@ getMPInteger :: Get MPInteger getMPInteger = getWord8 >>= \case -- positive fixnum stores 7-bit positive integer -- negative fixnum stores 5-bit negative integer - c | is_TAG_fixint c -> pure $! toMPInteger (fromIntegral c :: Int8) + c | is_TAG_fixint c -> pure $! toMPInteger (intCastIso c :: Int8) TAG_uint8 -> toMPInteger <$> getWord8 TAG_uint16 -> toMPInteger <$> getWord16be TAG_uint32 -> toMPInteger <$> getWord32be TAG_uint64 -> toMPInteger <$> getWord64be - TAG_int8 -> toMPInteger <$> (fromIntegral <$> getWord8 :: Get Int8) - TAG_int16 -> toMPInteger <$> (fromIntegral <$> getWord16be :: Get Int16) - TAG_int32 -> toMPInteger <$> (fromIntegral <$> getWord32be :: Get Int32) - TAG_int64 -> toMPInteger <$> (fromIntegral <$> getWord64be :: Get Int64) + TAG_int8 -> toMPInteger <$> getInt8 + TAG_int16 -> toMPInteger <$> getInt16be + TAG_int32 -> toMPInteger <$> getInt32be + TAG_int64 -> toMPInteger <$> getInt64be _ -> empty diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 53f4107..20d21dd 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -20,6 +20,7 @@ module Data.MessagePack.Put ( import Control.Applicative import Data.Bits import qualified Data.ByteString as S +import Data.IntCast import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V @@ -121,14 +122,4 @@ putExt' typ (sz,putdat) = do ---------------------------------------------------------------------------- toSizeM :: String -> Int -> PutM Word32 -toSizeM label len0 = maybe (fail label) pure (int2w32 len0) - where - -- TODO: switch to @int-cast@ package - int2w32 :: Int -> Maybe Word32 - int2w32 j - | j < 0 = Nothing - | intLargerThanWord32, j > maxI = Nothing - | otherwise = Just $! fromIntegral j - where - intLargerThanWord32 = not (maxI < (0 `asTypeOf` j)) - maxI = fromIntegral (maxBound :: Word32) +toSizeM label len0 = maybe (fail label) pure (intCastMaybe len0) diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs index 51b7ec3..2871ef0 100644 --- a/msgpack/src/Data/MessagePack/Tags.hs +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -16,7 +16,8 @@ -- module Data.MessagePack.Tags where -import Data.Bits (complement, (.&.)) +import Data.Bits (complement, (.&.)) +import Data.IntCast import Data.Word -- | Test whether tag is a fixint @@ -34,7 +35,7 @@ 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 $! fromIntegral (t .&. complement TAG_MASK_fixmap) + | t .&. TAG_MASK_fixmap == TAG_fixmap = Just $! intCast (t .&. complement TAG_MASK_fixmap) | otherwise = Nothing {-# INLINE is_TAG_fixmap #-} @@ -44,7 +45,7 @@ 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 $! fromIntegral (t .&. complement TAG_MASK_fixarray) + | t .&. TAG_MASK_fixarray == TAG_fixarray = Just $! intCast (t .&. complement TAG_MASK_fixarray) | otherwise = Nothing {-# INLINE is_TAG_fixarray #-} @@ -54,7 +55,7 @@ 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 $! fromIntegral (t .&. complement TAG_MASK_fixstr) + | t .&. TAG_MASK_fixstr == TAG_fixstr = Just $! intCast (t .&. complement TAG_MASK_fixstr) | otherwise = Nothing {-# INLINE is_TAG_fixstr #-} diff --git a/msgpack/src/Data/MessagePack/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs index 740e9d4..29494e1 100644 --- a/msgpack/src/Data/MessagePack/Timestamp.hs +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -31,6 +31,7 @@ import Control.Monad import Data.Bits import qualified Data.ByteString as S import Data.Fixed +import Data.IntCast import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time @@ -158,7 +159,9 @@ mptsEncode :: MPTimestamp -> S.ByteString mptsEncode = runPut' . snd . mptsPutExtData mptsDecode :: S.ByteString -> Maybe MPTimestamp -mptsDecode bs = runGet' bs (mptsGetExtData (fromIntegral $ S.length bs)) -- FIXME: overflow-check +mptsDecode bs = do + len <- intCastMaybe (S.length bs) + runGet' bs (mptsGetExtData len) -- | This 'Binary' instance encodes\/decodes to\/from MessagePack format instance Bin.Binary MPTimestamp where @@ -170,31 +173,31 @@ instance Bin.Binary MPTimestamp where mptsPutExtData :: MPTimestamp -> (Word32,Bin.Put) mptsPutExtData (MPTimestamp sec ns) - | ns == 0, 0 <= sec, sec <= 0xffffffff = (4, Bin.putWord32be (fromIntegral sec)) + | ns == 0, Just sec' <- intCastMaybe sec = (4, Bin.putWord32be sec') | 0 <= sec, sec <= 0x3ffffffff = (8, do - let s' = ((fromIntegral ns :: Word64) `shiftL` 34) .|. (fromIntegral sec) + let s' = ((intCast ns :: Word64) `shiftL` 34) .|. (fromIntegral sec) Bin.putWord64be s') | otherwise = (12, do Bin.putWord32be ns - Bin.putWord64be (fromIntegral sec)) + Bin.putInt64be sec) mptsGetExtData :: Word32 -> Bin.Get MPTimestamp mptsGetExtData = \case 4 -> do s <- Bin.getWord32be - pure $! MPTimestamp (fromIntegral s) 0 + pure $! MPTimestamp (intCast s) 0 8 -> do dat <- Bin.getWord64be - let s = fromIntegral (dat .&. 0x3ffffffff) + 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.getWord64be + s <- Bin.getInt64be when (ns > 999999999) $ fail "invalid nanosecond value" - pure $! MPTimestamp (fromIntegral s) ns + pure $! MPTimestamp s ns _ -> fail "unsupported timestamp encoding" From ca04eb86fcccebed40b1a4d9a43ec93031c04c2d Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 23:15:07 +0100 Subject: [PATCH 51/75] Major ver bump of msgpack and msgpack-aeson as both have introduced backward-compat breaking changes since their respective previous releases Also fixup lower bounds --- cabal.project.floor-ghc-7.8.4 | 4 ++-- msgpack-aeson/msgpack-aeson.cabal | 6 +++--- msgpack-rpc/msgpack-rpc.cabal | 6 +++--- msgpack/msgpack.cabal | 6 +++--- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/cabal.project.floor-ghc-7.8.4 b/cabal.project.floor-ghc-7.8.4 index bb79495..b61c623 100644 --- a/cabal.project.floor-ghc-7.8.4 +++ b/cabal.project.floor-ghc-7.8.4 @@ -6,12 +6,12 @@ constraints: bytestring installed , binary installed , containers installed - , mtl == 2.1.3.1 + , 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.0.0 + , text == 1.2.3.0 , scientific == 0.3.2.0 , aeson == 0.8.0.2 , exceptions == 0.8 diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index 1cf55eb..c9a8d7c 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: msgpack-aeson -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Aeson adapter for MessagePack description: Aeson adapter for MessagePack @@ -27,9 +27,9 @@ library , aeson >= 0.8.0.2 && < 0.12 || >= 1.0 && < 1.5 , bytestring >= 0.10.4 && < 0.11 - , msgpack >= 1.0.0 && < 1.1 + , msgpack >= 1.1.0 && < 1.2 , scientific >= 0.3.2 && < 0.4 - , text >= 1.2 && < 1.3 + , text >= 1.2.3 && < 1.3 , unordered-containers >= 0.2.5 && < 0.3 , vector >= 0.10.11 && < 0.13 , deepseq >= 1.3 && < 1.5 diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index a0323ac..f4404e3 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -28,17 +28,17 @@ library build-depends: base >= 4.5 && < 4.13 , bytestring >= 0.10.4 && < 0.11 - , text >= 1.2 && < 1.3 + , text >= 1.2.3 && < 1.3 , network >= 2.6 && < 2.9 || >= 3.0 && < 3.1 - , mtl >= 2.1.3.1 && < 2.3 + , 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.0.0 && < 1.1 + , msgpack >= 1.0.0 && < 1.2 test-suite msgpack-rpc-test default-language: Haskell2010 diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 92f13e0..d59b293 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: msgpack -version: 1.0.1.0 +version: 1.1.0.0 synopsis: A Haskell implementation of MessagePack description: @@ -69,9 +69,9 @@ library Compat.Binary build-depends: base >= 4.7 && < 4.13 - , mtl >= 2.1.3.1 && < 2.3 + , mtl >= 2.2.1 && < 2.3 , bytestring >= 0.10.4 && < 0.11 - , text >= 1.2 && < 1.3 + , 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.3 From e5b864f53f0ec877bffa6379ef46ea639b6fbd23 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sat, 30 Mar 2019 23:50:39 +0100 Subject: [PATCH 52/75] Introduce local `Compat.Prelude` module --- msgpack/msgpack.cabal | 1 + msgpack/src/Compat/Binary.hs | 10 ++-------- msgpack/src/Compat/Prelude.hs | 15 +++++++++++++++ msgpack/src/Data/MessagePack/Assoc.hs | 3 +-- msgpack/src/Data/MessagePack/Generic.hs | 6 ++---- msgpack/src/Data/MessagePack/Get.hs | 6 ++---- msgpack/src/Data/MessagePack/Integer.hs | 5 ++--- msgpack/src/Data/MessagePack/Object.hs | 10 +++------- msgpack/src/Data/MessagePack/Put.hs | 8 +++----- msgpack/src/Data/MessagePack/Tags.hs | 4 +--- msgpack/src/Data/MessagePack/Timestamp.hs | 7 ++----- 11 files changed, 34 insertions(+), 41 deletions(-) create mode 100644 msgpack/src/Compat/Prelude.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index d59b293..3428fb5 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -67,6 +67,7 @@ library other-modules: Data.MessagePack.Tags Compat.Binary + Compat.Prelude build-depends: base >= 4.7 && < 4.13 , mtl >= 2.2.1 && < 2.3 diff --git a/msgpack/src/Compat/Binary.hs b/msgpack/src/Compat/Binary.hs index 8a7b1a3..01cb7f3 100644 --- a/msgpack/src/Compat/Binary.hs +++ b/msgpack/src/Compat/Binary.hs @@ -23,24 +23,18 @@ module Compat.Binary , getFloat64be, putFloat64be , Bin.getByteString, Bin.putByteString - - -- convenience - , Data.Word.Word, Word8, Word16, Word32, Word64 - , Data.Int.Int, Int8, Int16, Int32, Int64 ) where -import Control.Applicative +import Compat.Prelude + import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import Data.IntCast 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 Data.Int -import Data.Word import GHC.ST (ST, runST) diff --git a/msgpack/src/Compat/Prelude.hs b/msgpack/src/Compat/Prelude.hs new file mode 100644 index 0000000..01a4358 --- /dev/null +++ b/msgpack/src/Compat/Prelude.hs @@ -0,0 +1,15 @@ +-- | 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.Int as X +import Data.IntCast as X +import Data.Typeable as X (Typeable) +import Data.Word as X +import GHC.Generics as X (Generic) diff --git a/msgpack/src/Data/MessagePack/Assoc.hs b/msgpack/src/Data/MessagePack/Assoc.hs index 4d552fa..0146b71 100644 --- a/msgpack/src/Data/MessagePack/Assoc.hs +++ b/msgpack/src/Data/MessagePack/Assoc.hs @@ -19,8 +19,7 @@ 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) diff --git a/msgpack/src/Data/MessagePack/Generic.hs b/msgpack/src/Data/MessagePack/Generic.hs index f1c1a20..0ca34cc 100644 --- a/msgpack/src/Data/MessagePack/Generic.hs +++ b/msgpack/src/Data/MessagePack/Generic.hs @@ -12,10 +12,8 @@ module Data.MessagePack.Generic , genericFromObject ) where -import Control.Applicative -import Control.Monad ((>=>)) -import Data.Bits (shiftR) -import Data.Word (Word64) +import Compat.Prelude + import GHC.Generics import Data.MessagePack.Object diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index e3c3019..9296388 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -18,11 +18,9 @@ module Data.MessagePack.Get( getStr, getBin, getArray, getMap, getExt, getExt' ) where -import Control.Applicative -import Control.Monad +import Compat.Prelude + import qualified Data.ByteString as S -import Data.Int -import Data.IntCast import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs index c5a499c..2ce62a1 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -16,11 +16,10 @@ module Data.MessagePack.Integer , fromIntegerTry ) where -import Control.Applicative -import Control.DeepSeq (NFData (rnf)) +import Compat.Prelude + import Control.Exception (ArithException (DivideByZero, Overflow, Underflow), throw) -import Data.IntCast import Compat.Binary import Data.MessagePack.Tags diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index c415f7e..90a625b 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -25,22 +25,20 @@ module Data.MessagePack.Object ( MessagePack(..), ) where -import Control.Applicative +import Compat.Prelude +import Prelude hiding (putStr) + import Control.Arrow -import Control.DeepSeq 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 Data.Int import qualified Data.IntMap.Strict as IntMap import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Data.Typeable import qualified Data.Vector as V -import GHC.Generics (Generic) import Data.MessagePack.Assoc import Data.MessagePack.Get @@ -49,8 +47,6 @@ import Data.MessagePack.Put import Compat.Binary -import Prelude hiding (putStr) - -- | Object Representation of MessagePack data. -- diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 20d21dd..b7f5154 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -17,16 +17,14 @@ module Data.MessagePack.Put ( putStr, putBin, putArray, putMap, putExt, putExt' ) where -import Control.Applicative -import Data.Bits +import Compat.Prelude +import Prelude hiding (putStr) + import qualified Data.ByteString as S -import Data.IntCast import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V -import Prelude hiding (putStr) - import Compat.Binary import Data.MessagePack.Integer import Data.MessagePack.Tags diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs index 2871ef0..2124570 100644 --- a/msgpack/src/Data/MessagePack/Tags.hs +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -16,9 +16,7 @@ -- module Data.MessagePack.Tags where -import Data.Bits (complement, (.&.)) -import Data.IntCast -import Data.Word +import Compat.Prelude -- | Test whether tag is a fixint is_TAG_fixint :: Word8 -> Bool diff --git a/msgpack/src/Data/MessagePack/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs index 29494e1..3cc515b 100644 --- a/msgpack/src/Data/MessagePack/Timestamp.hs +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -25,13 +25,10 @@ module Data.MessagePack.Timestamp , mptsFromUTCTimeLossy ) where -import Control.Applicative -import Control.DeepSeq (NFData (rnf)) -import Control.Monad -import Data.Bits +import Compat.Prelude + import qualified Data.ByteString as S import Data.Fixed -import Data.IntCast import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time From 4098315f87d61e9c49984293ee8ee4c93328011d Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 14:42:58 +0200 Subject: [PATCH 53/75] Add missing `Typeable` instances --- msgpack/src/Data/MessagePack/Integer.hs | 3 ++- msgpack/src/Data/MessagePack/Timestamp.hs | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs index 2ce62a1..3426027 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -30,7 +31,7 @@ import Data.MessagePack.Tags -- This type can be unboxed (i.e. via @{-# UNPACK #-}@). data MPInteger = MPInteger {- isW64 -} !Bool {- value -} {-# UNPACK #-} !Int64 - deriving (Eq,Ord) + deriving (Eq,Ord,Typeable) -- NOTE: Internal invariant of 'MPInteger' -- diff --git a/msgpack/src/Data/MessagePack/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs index 3cc515b..b82fbb5 100644 --- a/msgpack/src/Data/MessagePack/Timestamp.hs +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,7 +45,7 @@ import Data.MessagePack.Tags -- -- @since 1.1.0.0 data MPTimestamp = MPTimestamp !Int64 !Word32 - deriving (Eq,Ord,Show,Read) + deriving (Eq,Ord,Show,Read,Typeable) instance Bounded MPTimestamp where minBound = MPTimestamp minBound 0 From ace79f93de75e81ffd742e6af646d6709032cfdd Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 14:55:27 +0200 Subject: [PATCH 54/75] Use more accurate `Int8` for representing extension type-ids --- msgpack/src/Data/MessagePack/Get.hs | 6 +++--- msgpack/src/Data/MessagePack/Object.hs | 9 ++++++--- msgpack/src/Data/MessagePack/Put.hs | 6 +++--- msgpack/src/Data/MessagePack/Tags.hs | 12 ++++++++---- 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 9296388..e2ed417 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -126,13 +126,13 @@ getMap k v = do len' <- fromSizeM "getMap: data exceeds capacity of Vector" len V.replicateM len' $ (,) <$> k <*> v -getExt :: Get (Word8, S.ByteString) +getExt :: Get (Int8, S.ByteString) getExt = getExt' $ \typ len -> do len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len (,) typ <$> getByteString len' -- | @since 1.1.0.0 -getExt' :: (Word8 -> Word32 -> Get a) -> Get a +getExt' :: (Int8 -> Word32 -> Get a) -> Get a getExt' getdat = do len <- getWord8 >>= \case TAG_fixext1 -> return 1 @@ -144,7 +144,7 @@ getExt' getdat = do TAG_ext16 -> intCast <$> getWord16be TAG_ext32 -> getWord32be _ -> empty - typ <- getWord8 + typ <- getInt8 getdat typ len fromSizeM :: String -> Word32 -> Get Int diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 90a625b..022accc 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -78,11 +78,14 @@ data Object -- ^ represents key-value pairs of objects -- -- __NOTE__: MessagePack is limited to maximum of \( 2^{32}-1 \) map entries. - | ObjectExt {-# UNPACK #-} !Word8 !S.ByteString + | ObjectExt {-# UNPACK #-} !Int8 !S.ByteString -- ^ represents a tuple of an integer and a byte array where - -- the integer represents type information and the byte array represents data. + -- 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. -- - -- __NOTE__: MessagePack is limited to maximum data size of \( 2^{32}-1 \) bytes. + -- 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) instance NFData Object where diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index b7f5154..0cd56f4 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -95,13 +95,13 @@ putMap p q xs = do 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 :: Word8 -> S.ByteString -> Put +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' :: Word8 -- ^ type-tag of extended data +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 @@ -114,7 +114,7 @@ putExt' typ (sz,putdat) = do len | len < 0x100 -> putWord8 TAG_ext8 >> putWord8 (fromIntegral len) | len < 0x10000 -> putWord8 TAG_ext16 >> putWord16be (fromIntegral len) | otherwise -> putWord8 TAG_ext32 >> putWord32be (fromIntegral len) - putWord8 typ + putInt8 typ putdat ---------------------------------------------------------------------------- diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs index 2124570..a7c42da 100644 --- a/msgpack/src/Data/MessagePack/Tags.hs +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} @@ -102,6 +103,9 @@ pattern TAG_array32 = 0xdd -- 0b11011101 pattern TAG_map16 = 0xde -- 0b11011110 pattern TAG_map32 = 0xdf -- 0b11011111 --- used by "Data.MessagePack.Timestamp" -pattern XTAG_Timestamp = 0xff +-- 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 From 906fa01c357f55d8e7a45e2680d91ad00fea3553 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 15:31:40 +0200 Subject: [PATCH 55/75] Introduce `MessagePack(toBinary)` method This corresponds to aeson's `toEncoding` optimization providing a direct encoding path avoiding an intermediate `Object` AST construction --- msgpack/src/Data/MessagePack.hs | 5 ++- msgpack/src/Data/MessagePack/Object.hs | 53 ++++++++++++++++++++++++-- msgpack/src/Data/MessagePack/Put.hs | 16 ++++++-- 3 files changed, 64 insertions(+), 10 deletions(-) diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index 1894fa8..b8c2c51 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -22,7 +22,8 @@ module Data.MessagePack ( module Data.MessagePack.Put, ) where -import Data.Binary (decode, encode) +import Data.Binary (decode) +import Data.Binary.Put (runPut) import qualified Data.ByteString.Lazy as L import Data.MessagePack.Assoc @@ -32,7 +33,7 @@ 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 Nothing. unpack :: MessagePack a => L.ByteString -> Maybe a diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 022accc..998ddba 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -128,6 +128,13 @@ instance Binary Object where -- | Class for converting between MessagePack 'Object's and native Haskell types. class MessagePack a where toObject :: a -> Object + + -- | Encodes directly to 'Put' monad bypassing the intermediate 'Object' AST + -- + -- @since 1.1.0.0 + toBinary :: a -> Put + toBinary = putObject . toObject + fromObject :: Object -> Maybe a -- core instances @@ -135,17 +142,20 @@ class MessagePack a where -- | The trivial identity 'MessagePack' instance instance MessagePack Object where toObject = id + toBinary = putObject fromObject = Just -- | Encodes as 'ObjectNil' instance MessagePack () where toObject _ = ObjectNil + toBinary _ = putNil fromObject = \case ObjectNil -> Just () _ -> Nothing instance MessagePack Bool where toObject = ObjectBool + toBinary = putBool fromObject = \case ObjectBool b -> Just b _ -> Nothing @@ -155,6 +165,7 @@ instance MessagePack Bool where -- | @since 1.1.0.0 instance MessagePack MPInteger where toObject = ObjectInt + toBinary = put fromObject = \case ObjectInt n -> Just n _ -> Nothing @@ -162,6 +173,7 @@ instance MessagePack MPInteger where -- | @since 1.1.0.0 instance MessagePack Word64 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -169,6 +181,7 @@ instance MessagePack Word64 where -- | @since 1.1.0.0 instance MessagePack Word32 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -176,6 +189,7 @@ instance MessagePack Word32 where -- | @since 1.1.0.0 instance MessagePack Word16 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -183,6 +197,7 @@ instance MessagePack Word16 where -- | @since 1.1.0.0 instance MessagePack Word8 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -190,6 +205,7 @@ instance MessagePack Word8 where -- | @since 1.1.0.0 instance MessagePack Word where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -198,6 +214,7 @@ instance MessagePack Word where -- | @since 1.1.0.0 instance MessagePack Int64 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -205,6 +222,7 @@ instance MessagePack Int64 where -- | @since 1.1.0.0 instance MessagePack Int32 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -212,6 +230,7 @@ instance MessagePack Int32 where -- | @since 1.1.0.0 instance MessagePack Int16 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -219,12 +238,14 @@ instance MessagePack Int16 where -- | @since 1.1.0.0 instance MessagePack Int8 where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing instance MessagePack Int where toObject = ObjectInt . toMPInteger + toBinary = put . toMPInteger fromObject = \case ObjectInt n -> fromMPInteger n _ -> Nothing @@ -233,6 +254,7 @@ instance MessagePack Int where instance MessagePack Float where toObject = ObjectFloat + toBinary = putFloat fromObject = \case ObjectInt n -> Just $! fromIntegral n ObjectFloat f -> Just f @@ -241,6 +263,7 @@ instance MessagePack Float where instance MessagePack Double where toObject = ObjectDouble + toBinary = putDouble fromObject = \case ObjectInt n -> Just $! fromIntegral n ObjectFloat f -> Just $! realToFrac f @@ -249,6 +272,7 @@ instance MessagePack Double where instance MessagePack S.ByteString where toObject = ObjectBin + toBinary = putBin fromObject = \case ObjectBin r -> Just r _ -> Nothing @@ -256,21 +280,22 @@ instance MessagePack S.ByteString where -- Because of overlapping instance, this must be above [a] instance MessagePack String where 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 + toBinary = putArray toBinary fromObject = \case ObjectArray xs -> V.mapM fromObject xs _ -> Nothing instance (MessagePack a, MessagePack b) => MessagePack (Assoc (V.Vector (a, b))) where toObject (Assoc xs) = ObjectMap $ V.map (toObject *** toObject) xs + toBinary (Assoc xs) = putMap toBinary toBinary xs fromObject = \case - ObjectMap xs -> - Assoc <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs - _ -> - Nothing + ObjectMap xs -> Assoc <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs + _ -> Nothing -- util instances @@ -283,6 +308,9 @@ 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 @@ -292,85 +320,102 @@ instance MessagePack a => MessagePack (Maybe a) where instance MessagePack L.ByteString where 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 = ObjectStr + toBinary = putStr fromObject = \case ObjectStr s -> Just s _ -> Nothing instance MessagePack LT.Text where 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 -- 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 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 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 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 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 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 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 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 diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index 0cd56f4..a2adfcc 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -14,7 +14,7 @@ module Data.MessagePack.Put ( putNil, putBool, putFloat, putDouble, putInt, putWord, putInt64, putWord64, - putStr, putBin, putArray, putMap, putExt, putExt' + putStr, putBin, putArray, putArray', putMap, putExt, putExt' ) where import Compat.Prelude @@ -80,11 +80,19 @@ putBin bs = do putArray :: (a -> Put) -> V.Vector a -> Put putArray p xs = do - toSizeM ("putArray: data exceeds 2^32-1 element limit of MessagePack") (V.length xs) >>= \case - len | len < 16 -> putWord8 (TAG_fixarray .|. fromIntegral len) + 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) - V.mapM_ p xs + putter putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put putMap p q xs = do From 43b738e4c1ce330efdae89e061d75722e74fa999 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 15:58:49 +0200 Subject: [PATCH 56/75] Introduce aeson-ish `Result` type for `fromObject` decoder This allows to give more error context on decoding failures --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 30 ++-- msgpack-aeson/test/test.hs | 4 +- msgpack-rpc/msgpack-rpc.cabal | 2 +- msgpack-rpc/src/Network/MessagePack/Client.hs | 12 +- msgpack-rpc/src/Network/MessagePack/Server.hs | 8 +- msgpack/msgpack.cabal | 5 + msgpack/src/Compat/Binary.hs | 10 +- msgpack/src/Compat/Prelude.hs | 2 + msgpack/src/Data/MessagePack.hs | 8 +- msgpack/src/Data/MessagePack/Generic.hs | 12 +- msgpack/src/Data/MessagePack/Object.hs | 167 ++++++++++-------- msgpack/src/Data/MessagePack/Result.hs | 53 ++++++ msgpack/src/Data/MessagePack/Timestamp.hs | 10 +- msgpack/test/DataCases.hs | 2 +- msgpack/test/Properties.hs | 2 +- 15 files changed, 205 insertions(+), 122 deletions(-) create mode 100644 msgpack/src/Data/MessagePack/Result.hs diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index a18fdd1..fee4fff 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -34,17 +34,17 @@ import qualified Data.Vector as V 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 + 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 -> String <$> either (fail . show) pure (T.decodeUtf8' b) 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 = maybe (fail "bad object") pure . MP.fromObject + where from = mpResult fail pure . MP.fromObject ObjectExt _ _ -> fail "ObjectExt is not supported" -- | Convert JSON 'Value' to 'MP.Object' @@ -65,7 +65,7 @@ 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 <$> (\case { A.Error _ -> Nothing; A.Success x -> Just x } $ (fromJSON =<< toAeson o)) + fromObject o = AsMessagePack <$> (aResult fail pure (fromJSON =<< toAeson o)) toObject = fromAeson . toJSON . getAsMessagePack -- | Wrapper for using MessagePack values as Aeson value. @@ -73,18 +73,18 @@ newtype AsAeson a = AsAeson { getAsAeson :: a } deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) instance MessagePack a => ToJSON (AsAeson a) where - toJSON = \case { A.Error _ -> Null; A.Success x -> x } . toAeson . toObject . getAsAeson + toJSON = aResult (const Null) id . toAeson . toObject . getAsAeson instance MessagePack a => FromJSON (AsAeson a) where - parseJSON = maybe empty (return . AsAeson) . fromObject . fromAeson + parseJSON = mpResult fail (pure . AsAeson) . fromObject . fromAeson -- | Encode to MessagePack via "Data.Aeson"'s 'ToJSON' instances packAeson :: ToJSON a => a -> L.ByteString packAeson = pack . fromAeson . toJSON -- | Decode from MessagePack via "Data.Aeson"'s 'FromJSON' instances -unpackAeson :: FromJSON a => L.ByteString -> Result a -unpackAeson b = fromJSON =<< toAeson =<< maybe (fail "unpackAeson") pure (unpack b) +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 @@ -93,3 +93,11 @@ 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 index 7242b71..d27659a 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -42,11 +42,11 @@ test :: (MessagePack a, Show a, Eq a) => a -> IO () test v = do let bs = pack v print bs - print (unpack bs == Just v) + print (unpack bs == Right v) let oa = toObject v print oa - print (fromObject oa == Just v) + print (fromObject oa == Data.MessagePack.Success v) roundTrip :: (Show a, Eq a, ToJSON a, FromJSON a) => a -> IO () roundTrip v = do diff --git a/msgpack-rpc/msgpack-rpc.cabal b/msgpack-rpc/msgpack-rpc.cabal index f4404e3..0acf909 100644 --- a/msgpack-rpc/msgpack-rpc.cabal +++ b/msgpack-rpc/msgpack-rpc.cabal @@ -38,7 +38,7 @@ library , binary-conduit >= 1.2.3 && < 1.3 , exceptions >= 0.8 && < 0.11 , binary >= 0.7.1 && < 0.9 - , msgpack >= 1.0.0 && < 1.2 + , msgpack >= 1.1.0 && < 1.2 test-suite msgpack-rpc-test default-language: Haskell2010 diff --git a/msgpack-rpc/src/Network/MessagePack/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs index f1caf99..8bf25e5 100644 --- a/msgpack-rpc/src/Network/MessagePack/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -87,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) @@ -102,8 +102,8 @@ rpcCall methodName args = ClientT $ do CMS.put $ Connection rsrc' sink (msgid + 1) case fromObject res of - Nothing -> throwM $ ProtocolError "invalid response data" - Just (rtype, rmsgid, rerror, rresult) -> do + Error e -> throwM $ ProtocolError e + Success (rtype, rmsgid, rerror, rresult) -> do when (rtype /= (1 :: Int)) $ throwM $ ProtocolError $ @@ -116,8 +116,8 @@ rpcCall methodName args = ClientT $ do ++ show rmsgid case fromObject rerror of - Nothing -> throwM $ ServerError rerror - Just () -> return rresult + 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 index ea294ef..5be0083 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -90,8 +90,8 @@ instance (Functor m, MonadThrow m, MessagePack o) => MethodType m (ServerT m o) instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where toBody f (x: xs) = case fromObject x of - Nothing -> throwM $ ServerError "argument type error" - Just r -> toBody (f r) xs + Error e -> throwM $ ServerError e + Success r -> toBody (f r) xs -- | Build a method method :: MethodType m f @@ -114,8 +114,8 @@ serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do (rsrc', res) <- rsrc $$++ do obj <- sinkGet get case fromObject obj of - Nothing -> throwM $ ServerError "invalid request" - Just req -> lift $ getResponse (req :: Request) + Error e -> throwM $ ServerError e + Success req -> lift $ getResponse (req :: Request) _ <- CB.sourceLbs (pack res) $$ sink processRequests rsrc' sink diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 3428fb5..792fe4d 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -66,6 +66,7 @@ library Data.MessagePack.Put other-modules: Data.MessagePack.Tags + Data.MessagePack.Result Compat.Binary Compat.Prelude @@ -83,11 +84,15 @@ library , 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 default-language: Haskell2010 diff --git a/msgpack/src/Compat/Binary.hs b/msgpack/src/Compat/Binary.hs index 01cb7f3..33abfcb 100644 --- a/msgpack/src/Compat/Binary.hs +++ b/msgpack/src/Compat/Binary.hs @@ -38,13 +38,13 @@ import qualified Data.Binary.Put as Bin import GHC.ST (ST, runST) -runGet' :: BS.ByteString -> Get a -> Maybe a +runGet' :: BS.ByteString -> Get a -> Either String a runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of Bin.Done bs _ x - | BS.null bs -> return x - | otherwise -> fail "trailing data" - Bin.Partial _ -> fail "eof" - Bin.Fail _ _ msg -> fail msg + | BS.null bs -> Right x + | otherwise -> Left "unexpected trailing data" + Bin.Partial _ -> Left "truncated data" + Bin.Fail _ _ msg -> Left msg runPut' :: Put -> BS.ByteString runPut' = BL.toStrict . Bin.runPut diff --git a/msgpack/src/Compat/Prelude.hs b/msgpack/src/Compat/Prelude.hs index 01a4358..e6607c5 100644 --- a/msgpack/src/Compat/Prelude.hs +++ b/msgpack/src/Compat/Prelude.hs @@ -8,8 +8,10 @@ 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 b8c2c51..ee7a3b1 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -35,6 +35,8 @@ import Data.MessagePack.Put pack :: MessagePack a => a -> L.ByteString pack = runPut . toBinary --- | Unpack MessagePack binary to a Haskell value. If it fails, it returns Nothing. -unpack :: MessagePack a => L.ByteString -> Maybe a -unpack = fromObject . decode +-- | Unpack MessagePack binary to a Haskell value. If it fails, it returns 'Left' with an error message. +unpack :: MessagePack a => L.ByteString -> Either String a +unpack bs = case fromObject (decode bs) of + Success a -> Right a + Error e -> Left e diff --git a/msgpack/src/Data/MessagePack/Generic.hs b/msgpack/src/Data/MessagePack/Generic.hs index 0ca34cc..4d8fb31 100644 --- a/msgpack/src/Data/MessagePack/Generic.hs +++ b/msgpack/src/Data/MessagePack/Generic.hs @@ -21,12 +21,12 @@ import Data.MessagePack.Object genericToObject :: (Generic a, GMessagePack (Rep a)) => a -> Object genericToObject = gToObject . from -genericFromObject :: (Generic a, GMessagePack (Rep a)) => Object -> Maybe a +genericFromObject :: (Generic a, GMessagePack (Rep a)) => Object -> Result a genericFromObject x = to <$> gFromObject x class GMessagePack f where gToObject :: f a -> Object - gFromObject :: Object -> Maybe (f a) + gFromObject :: Object -> Result (f a) instance GMessagePack U1 where gToObject U1 = ObjectNil @@ -61,7 +61,7 @@ instance MessagePack a => GMessagePack (K1 i a) where class GProdPack f where prodToObject :: f a -> [Object] - prodFromObject :: [Object] -> Maybe (f a) + prodFromObject :: [Object] -> Result (f a) instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where @@ -77,13 +77,13 @@ instance GMessagePack a => GProdPack (M1 t c a) where -- Sum type packing. -checkSumFromObject0 :: GSumPack f => Word64 -> Word64 -> Maybe (f a) +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 -> Maybe (f a) +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" @@ -91,7 +91,7 @@ checkSumFromObject size code x class GSumPack f where sumToObject :: Word64 -> Word64 -> f a -> Object - sumFromObject :: Word64 -> Word64 -> Object -> Maybe (f a) + sumFromObject :: Word64 -> Word64 -> Object -> Result (f a) instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 998ddba..2b00fcf 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -22,7 +22,7 @@ module Data.MessagePack.Object ( Object(..), -- * MessagePack Serializable Types - MessagePack(..), + MessagePack(..), typeMismatch, Result(..) ) where import Compat.Prelude @@ -44,6 +44,7 @@ import Data.MessagePack.Assoc import Data.MessagePack.Get import Data.MessagePack.Integer import Data.MessagePack.Put +import Data.MessagePack.Result import Compat.Binary @@ -135,7 +136,7 @@ class MessagePack a where toBinary :: a -> Put toBinary = putObject . toObject - fromObject :: Object -> Maybe a + fromObject :: Object -> Result a -- core instances @@ -143,22 +144,18 @@ class MessagePack a where instance MessagePack Object where toObject = id toBinary = putObject - fromObject = Just + fromObject = pure -- | Encodes as 'ObjectNil' instance MessagePack () where toObject _ = ObjectNil toBinary _ = putNil - fromObject = \case - ObjectNil -> Just () - _ -> Nothing + fromObject = withNil "()" (pure ()) instance MessagePack Bool where toObject = ObjectBool toBinary = putBool - fromObject = \case - ObjectBool b -> Just b - _ -> Nothing + fromObject = withBool "Bool" pure ---------------------------------------------------------------------------- @@ -166,89 +163,73 @@ instance MessagePack Bool where instance MessagePack MPInteger where toObject = ObjectInt toBinary = put - fromObject = \case - ObjectInt n -> Just n - _ -> Nothing + 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 = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Word64" -- | @since 1.1.0.0 instance MessagePack Word32 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Word32" -- | @since 1.1.0.0 instance MessagePack Word16 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Word16" -- | @since 1.1.0.0 instance MessagePack Word8 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Word8" -- | @since 1.1.0.0 instance MessagePack Word where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing - + fromObject = fromObjectInt "Word" -- | @since 1.1.0.0 instance MessagePack Int64 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Int64" -- | @since 1.1.0.0 instance MessagePack Int32 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Int32" -- | @since 1.1.0.0 instance MessagePack Int16 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Int16" -- | @since 1.1.0.0 instance MessagePack Int8 where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Int8" instance MessagePack Int where toObject = ObjectInt . toMPInteger toBinary = put . toMPInteger - fromObject = \case - ObjectInt n -> fromMPInteger n - _ -> Nothing + fromObject = fromObjectInt "Int" ---------------------------------------------------------------------------- @@ -256,26 +237,24 @@ instance MessagePack Float where toObject = ObjectFloat toBinary = putFloat fromObject = \case - ObjectInt n -> Just $! fromIntegral n - ObjectFloat f -> Just f - ObjectDouble d -> Just $! realToFrac d - _ -> Nothing + ObjectInt n -> pure $! fromIntegral n + ObjectFloat f -> pure f + ObjectDouble d -> pure $! realToFrac d + obj -> typeMismatch "Float" obj instance MessagePack Double where toObject = ObjectDouble toBinary = putDouble fromObject = \case - ObjectInt n -> Just $! fromIntegral n - ObjectFloat f -> Just $! realToFrac f - ObjectDouble d -> Just d - _ -> Nothing + ObjectInt n -> pure $! fromIntegral n + ObjectFloat f -> pure $! realToFrac f + ObjectDouble d -> pure d + obj -> typeMismatch "Double" obj instance MessagePack S.ByteString where toObject = ObjectBin toBinary = putBin - fromObject = \case - ObjectBin r -> Just r - _ -> Nothing + fromObject = withBin "ByteString" pure -- Because of overlapping instance, this must be above [a] instance MessagePack String where @@ -286,20 +265,12 @@ instance MessagePack String where instance MessagePack a => MessagePack (V.Vector a) where toObject = ObjectArray . V.map toObject toBinary = putArray toBinary - fromObject = \case - ObjectArray xs -> V.mapM fromObject xs - _ -> Nothing + 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 toBinary (Assoc xs) = putMap toBinary toBinary xs - fromObject = \case - ObjectMap xs -> Assoc <$> V.mapM (\(k, v) -> (,) <$> fromObject k <*> fromObject v) xs - _ -> Nothing - --- util instances - --- nullable + 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@. -- @@ -313,8 +284,8 @@ instance MessagePack a => MessagePack (Maybe a) where Nothing -> putNil fromObject = \case - ObjectNil -> Just Nothing - obj -> Just <$> fromObject obj + ObjectNil -> pure Nothing + obj -> Just <$> fromObject obj -- UTF8 string like @@ -332,9 +303,7 @@ instance MessagePack SBS.ShortByteString where instance MessagePack T.Text where toObject = ObjectStr toBinary = putStr - fromObject = \case - ObjectStr s -> Just s - _ -> Nothing + fromObject = withStr "Text" pure instance MessagePack LT.Text where toObject = toObject . LT.toStrict @@ -376,46 +345,90 @@ 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 + +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/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/Timestamp.hs b/msgpack/src/Data/MessagePack/Timestamp.hs index b82fbb5..7c78309 100644 --- a/msgpack/src/Data/MessagePack/Timestamp.hs +++ b/msgpack/src/Data/MessagePack/Timestamp.hs @@ -150,16 +150,16 @@ instance MessagePack MPTimestamp where fromObject = \case ObjectExt XTAG_Timestamp bs -> mptsDecode bs - _ -> Nothing + obj -> typeMismatch "MPTimestamp" obj -- helpers for 'MessagePack' instance mptsEncode :: MPTimestamp -> S.ByteString mptsEncode = runPut' . snd . mptsPutExtData -mptsDecode :: S.ByteString -> Maybe MPTimestamp +mptsDecode :: S.ByteString -> Result MPTimestamp mptsDecode bs = do - len <- intCastMaybe (S.length bs) - runGet' bs (mptsGetExtData len) + 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 @@ -198,4 +198,4 @@ mptsGetExtData = \case when (ns > 999999999) $ fail "invalid nanosecond value" pure $! MPTimestamp s ns - _ -> fail "unsupported timestamp encoding" + _ -> fail "unsupported timestamp encoding (length)" diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs index eec6120..f231bb6 100644 --- a/msgpack/test/DataCases.hs +++ b/msgpack/test/DataCases.hs @@ -39,7 +39,7 @@ genDataCases fns = testGroup "Reference Tests" <$> forM fns doFile assertBool ("pack " ++ show obj) (b0 `elem` dcMsgPack tc) forM_ (zip [0..] (dcMsgPack tc)) $ \(j,b) -> do - let Just decoded = unpack (L.fromStrict b) + let Right decoded = unpack (L.fromStrict b) packLbl = "pack #" ++ (show (j::Int)) unpackLbl = "un" ++ packLbl diff --git a/msgpack/test/Properties.hs b/msgpack/test/Properties.hs index 80896ff..f7b4770 100644 --- a/msgpack/test/Properties.hs +++ b/msgpack/test/Properties.hs @@ -34,7 +34,7 @@ instance Arbitrary MPTimestamp where ] mid :: MessagePack a => a -> a -mid = fromJust . unpack . pack +mid = either error id . unpack . pack idPropTests :: TestTree idPropTests = testGroup "Identity Properties" From fbb78051bc790cf0ee44933703e99842454e6cf1 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Wed, 27 Feb 2019 16:04:32 +0200 Subject: [PATCH 57/75] Ensure binary decoder exceptions are turned into errors rather than exceptions Also add strict bytestring variants of unpack/pack --- msgpack/src/Compat/Binary.hs | 14 +++++++--- msgpack/src/Data/MessagePack.hs | 36 +++++++++++++++++++++----- msgpack/src/Data/MessagePack/Object.hs | 1 + 3 files changed, 41 insertions(+), 10 deletions(-) diff --git a/msgpack/src/Compat/Binary.hs b/msgpack/src/Compat/Binary.hs index 33abfcb..eb2f983 100644 --- a/msgpack/src/Compat/Binary.hs +++ b/msgpack/src/Compat/Binary.hs @@ -7,7 +7,7 @@ module Compat.Binary ( Binary(put, get) , runPut', Bin.runPut, Bin.PutM, Put - , runGet', Bin.runGet, Get + , runGet', runGet, Get , Bin.getWord64be, Bin.putWord64be , Bin.getWord32be, Bin.putWord32be @@ -40,15 +40,21 @@ 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 _ x + Bin.Done bs ofs x | BS.null bs -> Right x - | otherwise -> Left "unexpected trailing data" + | otherwise -> Left ("unexpected trailing data (ofs="++show ofs++")") Bin.Partial _ -> Left "truncated data" - Bin.Fail _ _ msg -> Left msg + 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 diff --git a/msgpack/src/Data/MessagePack.hs b/msgpack/src/Data/MessagePack.hs index ee7a3b1..416ed00 100644 --- a/msgpack/src/Data/MessagePack.hs +++ b/msgpack/src/Data/MessagePack.hs @@ -12,18 +12,21 @@ module Data.MessagePack ( -- * Simple interface to pack and unpack msgpack binary + -- ** Lazy 'L.ByteString' pack, unpack, + -- ** Strict 'L.ByteString' + pack', unpack', + -- * Re-export modules - -- $reexports module Data.MessagePack.Assoc, module Data.MessagePack.Get, module Data.MessagePack.Object, module Data.MessagePack.Put, ) where -import Data.Binary (decode) -import Data.Binary.Put (runPut) +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 @@ -36,7 +39,28 @@ pack :: MessagePack a => a -> L.ByteString 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 = case fromObject (decode bs) of - Success a -> Right a - Error e -> Left e +unpack bs = do + obj <- runGet bs get + case fromObject obj of + Success a -> Right a + Error e -> Left e + + +-- | 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/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 2b00fcf..d55c411 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -107,6 +107,7 @@ getObject = <|> ObjectArray <$> getArray getObject <|> ObjectMap <$> getMap getObject getObject <|> uncurry ObjectExt <$> getExt + <|> fail "invalid MessagePack object" putObject :: Object -> Put putObject = \case From e377b942ae3cf1dd87714ac8b6d0a0cb2262b7ed Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 16:07:57 +0200 Subject: [PATCH 58/75] Avoid use of TH in testsuite --- msgpack-aeson/test/test.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs index d27659a..11ab038 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} import Control.Applicative import Control.Monad @@ -8,35 +8,36 @@ import Data.Aeson import Data.Aeson.TH import Data.MessagePack import Data.MessagePack.Aeson +import GHC.Generics (Generic) import Test.Tasty import Test.Tasty.HUnit data T = A Int String | B Double - deriving (Show, Eq) + deriving (Show, Eq, Generic) -deriveJSON defaultOptions ''T +instance FromJSON T; instance ToJSON T data U = C { c1 :: Int, c2 :: String } | D { z1 :: Double } - deriving (Show, Eq) + deriving (Show, Eq, Generic) -deriveJSON defaultOptions ''U +instance FromJSON U; instance ToJSON U data V = E String | F - deriving (Show, Eq) + deriving (Show, Eq, Generic) -deriveJSON defaultOptions ''V +instance FromJSON V; instance ToJSON V data W a = G a String | H { hHoge :: Int, h_age :: a } - deriving (Show, Eq) + deriving (Show, Eq, Generic) -deriveJSON defaultOptions ''W +instance FromJSON a => FromJSON (W a); instance ToJSON a => ToJSON (W a) test :: (MessagePack a, Show a, Eq a) => a -> IO () test v = do From 02bca6674614d909c2dbdc91a2d248f25a16727f Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 16:09:38 +0200 Subject: [PATCH 59/75] Relocate `.Get` module to `.Get.Internal` module This will allow us to provide some extra internals not exported as part of the API --- msgpack/msgpack.cabal | 1 + msgpack/src/Data/MessagePack/Get.hs | 148 ++-------------- msgpack/src/Data/MessagePack/Get/Internal.hs | 167 +++++++++++++++++++ 3 files changed, 185 insertions(+), 131 deletions(-) create mode 100644 msgpack/src/Data/MessagePack/Get/Internal.hs diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 792fe4d..7160af4 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -67,6 +67,7 @@ library other-modules: Data.MessagePack.Tags Data.MessagePack.Result + Data.MessagePack.Get.Internal Compat.Binary Compat.Prelude diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index e2ed417..6e0b098 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -12,140 +12,26 @@ -- -------------------------------------------------------------------- -module Data.MessagePack.Get( - getNil, getBool, getFloat, getDouble, - getInt, getWord, getInt64, getWord64, - getStr, getBin, getArray, getMap, getExt, getExt' - ) 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.Integer -import Data.MessagePack.Tags - -getNil :: Get () -getNil = tag TAG_nil - -getBool :: Get Bool -getBool = - getWord8 >>= \case - TAG_false -> return False - TAG_true -> return True - _ -> empty - -getFloat :: Get Float -getFloat = tag TAG_float32 >> getFloat32be - -getDouble :: Get Double -getDouble = tag TAG_float64 >> getFloat64be - --- local helper for single-tag decoders -tag :: Word8 -> Get () -tag t = do { b <- getWord8; guard (t == b) } - --- | 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 +module Data.MessagePack.Get + ( getNil + , getBool --- | 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 - --- | 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 - --- | 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 - -getStr :: Get T.Text -getStr = do - len <- getWord8 >>= \case - t | Just sz <- is_TAG_fixstr t -> pure sz - TAG_str8 -> intCast <$> getWord8 - TAG_str16 -> intCast <$> getWord16be - TAG_str32 -> getWord32be - _ -> empty + , getFloat + , getDouble - len' <- fromSizeM "getStr: data exceeds capacity of ByteString/Text" len - bs <- getByteString len' - case T.decodeUtf8' bs of - Left _ -> empty - Right v -> return v + , getInt + , getWord + , getInt64 + , getWord64 -getBin :: Get S.ByteString -getBin = do - len <- getWord8 >>= \case - TAG_bin8 -> intCast <$> getWord8 - TAG_bin16 -> intCast <$> getWord16be - TAG_bin32 -> getWord32be - _ -> empty - len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len - getByteString len' + , getStr + , getBin -getArray :: Get a -> Get (V.Vector a) -getArray g = do - len <- getWord8 >>= \case - t | Just sz <- is_TAG_fixarray t -> pure sz - TAG_array16 -> intCast <$> getWord16be - TAG_array32 -> getWord32be - _ -> empty - len' <- fromSizeM "getArray: data exceeds capacity of Vector" len - V.replicateM len' g + , getArray + , getMap -getMap :: Get a -> Get b -> Get (V.Vector (a, b)) -getMap k v = do - len <- getWord8 >>= \case - t | Just sz <- is_TAG_fixmap t -> pure sz - TAG_map16 -> intCast <$> getWord16be - TAG_map32 -> getWord32be - _ -> empty - len' <- fromSizeM "getMap: data exceeds capacity of Vector" len - V.replicateM len' $ (,) <$> k <*> v - -getExt :: Get (Int8, S.ByteString) -getExt = getExt' $ \typ len -> do - len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len - (,) typ <$> getByteString len' - --- | @since 1.1.0.0 -getExt' :: (Int8 -> Word32 -> Get a) -> Get a -getExt' getdat = do - len <- getWord8 >>= \case - TAG_fixext1 -> return 1 - TAG_fixext2 -> return 2 - TAG_fixext4 -> return 4 - TAG_fixext8 -> return 8 - TAG_fixext16 -> return 16 - TAG_ext8 -> intCast <$> getWord8 - TAG_ext16 -> intCast <$> getWord16be - TAG_ext32 -> getWord32be - _ -> empty - typ <- getInt8 - getdat typ len + , getExt + , getExt' + ) where -fromSizeM :: String -> Word32 -> Get Int -fromSizeM label sz = maybe (fail label) pure (intCastMaybe sz) +import Data.MessagePack.Get.Internal diff --git a/msgpack/src/Data/MessagePack/Get/Internal.hs b/msgpack/src/Data/MessagePack/Get/Internal.hs new file mode 100644 index 0000000..81f4199 --- /dev/null +++ b/msgpack/src/Data/MessagePack/Get/Internal.hs @@ -0,0 +1,167 @@ +{-# 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 + , getBool + + , getFloat + , getDouble + + , getInt + , getWord + , getInt64 + , getWord64 + + , getStr + , getBin + + , getArray + , getMap + + , getExt + , getExt' + ) 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.Integer +import Data.MessagePack.Tags + +getNil :: Get () +getNil = tag TAG_nil + +getBool :: Get Bool +getBool = + getWord8 >>= \case + TAG_false -> return False + TAG_true -> return True + _ -> empty + +getFloat :: Get Float +getFloat = tag TAG_float32 >> getFloat32be + +getDouble :: Get Double +getDouble = tag TAG_float64 >> getFloat64be + +-- local helper for single-tag decoders +tag :: Word8 -> Get () +tag t = do { b <- getWord8; guard (t == b) } + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + +getStr :: Get T.Text +getStr = do + len <- getWord8 >>= \case + t | Just sz <- is_TAG_fixstr t -> pure sz + TAG_str8 -> intCast <$> getWord8 + TAG_str16 -> intCast <$> getWord16be + TAG_str32 -> getWord32be + _ -> empty + + len' <- fromSizeM "getStr: data exceeds capacity of ByteString/Text" len + bs <- getByteString len' + case T.decodeUtf8' bs of + Left _ -> empty + Right v -> return v + +getBin :: Get S.ByteString +getBin = do + len <- getWord8 >>= \case + TAG_bin8 -> intCast <$> getWord8 + TAG_bin16 -> intCast <$> getWord16be + TAG_bin32 -> getWord32be + _ -> empty + len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len + getByteString len' + +getArray :: Get a -> Get (V.Vector a) +getArray g = do + len <- getWord8 >>= \case + t | Just sz <- is_TAG_fixarray t -> pure sz + TAG_array16 -> intCast <$> getWord16be + TAG_array32 -> getWord32be + _ -> empty + len' <- fromSizeM "getArray: data exceeds capacity of Vector" len + V.replicateM len' g + +getMap :: Get a -> Get b -> Get (V.Vector (a, b)) +getMap k v = do + len <- getWord8 >>= \case + t | Just sz <- is_TAG_fixmap t -> pure sz + TAG_map16 -> intCast <$> getWord16be + TAG_map32 -> getWord32be + _ -> empty + len' <- fromSizeM "getMap: data exceeds capacity of Vector" len + V.replicateM len' $ (,) <$> k <*> v + +getExt :: Get (Int8, S.ByteString) +getExt = getExt' $ \typ len -> do + len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len + (,) typ <$> getByteString len' + +-- | @since 1.1.0.0 +getExt' :: (Int8 -> Word32 -> Get a) -> Get a +getExt' getdat = do + len <- getWord8 >>= \case + TAG_fixext1 -> return 1 + TAG_fixext2 -> return 2 + TAG_fixext4 -> return 4 + TAG_fixext8 -> return 8 + TAG_fixext16 -> return 16 + TAG_ext8 -> intCast <$> getWord8 + TAG_ext16 -> intCast <$> getWord16be + TAG_ext32 -> getWord32be + _ -> empty + typ <- getInt8 + getdat typ len + +fromSizeM :: String -> Word32 -> Get Int +fromSizeM label sz = maybe (fail label) pure (intCastMaybe sz) From 60559857f8fcb883e05f1a75575565265cd9b76d Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 16:31:13 +0200 Subject: [PATCH 60/75] Make decoding errors more accurate This avoids the use of `Alternative` for combining sub-decoders and instead uses a continuation-style fall-through scheme. This is possibly just an interim refactoring state. --- msgpack/src/Data/MessagePack/Get.hs | 36 +++ msgpack/src/Data/MessagePack/Get/Internal.hs | 254 ++++++++++--------- msgpack/src/Data/MessagePack/Integer.hs | 35 ++- msgpack/src/Data/MessagePack/Object.hs | 53 ++-- msgpack/src/Data/MessagePack/Tags.hs | 2 +- 5 files changed, 224 insertions(+), 156 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Get.hs b/msgpack/src/Data/MessagePack/Get.hs index 6e0b098..73a0b6d 100644 --- a/msgpack/src/Data/MessagePack/Get.hs +++ b/msgpack/src/Data/MessagePack/Get.hs @@ -34,4 +34,40 @@ module Data.MessagePack.Get , getExt' ) where +import Compat.Binary +import Compat.Prelude import Data.MessagePack.Get.Internal +import Data.MessagePack.Integer + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 + diff --git a/msgpack/src/Data/MessagePack/Get/Internal.hs b/msgpack/src/Data/MessagePack/Get/Internal.hs index 81f4199..e0aaaa0 100644 --- a/msgpack/src/Data/MessagePack/Get/Internal.hs +++ b/msgpack/src/Data/MessagePack/Get/Internal.hs @@ -13,155 +13,175 @@ -------------------------------------------------------------------- module Data.MessagePack.Get.Internal - ( getNil - , getBool + ( getNil, tryNil + , getBool, tryBool - , getFloat - , getDouble + , getFloat, tryFloat + , getDouble, tryDouble - , getInt - , getWord - , getInt64 - , getWord64 + , getStr, tryStr + , getBin, tryBin - , getStr - , getBin + , getArray, tryArray + , getMap, tryMap - , getArray - , getMap - - , getExt - , getExt' + , 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 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 +mkGet :: (Word8 -> t -> Get a -> Get b) -> t -> String -> Get b +mkGet tryT f n = do { tag <- getWord8; tryT tag f (fail n) } + getNil :: Get () -getNil = tag TAG_nil +getNil = mkGet tryNil id "()" getBool :: Get Bool -getBool = - getWord8 >>= \case - TAG_false -> return False - TAG_true -> return True - _ -> empty +getBool = mkGet tryBool id "Bool" getFloat :: Get Float -getFloat = tag TAG_float32 >> getFloat32be +getFloat = mkGet tryFloat id "Float" getDouble :: Get Double -getDouble = tag TAG_float64 >> getFloat64be - --- local helper for single-tag decoders -tag :: Word8 -> Get () -tag t = do { b <- getWord8; guard (t == b) } - --- | 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 - --- | 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 - --- | 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 - --- | 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 +getDouble = mkGet tryDouble id "Double" getStr :: Get T.Text -getStr = do - len <- getWord8 >>= \case - t | Just sz <- is_TAG_fixstr t -> pure sz - TAG_str8 -> intCast <$> getWord8 - TAG_str16 -> intCast <$> getWord16be - TAG_str32 -> getWord32be - _ -> empty - - len' <- fromSizeM "getStr: data exceeds capacity of ByteString/Text" len - bs <- getByteString len' - case T.decodeUtf8' bs of - Left _ -> empty - Right v -> return v +getStr = mkGet tryStr id "Str" getBin :: Get S.ByteString -getBin = do - len <- getWord8 >>= \case - TAG_bin8 -> intCast <$> getWord8 - TAG_bin16 -> intCast <$> getWord16be - TAG_bin32 -> getWord32be - _ -> empty - len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len - getByteString len' +getBin = mkGet tryBin id "Bin" getArray :: Get a -> Get (V.Vector a) -getArray g = do - len <- getWord8 >>= \case - t | Just sz <- is_TAG_fixarray t -> pure sz - TAG_array16 -> intCast <$> getWord16be - TAG_array32 -> getWord32be - _ -> empty - len' <- fromSizeM "getArray: data exceeds capacity of Vector" len - V.replicateM len' g +getArray g = mkGet (tryArray g) id "Array" getMap :: Get a -> Get b -> Get (V.Vector (a, b)) -getMap k v = do - len <- getWord8 >>= \case - t | Just sz <- is_TAG_fixmap t -> pure sz - TAG_map16 -> intCast <$> getWord16be - TAG_map32 -> getWord32be - _ -> empty - len' <- fromSizeM "getMap: data exceeds capacity of Vector" len - V.replicateM len' $ (,) <$> k <*> v +getMap k v = mkGet (tryMap k v) id "Map" getExt :: Get (Int8, S.ByteString) -getExt = getExt' $ \typ len -> do - len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len - (,) typ <$> getByteString len' +getExt = mkGet tryExt id "Ext" -- | @since 1.1.0.0 getExt' :: (Int8 -> Word32 -> Get a) -> Get a -getExt' getdat = do - len <- getWord8 >>= \case - TAG_fixext1 -> return 1 - TAG_fixext2 -> return 2 - TAG_fixext4 -> return 4 - TAG_fixext8 -> return 8 - TAG_fixext16 -> return 16 - TAG_ext8 -> intCast <$> getWord8 - TAG_ext16 -> intCast <$> getWord16be - TAG_ext32 -> getWord32be - _ -> empty - typ <- getInt8 - getdat typ len +getExt' getdat = mkGet (tryExt' getdat) id "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 index 3426027..bc98a3d 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -15,6 +15,9 @@ module Data.MessagePack.Integer , ToMPInteger(..) , FromMPInteger(..) , fromIntegerTry + + -- ** Internal helper + , tryMPInteger ) where import Compat.Prelude @@ -252,19 +255,23 @@ putMPInteger (MPInteger True w) = putWord8 TAG_uint64 >> putWord64be (toW64 w) -- -- This operation will only fail if a non-integer MessagePack tag is encountered. getMPInteger :: Get MPInteger -getMPInteger = getWord8 >>= \case +getMPInteger = do + tag <- getWord8 + tryMPInteger tag id (fail "getMPInteger") + +-- | @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 $! toMPInteger (intCastIso c :: Int8) - - TAG_uint8 -> toMPInteger <$> getWord8 - TAG_uint16 -> toMPInteger <$> getWord16be - TAG_uint32 -> toMPInteger <$> getWord32be - TAG_uint64 -> toMPInteger <$> getWord64be - - TAG_int8 -> toMPInteger <$> getInt8 - TAG_int16 -> toMPInteger <$> getInt16be - TAG_int32 -> toMPInteger <$> getInt32be - TAG_int64 -> toMPInteger <$> getInt64be - - _ -> empty + 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 d55c411..ac0ee7c 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -26,25 +26,26 @@ module Data.MessagePack.Object ( ) where import Compat.Prelude -import Prelude hiding (putStr) +import Prelude hiding (putStr) import Control.Arrow -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 qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Vector as V +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 qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +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 @@ -96,18 +97,22 @@ instance NFData Object where _ -> () getObject :: Get Object -getObject = - ObjectNil <$ getNil - <|> ObjectBool <$> getBool - <|> ObjectInt <$> get - <|> ObjectFloat <$> getFloat - <|> ObjectDouble <$> getDouble - <|> ObjectStr <$> getStr - <|> ObjectBin <$> getBin - <|> ObjectArray <$> getArray getObject - <|> ObjectMap <$> getMap getObject getObject - <|> uncurry ObjectExt <$> getExt - <|> fail "invalid MessagePack object" +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 diff --git a/msgpack/src/Data/MessagePack/Tags.hs b/msgpack/src/Data/MessagePack/Tags.hs index a7c42da..7183fa3 100644 --- a/msgpack/src/Data/MessagePack/Tags.hs +++ b/msgpack/src/Data/MessagePack/Tags.hs @@ -62,7 +62,7 @@ pattern TAG_fixstr = 0xa0 -- 0b101xxxxx [0xa0 .. 0xbf] pattern TAG_MASK_fixstr = 0xe0 -- 0b11100000 pattern TAG_nil = 0xc0 -- 0b11000000 --- reserved = 0xc1 -- 0b11000001 +pattern TAG_reserved_C1 = 0xc1 -- 0b11000001 pattern TAG_false = 0xc2 -- 0b11000010 pattern TAG_true = 0xc3 -- 0b11000011 From d067444c868971664baa586028b96a3815e50264 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@gnu.org> Date: Sun, 31 Mar 2019 16:38:29 +0200 Subject: [PATCH 61/75] Inhibit unsound coercions for `Float` and `Double` 1. The MessagePack spec seems to imply that integers and floats are separate types 2. In general we can't convert a float64 into a 32-bit 'Float' losslessy; the spec even mentions this 3. We can't convert the full range of MP Integers into either 32-bit or 64-bit floats So it's better to err on the type-safe side and don't silently convert integers into floats as well as only allow upcasting from float32 to float64 but not vice-versa --- msgpack/src/Data/MessagePack/Object.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index ac0ee7c..708800c 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -239,23 +239,17 @@ instance MessagePack Int where ---------------------------------------------------------------------------- +-- | This instance decodes only 32bit floats and will fail to decode 64bit floats from MessagePack streams instance MessagePack Float where toObject = ObjectFloat toBinary = putFloat - fromObject = \case - ObjectInt n -> pure $! fromIntegral n - ObjectFloat f -> pure f - ObjectDouble d -> pure $! realToFrac d - obj -> typeMismatch "Float" obj + fromObject = withFloat "Float" pure +-- | This instance decodes 64bit and 32bit floats from MessagePack streams into a 'Double' instance MessagePack Double where toObject = ObjectDouble toBinary = putDouble - fromObject = \case - ObjectInt n -> pure $! fromIntegral n - ObjectFloat f -> pure $! realToFrac f - ObjectDouble d -> pure d - obj -> typeMismatch "Double" obj + fromObject = withDouble "Double" pure instance MessagePack S.ByteString where toObject = ObjectBin @@ -422,6 +416,15 @@ 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 @@ -434,7 +437,6 @@ 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 From fb1de8557e8d0c18b8d9561b5e76ef0102eddd72 Mon Sep 17 00:00:00 2001 From: 2mol <1773075+2mol@users.noreply.github.com> Date: Mon, 13 May 2019 10:45:01 +0200 Subject: [PATCH 62/75] Update test-suite to QuickCheck 2.13 --- msgpack/msgpack.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 7160af4..014ab87 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -120,4 +120,4 @@ test-suite msgpack-tests , tasty == 1.2.* , tasty-quickcheck == 0.10.* , tasty-hunit == 0.10.* - , QuickCheck == 2.12.* + , QuickCheck == 2.13.* From 86271d95f495bab450e9d654fb6460b4911138d4 Mon Sep 17 00:00:00 2001 From: Kenny Shen <kenny@machinesung.com> Date: Fri, 17 May 2019 10:27:56 +0800 Subject: [PATCH 63/75] Update examples in msgpack-rpc --- msgpack-rpc/src/Network/MessagePack/Client.hs | 4 ++-- msgpack-rpc/src/Network/MessagePack/Server.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/msgpack-rpc/src/Network/MessagePack/Client.hs b/msgpack-rpc/src/Network/MessagePack/Client.hs index 8bf25e5..e7a8edb 100644 --- a/msgpack-rpc/src/Network/MessagePack/Client.hs +++ b/msgpack-rpc/src/Network/MessagePack/Client.hs @@ -17,12 +17,12 @@ -- -- 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 -- diff --git a/msgpack-rpc/src/Network/MessagePack/Server.hs b/msgpack-rpc/src/Network/MessagePack/Server.hs index 5be0083..f525e4d 100644 --- a/msgpack-rpc/src/Network/MessagePack/Server.hs +++ b/msgpack-rpc/src/Network/MessagePack/Server.hs @@ -22,7 +22,7 @@ -- -- A simple example: -- --- > import Network.MessagePackRpc.Server +-- > import Network.MessagePack.Server -- > -- > add :: Int -> Int -> Server Int -- > add x y = return $ x + y From 88e529f32ad5ade1b98f2f0ab52b1c62202e6a07 Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@symbiont.io> Date: Mon, 29 Jul 2019 16:47:30 +0100 Subject: [PATCH 64/75] conveniences for creating MessagePack from Aeson instances --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 13 +++++++++++++ msgpack-aeson/test/test.hs | 11 +++++++++-- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index fee4fff..e9ab32e 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -7,6 +7,7 @@ module Data.MessagePack.Aeson ( -- * Conversion functions toAeson, fromAeson, + viaToJSON, viaFromJSON, -- * Wrapper instances AsMessagePack(..), @@ -60,6 +61,18 @@ fromAeson = \case Array v -> ObjectArray $ V.map fromAeson v A.Object o -> ObjectMap $ V.fromList $ map (toObject *** fromAeson) $ HM.toList o +-- 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 + +viaToJSON :: ToJSON a => a -> MP.Object +viaToJSON = fromAeson . toJSON + -- | Wrapper for using Aeson values as MessagePack value. newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs index 11ab038..2a43e4e 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -39,6 +39,10 @@ data W a instance FromJSON a => FromJSON (W a); instance ToJSON a => ToJSON (W a) +instance (FromJSON a, ToJSON a) => MessagePack (W a) where + toObject = viaToJSON + fromObject = viaFromJSON + test :: (MessagePack a, Show a, Eq a) => a -> IO () test v = do let bs = pack v @@ -55,6 +59,9 @@ roundTrip v = do v' = unpackAeson mp v' @?= pure v +roundTrip' :: (Show a, Eq a, MessagePack a) => a -> IO () +roundTrip' v = (unpack . pack $ v) @?= pure v + main :: IO () main = defaultMain $ @@ -72,7 +79,7 @@ main = , testCase "unit 2" $ roundTrip F , testCase "parameterized 1" $ - roundTrip $ G (E "hello") "world" + roundTrip' $ G (E "hello") "world" , testCase "parameterized 2" $ - roundTrip $ H 123 F + roundTrip' $ H 123 F ] From a03ab375ef2669f7f069e5dec6009066f9b52474 Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@symbiont.io> Date: Mon, 29 Jul 2019 16:50:42 +0100 Subject: [PATCH 65/75] NonEmpty instance --- msgpack/msgpack.cabal | 1 + msgpack/src/Data/MessagePack/Object.hs | 11 +++++++++++ 2 files changed, 12 insertions(+) diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 014ab87..1ad62d0 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -81,6 +81,7 @@ library , 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.9 , int-cast >= 0.1.1 && < 0.3 , array >= 0.5.0 && < 0.6 diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 708800c..3091d73 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -35,6 +35,8 @@ 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 @@ -317,6 +319,15 @@ instance MessagePack a => MessagePack [a] where 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 From 6958f54079516a8717684518a5d8c9e67831068a Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@symbiont.io> Date: Mon, 29 Jul 2019 16:53:42 +0100 Subject: [PATCH 66/75] Aeson-like conveniences for records --- msgpack/src/Data/MessagePack/Object.hs | 17 +++++++++++++++++ msgpack/test/DataCases.hs | 2 +- 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 3091d73..5de766a 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -21,6 +21,9 @@ module Data.MessagePack.Object ( -- * MessagePack Object Object(..), + -- * MessagePack conveniences + (.:), (.=), + -- * MessagePack Serializable Types MessagePack(..), typeMismatch, Result(..) ) where @@ -38,8 +41,10 @@ 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 Data.Monoid import qualified Data.Text as T import qualified Data.Text.Lazy as LT +import Data.Typeable import qualified Data.Vector as V import Data.MessagePack.Assoc @@ -92,6 +97,18 @@ data Object -- __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 ObjectArray a -> rnf a diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs index f231bb6..8eefa6a 100644 --- a/msgpack/test/DataCases.hs +++ b/msgpack/test/DataCases.hs @@ -19,7 +19,7 @@ import System.FilePath import Test.Tasty import Test.Tasty.HUnit -import Data.MessagePack +import Data.MessagePack hiding ((.:), (.=)) import Data.MessagePack.Timestamp genDataCases :: [FilePath] -> IO TestTree From bff614bc2dc22e5606c19c140a71fc0ebe7f4580 Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@symbiont.io> Date: Fri, 2 Aug 2019 11:16:12 +0100 Subject: [PATCH 67/75] test for numbers --- msgpack-aeson/test/test.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs index 2a43e4e..442316b 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -6,8 +6,10 @@ import Control.Applicative import Control.Monad import Data.Aeson import Data.Aeson.TH +import Data.Int import Data.MessagePack import Data.MessagePack.Aeson +import Data.Word import GHC.Generics (Generic) import Test.Tasty import Test.Tasty.HUnit @@ -82,4 +84,8 @@ main = 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) ] From 1ecb6c22ac594d991108f5cbbb7b4d4380a05448 Mon Sep 17 00:00:00 2001 From: Rahul Muttineni <rahul.muttineni@symbiont.io> Date: Thu, 8 Aug 2019 21:01:42 +0300 Subject: [PATCH 68/75] Add overlap pragmas to GSumPack --- msgpack/src/Data/MessagePack/Generic.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Generic.hs b/msgpack/src/Data/MessagePack/Generic.hs index 4d8fb31..88dfc34 100644 --- a/msgpack/src/Data/MessagePack/Generic.hs +++ b/msgpack/src/Data/MessagePack/Generic.hs @@ -110,12 +110,12 @@ instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where sizeR = size - sizeL -instance GSumPack (C1 c U1) where +instance {-# OVERLAPPING #-} GSumPack (C1 c U1) where sumToObject code _ _ = toObject code sumFromObject _ _ = gFromObject -instance GMessagePack a => GSumPack (C1 c a) where +instance {-# OVERLAPPABLE #-} GMessagePack a => GSumPack (C1 c a) where sumToObject code _ x = toObject (code, gToObject x) sumFromObject _ _ = gFromObject From 92375c32c949d90ac7a7195c94face5987b3c614 Mon Sep 17 00:00:00 2001 From: Rahul Muttineni <rahul.muttineni@symbiont.io> Date: Tue, 13 Aug 2019 23:31:39 +0300 Subject: [PATCH 69/75] Export useful functions --- msgpack/src/Data/MessagePack/Object.hs | 4 ++++ msgpack/test/DataCases.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 708800c..61694c7 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -21,6 +21,10 @@ module Data.MessagePack.Object ( -- * MessagePack Object Object(..), + withNil, withBool, withInt, + withFloat, withDouble, withBin, withStr, + withArray, withMap, + -- * MessagePack Serializable Types MessagePack(..), typeMismatch, Result(..) ) where diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs index f231bb6..a4aa82c 100644 --- a/msgpack/test/DataCases.hs +++ b/msgpack/test/DataCases.hs @@ -74,7 +74,7 @@ data DataCase = DataCase } deriving Show instance FromYAML DataCase where - parseYAML = withMap "DataCase" $ \m -> do + parseYAML = Y.withMap "DataCase" $ \m -> do msgpack <- m .: "msgpack" obj <- do { Just (Y.Scalar Y.SNull) <- m .:! "nil" ; pure ObjectNil } From bd4625fd20c059fad79f0d8ad08be75e9142a124 Mon Sep 17 00:00:00 2001 From: Rahul Muttineni <rahul.muttineni@symbiont.io> Date: Wed, 14 Aug 2019 10:46:00 +0300 Subject: [PATCH 70/75] DerivingVia generic deriving helper --- msgpack/src/Data/MessagePack/Generic.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/msgpack/src/Data/MessagePack/Generic.hs b/msgpack/src/Data/MessagePack/Generic.hs index 88dfc34..78fa432 100644 --- a/msgpack/src/Data/MessagePack/Generic.hs +++ b/msgpack/src/Data/MessagePack/Generic.hs @@ -5,11 +5,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Data.MessagePack.Generic ( GMessagePack , genericToObject , genericFromObject + , GenericMsgPack(..) ) where import Compat.Prelude @@ -24,6 +26,12 @@ 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) From 407b0b220670315cb2dd4a3ca8f1d7e183c8abb2 Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@symbiont.io> Date: Tue, 13 Aug 2019 16:36:50 +0100 Subject: [PATCH 71/75] fromAeson can fail --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 65 +++++++++++++-------- msgpack-aeson/test/test.hs | 21 +++++-- 2 files changed, 58 insertions(+), 28 deletions(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index e9ab32e..0abca15 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -2,16 +2,18 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} -- | Aeson bridge for MessagePack module Data.MessagePack.Aeson ( -- * Conversion functions toAeson, fromAeson, - viaToJSON, viaFromJSON, + unsafeViaToJSON, viaFromJSON, -- * Wrapper instances AsMessagePack(..), AsAeson(..), + MessagePackAesonError(..), -- * Utility functions packAeson, unpackAeson, @@ -21,15 +23,20 @@ module Data.MessagePack.Aeson ( import Control.Applicative import Control.Arrow import Control.DeepSeq -import Data.Aeson as A -import qualified Data.ByteString.Lazy as L (ByteString) +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 qualified Data.HashMap.Strict as HM +import Data.Int import Data.Maybe -import Data.MessagePack as MP +import Data.MessagePack as MP +import Data.MessagePack.Integer import Data.Scientific -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +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 @@ -40,26 +47,30 @@ toAeson = \case ObjectFloat f -> pure $! Number $! realToFrac f ObjectDouble d -> pure $! Number $! realToFrac d ObjectStr t -> pure (String t) - ObjectBin b -> String <$> either (fail . show) pure (T.decodeUtf8' b) + 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" + ObjectExt _ _ -> fail "ObjectExt is not supported by JSON" -- | Convert JSON 'Value' to 'MP.Object' -fromAeson :: Value -> MP.Object +fromAeson :: Value -> MP.Result MP.Object fromAeson = \case - Null -> ObjectNil - Bool b -> ObjectBool b + Null -> pure ObjectNil + Bool b -> pure $ ObjectBool b Number s -> + -- NOTE floatingOrInteger can OOM on untrusted input case floatingOrInteger s of - Left f -> ObjectDouble f - Right n -> ObjectInt n - String t -> ObjectStr t - Array v -> ObjectArray $ V.map fromAeson v - A.Object o -> ObjectMap $ V.fromList $ map (toObject *** fromAeson) $ HM.toList o + 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. @@ -70,8 +81,14 @@ viaFromJSON o = case toAeson o >>= fromJSON of A.Success a -> MP.Success a A.Error e -> MP.Error e -viaToJSON :: ToJSON a => a -> MP.Object -viaToJSON = fromAeson . toJSON +-- 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) +instance Exception MessagePackAesonError -- | Wrapper for using Aeson values as MessagePack value. newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } @@ -79,7 +96,7 @@ newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } instance (FromJSON a, ToJSON a) => MessagePack (AsMessagePack a) where fromObject o = AsMessagePack <$> (aResult fail pure (fromJSON =<< toAeson o)) - toObject = fromAeson . toJSON . getAsMessagePack + toObject = unsafeViaToJSON . getAsMessagePack -- | Wrapper for using MessagePack values as Aeson value. newtype AsAeson a = AsAeson { getAsAeson :: a } @@ -89,11 +106,13 @@ instance MessagePack a => ToJSON (AsAeson a) where toJSON = aResult (const Null) id . toAeson . toObject . getAsAeson instance MessagePack a => FromJSON (AsAeson a) where - parseJSON = mpResult fail (pure . AsAeson) . fromObject . fromAeson + 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 -> L.ByteString -packAeson = pack . fromAeson . toJSON +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 diff --git a/msgpack-aeson/test/test.hs b/msgpack-aeson/test/test.hs index 442316b..e58462d 100644 --- a/msgpack-aeson/test/test.hs +++ b/msgpack-aeson/test/test.hs @@ -4,10 +4,10 @@ import Control.Applicative import Control.Monad -import Data.Aeson +import Data.Aeson as A import Data.Aeson.TH import Data.Int -import Data.MessagePack +import Data.MessagePack as MP import Data.MessagePack.Aeson import Data.Word import GHC.Generics (Generic) @@ -42,7 +42,7 @@ data W a instance FromJSON a => FromJSON (W a); instance ToJSON a => ToJSON (W a) instance (FromJSON a, ToJSON a) => MessagePack (W a) where - toObject = viaToJSON + toObject = unsafeViaToJSON fromObject = viaFromJSON test :: (MessagePack a, Show a, Eq a) => a -> IO () @@ -53,12 +53,14 @@ test v = do let oa = toObject v print oa - print (fromObject oa == Data.MessagePack.Success v) + 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' = unpackAeson mp + 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 () @@ -88,4 +90,13 @@ main = 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 ] From e47aa0315be50f46762bb126f045598b088bae88 Mon Sep 17 00:00:00 2001 From: Sam Halliday <sam.halliday@symbiont.io> Date: Wed, 14 Aug 2019 09:23:12 +0100 Subject: [PATCH 72/75] fix for older ghc --- msgpack-aeson/src/Data/MessagePack/Aeson.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/msgpack-aeson/src/Data/MessagePack/Aeson.hs b/msgpack-aeson/src/Data/MessagePack/Aeson.hs index 0abca15..d97ecc1 100644 --- a/msgpack-aeson/src/Data/MessagePack/Aeson.hs +++ b/msgpack-aeson/src/Data/MessagePack/Aeson.hs @@ -87,7 +87,8 @@ unsafeViaToJSON a = case fromAeson $ toJSON a of MP.Error e -> throw $ MessagePackAesonError e MP.Success a -> a -data MessagePackAesonError = MessagePackAesonError String deriving (Eq, Show) +data MessagePackAesonError = MessagePackAesonError String + deriving (Eq, Show, Typeable) instance Exception MessagePackAesonError -- | Wrapper for using Aeson values as MessagePack value. From bf065eab22d3b5e35fca0aab78af34c0d61a355b Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@rise-world.com> Date: Tue, 8 Oct 2019 23:03:24 +0200 Subject: [PATCH 73/75] base-4.13 compatibility --- msgpack-aeson/msgpack-aeson.cabal | 2 +- msgpack/msgpack.cabal | 6 +++--- msgpack/src/Data/MessagePack/Object.hs | 5 ++--- msgpack/src/Data/MessagePack/Put.hs | 2 +- msgpack/test/DataCases.hs | 3 +-- 5 files changed, 8 insertions(+), 10 deletions(-) diff --git a/msgpack-aeson/msgpack-aeson.cabal b/msgpack-aeson/msgpack-aeson.cabal index c9a8d7c..063ebd4 100644 --- a/msgpack-aeson/msgpack-aeson.cabal +++ b/msgpack-aeson/msgpack-aeson.cabal @@ -23,7 +23,7 @@ library hs-source-dirs: src exposed-modules: Data.MessagePack.Aeson - build-depends: base >= 4.7 && < 4.13 + build-depends: base >= 4.7 && < 4.14 , aeson >= 0.8.0.2 && < 0.12 || >= 1.0 && < 1.5 , bytestring >= 0.10.4 && < 0.11 diff --git a/msgpack/msgpack.cabal b/msgpack/msgpack.cabal index 1ad62d0..9283e9e 100644 --- a/msgpack/msgpack.cabal +++ b/msgpack/msgpack.cabal @@ -71,18 +71,18 @@ library Compat.Binary Compat.Prelude - build-depends: base >= 4.7 && < 4.13 + 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.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.9 + , time >= 1.4.2 && < 1.10 , int-cast >= 0.1.1 && < 0.3 , array >= 0.5.0 && < 0.6 diff --git a/msgpack/src/Data/MessagePack/Object.hs b/msgpack/src/Data/MessagePack/Object.hs index 5de766a..6d34640 100644 --- a/msgpack/src/Data/MessagePack/Object.hs +++ b/msgpack/src/Data/MessagePack/Object.hs @@ -41,7 +41,6 @@ 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 Data.Monoid import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable @@ -103,8 +102,8 @@ data Object 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) + _ -> 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) diff --git a/msgpack/src/Data/MessagePack/Put.hs b/msgpack/src/Data/MessagePack/Put.hs index a2adfcc..56d98ef 100644 --- a/msgpack/src/Data/MessagePack/Put.hs +++ b/msgpack/src/Data/MessagePack/Put.hs @@ -128,4 +128,4 @@ putExt' typ (sz,putdat) = do ---------------------------------------------------------------------------- toSizeM :: String -> Int -> PutM Word32 -toSizeM label len0 = maybe (fail label) pure (intCastMaybe len0) +toSizeM label len0 = maybe (error label) pure (intCastMaybe len0) diff --git a/msgpack/test/DataCases.hs b/msgpack/test/DataCases.hs index 8eefa6a..d3f6901 100644 --- a/msgpack/test/DataCases.hs +++ b/msgpack/test/DataCases.hs @@ -9,7 +9,6 @@ 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.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import Data.Word @@ -108,7 +107,7 @@ scalarToObj (SUnknown _ _) = error "scalarToValue" hex2bin :: Text -> S.ByteString hex2bin t - | T.null t = mempty + | T.null t = BS.empty | otherwise = BS.pack (map f $ T.split (=='-') t) where f :: T.Text -> Word8 From e9128f61ead97f9f3ae0d35ebed75259a47287f3 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@rise-world.com> Date: Wed, 9 Oct 2019 00:00:08 +0200 Subject: [PATCH 74/75] Make error-reporting more accurate on tag-mismatch errors --- msgpack/src/Data/MessagePack/Get/Internal.hs | 2 +- msgpack/src/Data/MessagePack/Integer.hs | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Get/Internal.hs b/msgpack/src/Data/MessagePack/Get/Internal.hs index e0aaaa0..6429c6b 100644 --- a/msgpack/src/Data/MessagePack/Get/Internal.hs +++ b/msgpack/src/Data/MessagePack/Get/Internal.hs @@ -40,7 +40,7 @@ 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 (fail n) } +mkGet tryT f n = do { tag <- getWord8; tryT tag f empty } <|> fail n getNil :: Get () getNil = mkGet tryNil id "()" diff --git a/msgpack/src/Data/MessagePack/Integer.hs b/msgpack/src/Data/MessagePack/Integer.hs index bc98a3d..dc5d308 100644 --- a/msgpack/src/Data/MessagePack/Integer.hs +++ b/msgpack/src/Data/MessagePack/Integer.hs @@ -255,9 +255,7 @@ putMPInteger (MPInteger True w) = putWord8 TAG_uint64 >> putWord64be (toW64 w) -- -- This operation will only fail if a non-integer MessagePack tag is encountered. getMPInteger :: Get MPInteger -getMPInteger = do - tag <- getWord8 - tryMPInteger tag id (fail "getMPInteger") +getMPInteger = do { tag <- getWord8; tryMPInteger tag id empty } <|> fail "expected MessagePack int" -- | @since 1.1.0.0 {-# INLINE tryMPInteger #-} From f52a5d2db620a7be70810eca648fd152141f8b14 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel <hvr@rise-world.com> Date: Wed, 9 Oct 2019 00:03:50 +0200 Subject: [PATCH 75/75] Tweak error-responses on type mismatches --- msgpack/src/Data/MessagePack/Get/Internal.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/msgpack/src/Data/MessagePack/Get/Internal.hs b/msgpack/src/Data/MessagePack/Get/Internal.hs index 6429c6b..59fe1ee 100644 --- a/msgpack/src/Data/MessagePack/Get/Internal.hs +++ b/msgpack/src/Data/MessagePack/Get/Internal.hs @@ -43,35 +43,35 @@ 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 "()" +getNil = mkGet tryNil id "expected MessagePack nil" getBool :: Get Bool -getBool = mkGet tryBool id "Bool" +getBool = mkGet tryBool id "expected MessagePack bool" getFloat :: Get Float -getFloat = mkGet tryFloat id "Float" +getFloat = mkGet tryFloat id "expected MessagePack float32" getDouble :: Get Double -getDouble = mkGet tryDouble id "Double" +getDouble = mkGet tryDouble id "expected MessagePack float64" getStr :: Get T.Text -getStr = mkGet tryStr id "Str" +getStr = mkGet tryStr id "expected MessagePack str" getBin :: Get S.ByteString -getBin = mkGet tryBin id "Bin" +getBin = mkGet tryBin id "expected MessagePack bin" getArray :: Get a -> Get (V.Vector a) -getArray g = mkGet (tryArray g) id "Array" +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 "Ext" +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 "Ext" +getExt' getdat = mkGet (tryExt' getdat) id "expected MessagePack ext" ---------------------------------------------------------------------------- -- primitives that take a tag as first argument @@ -129,7 +129,6 @@ tryBin tag f cont = case tag of 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