diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,6 @@ +# Changelog for packstream + +## [0.1.0.0] +- Initial support of PackStream protocol +- Test for all available data types +- Partial support of Structure types diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Pavel Yakovlev (c) 2021 + +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 Pavel Yakovlev 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,35 @@ +# packstream + +[![Travis](https://img.shields.io/travis/zmactep/packstream.svg)](https://travis-ci.org/zmactep/packstream) +[![GitHub Build](https://github.com/zmactep/packstream/workflows/build/badge.svg)](https://github.com/zmactep/packstream/actions?query=workflow%3A%22build%22) +[![hackage](https://img.shields.io/hackage/v/packstream.svg)](https://hackage.haskell.org/package/packstream) +[![hackage-deps](https://img.shields.io/hackage-deps/v/packstream.svg)](https://hackage.haskell.org/package/packstream) + +PackStream converter for Neo4j BOLT protocol + +Documentation +------------- + +To build Haddock documentation run: +```bash +$ stack haddock +``` + +Usage example +------------- + +```haskell +ghci> :set -XOverloadedStrings +ghci> import Data.ByteString +ghci> import Data.PackStream +ghci> import Data.PackStream.Internal.Hex +ghci> hex (pack 100500) +"CA00018894" +ghci> hex (pack [True, False, True]) +"93C3C2C3" +ghci> bs <- unhex "93C3C2C3" :: IO ByteString +ghci> unpack bs :: IO [Bool] +[True, False, True] +ghci> unpack bs :: IO [Value] +[B True, B False, B True] +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packstream.cabal b/packstream.cabal new file mode 100644 --- /dev/null +++ b/packstream.cabal @@ -0,0 +1,72 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b8814ee71f844d4802d1ee000fc17039604d267030cc1a1fccb2b68c64a93bba + +name: packstream +version: 0.1.0.0 +synopsis: PackStream converter for Neo4j BOLT protocol +description: Please see the README on GitHub at +category: Data +homepage: https://github.com/zmactep/packstream#readme +bug-reports: https://github.com/zmactep/packstream/issues +author: Pavel Yakovlev +maintainer: pavel@yakovlev.me +copyright: (c) 2021, Pavel Yakovlev +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/zmactep/packstream + +library + exposed-modules: + Data.PackStream + Data.PackStream.Internal.Binary + Data.PackStream.Internal.Code + Data.PackStream.Internal.Hex + Data.PackStream.Internal.Type + Data.PackStream.Parser + Data.PackStream.Serializer + Data.PackStream.Structure + other-modules: + Paths_packstream + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , binary >=0.8.3.0 && <0.11 + , bytestring >=0.10.8.1 && <0.12 + , containers >=0.5.7.1 && <0.7 + , data-binary-ieee754 >=0.4.4 && <0.5 + , mtl >=2.2.0 && <2.3 + , text >=1.2.2.1 && <1.3 + default-language: Haskell2010 + +test-suite packstream-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_packstream + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , binary >=0.8.3.0 && <0.11 + , bytestring >=0.10.8.1 && <0.12 + , containers >=0.5.7.1 && <0.7 + , data-binary-ieee754 >=0.4.4 && <0.5 + , hspec >=2.4.1 && <2.9 + , mtl >=2.2.0 && <2.3 + , packstream + , text >=1.2.2.1 && <1.3 + default-language: Haskell2010 diff --git a/src/Data/PackStream.hs b/src/Data/PackStream.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.PackStream +( + PackStreamError (..), PackStream (..), PackStreamValue (..) +, unpackStream, unpackFail, unpackThrow +, Value (..), (=:) +, Structure (..) +) where + +import Data.PackStream.Internal.Type +import qualified Data.PackStream.Parser as P +import qualified Data.PackStream.Serializer as S + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Map.Strict (Map) +import Control.Monad.Except (MonadError(..), liftEither) + + +-- |The data types that can be interpreted or parsed to/from 'PackStream' 'ByteString' +class PackStreamValue a where + -- |Pack a value into a 'PackStream' 'ByteString' + pack :: a -> ByteString + -- |Parse a value from a 'PackStream' 'ByteString' + unpack :: PackStream a + +instance PackStreamValue () where + pack _ = S.null + unpack = P.null + +instance PackStreamValue Bool where + pack = S.bool + unpack = P.bool + +instance PackStreamValue Int where + pack = S.integer + unpack = P.integer + +instance PackStreamValue Integer where + pack = S.integer . fromIntegral + unpack = fromIntegral <$> P.integer + +instance PackStreamValue Double where + pack = S.float + unpack = P.float + +instance PackStreamValue ByteString where + pack = S.bytes + unpack = P.bytes + +instance PackStreamValue Text where + pack = S.string + unpack = P.string + +instance (ToValue a, PackStreamValue a) => PackStreamValue [a] where + pack = S.list . fmap toValue + unpack = P.list unpack + +instance (ToValue a, PackStreamValue a) => PackStreamValue (Map Text a) where + pack = S.dict . fmap toValue + unpack = P.dict unpack + +instance PackStreamValue Structure where + pack = S.structure + unpack = P.structure + +instance PackStreamValue Value where + pack = S.value + unpack = P.value + +-- |Unpack some value of the specific type from 'ByteString' or raise 'PackStreamError' +unpackThrow :: (MonadError PackStreamError m, PackStreamValue a) => ByteString -> m a +unpackThrow = liftEither . unpackStream unpack + +-- |Unpack some value of the specific type from 'ByteString' or 'fail' +unpackFail :: (MonadFail m, PackStreamValue a) => ByteString -> m a +unpackFail bs = case unpackStream unpack bs of + Right x -> pure x + Left e -> fail $ show e diff --git a/src/Data/PackStream/Internal/Binary.hs b/src/Data/PackStream/Internal/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Internal/Binary.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.PackStream.Internal.Binary where + +import Data.PackStream.Internal.Type ( PackStream, PackStreamError(..) ) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (length) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Binary (Binary, encode, decode) +import Data.Binary.IEEE754 (wordToDouble, doubleToWord) +import Data.Text (Text) +import Data.Int (Int, Int8, Int16, Int32, Int64) +import Control.Applicative (liftA2) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Control.Monad.Except (throwError, MonadError) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) + + +-- |The data types that can be intepreted from 'ByteString' +class Interpret a where + -- |Interpret a 'ByteString' as a specific type of raise 'PackStreamError' + interpret :: MonadError PackStreamError m => ByteString -> m a + + default interpret :: (MonadError PackStreamError m, Binary a) => ByteString -> m a + interpret = pure . decode . fromStrict + +instance Interpret Int8 +instance Interpret Int16 +instance Interpret Int32 +instance Interpret Int64 + +instance Interpret Word8 +instance Interpret Word16 +instance Interpret Word32 +instance Interpret Word64 + +instance Interpret Word where + interpret bs | BS.length bs == 1 = fromIntegral @Word8 <$> interpret bs + | BS.length bs == 2 = fromIntegral @Word16 <$> interpret bs + | BS.length bs == 4 = fromIntegral @Word32 <$> interpret bs + | BS.length bs == 8 = fromIntegral @Word64 <$> interpret bs + | otherwise = throwError NotWord + +instance Interpret Int where + interpret bs | BS.length bs == 1 = fromIntegral @Int8 <$> interpret bs + | BS.length bs == 2 = fromIntegral @Int16 <$> interpret bs + | BS.length bs == 4 = fromIntegral @Int32 <$> interpret bs + | BS.length bs == 8 = fromIntegral @Int64 <$> interpret bs + | otherwise = throwError NotInt + +instance Interpret Integer where + interpret = fmap fromIntegral . interpret @Int + +instance Interpret Double where + interpret = fmap wordToDouble . interpret + +instance Interpret ByteString where + interpret = pure + +instance Interpret Text where + interpret = pure . decodeUtf8 + +-- |The data types that can be serialized into 'ByteString' +class Serialize a where + -- |Serialize a specific data type into a 'ByteString' + serialize :: a -> ByteString + + default serialize :: Binary a => a -> ByteString + serialize = toStrict . encode + +instance Serialize Int8 +instance Serialize Int16 +instance Serialize Int32 +instance Serialize Int64 + +instance Serialize Word8 +instance Serialize Word16 +instance Serialize Word32 +instance Serialize Word64 + +instance Serialize Word where + serialize i | i <= 0xFF = serialize @Word8 $ fromIntegral i + | i <= 0xFFFF = serialize @Word16 $ fromIntegral i + | i <= 0xFFFFFFFF = serialize @Word32 $ fromIntegral i + | i <= 0xFFFFFFFFFFFFFFFF = serialize @Word64 $ fromIntegral i + | otherwise = error "Not a 64-bit unsigned integer" + +instance Serialize Int where + serialize i | inDepth 8 i = serialize @Int8 $ fromIntegral i + | inDepth 16 i = serialize @Int16 $ fromIntegral i + | inDepth 32 i = serialize @Int32 $ fromIntegral i + | inDepth 64 i = serialize @Int64 $ fromIntegral i + | otherwise = error "Not a 64-bit integer" + +instance Serialize Integer where + serialize i | inDepth 64 i = serialize @Int $ fromIntegral i + | otherwise = error "Not a 64-bit integer" + +instance Serialize Double where + serialize = serialize . doubleToWord + +instance Serialize ByteString where + serialize = id + +instance Serialize Text where + serialize = encodeUtf8 + +-- |Check that the 'Integral' value is in the n-bit bounds +inDepth :: Integral a => Int -> a -> Bool +inDepth bitDepth = let bound = 2 ^ (bitDepth - 1) :: Integer + in liftA2 (&&) (>= -bound) (< bound) . fromIntegral diff --git a/src/Data/PackStream/Internal/Code.hs b/src/Data/PackStream/Internal/Code.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Internal/Code.hs @@ -0,0 +1,136 @@ +module Data.PackStream.Internal.Code where + +import Data.Binary (Word8) +import Control.Applicative (liftA2) +import Data.Bits ((.&.)) + +-- * Checkers +-- +-- These functions check the marker bytes of 'ByteString's to +-- identify the represented datatype. There names are self-describing. + +-- |Checks whether the represented data is '()' +isNull :: Word8 -> Bool +isNull = (== nullCode) + +isFalse, isTrue :: Word8 -> Bool +isFalse = (== falseCode) +isTrue = (== trueCode) + +-- |Checks whether the represented data is 'Bool' +isBool :: Word8 -> Bool +isBool = isSmth [isFalse, isTrue] + +isTinyInt, isInt8, isInt16, isInt32, isInt64 :: Word8 -> Bool +isTinyInt = liftA2 (||) (>= 0xF0) (<= 0x7F) +isInt8 = (== int8Code) +isInt16 = (== int16Code) +isInt32 = (== int32Code) +isInt64 = (== int64Code) + +-- |Checks whether the represented data is 'Int' +isInt :: Word8 -> Bool +isInt = isSmth [isTinyInt, isInt8, isInt16, isInt32, isInt64] + +-- |Checks whether the represented data is 'Double' +isFloat :: Word8 -> Bool +isFloat = (== floatCode) + +isBytes8, isBytes16, isBytes32 :: Word8 -> Bool +isBytes8 = (== bytes8Code) +isBytes16 = (== bytes16Code) +isBytes32 = (== bytes32Code) + +-- |Checks whether the represented data is 'ByteString' +isBytes :: Word8 -> Bool +isBytes = isSmth [isBytes8, isBytes16, isBytes32] + +isTinyString, isString8, isString16, isString32 :: Word8 -> Bool +isTinyString = liftA2 (&&) (>= stringTinyCode) (<= stringTinyCode + 0x0F) +isString8 = (== string8Code) +isString16 = (== string16Code) +isString32 = (== string32Code) + +-- |Checks whether the represented data is 'Text' +isString :: Word8 -> Bool +isString = isSmth [isTinyString, isString8, isString16, isString32] + +isTinyList, isList8, isList16, isList32 :: Word8 -> Bool +isTinyList = liftA2 (&&) (>= listTinyCode) (<= listTinyCode + 0x0F) +isList8 = (== list8Code) +isList16 = (== list16Code) +isList32 = (== list32Code) + +-- |Checks whether the represented data is '[Value]' +isList :: Word8 -> Bool +isList = isSmth [isTinyList, isList8, isList16, isList32] + +isTinyDict, isDict8, isDict16, isDict32 :: Word8 -> Bool +isTinyDict = liftA2 (&&) (>= dictTinyCode) (<= dictTinyCode + 0x0F) +isDict8 = (== dict8Code) +isDict16 = (== dict16Code) +isDict32 = (== dict32Code) + +-- |Checks whether the represented data is 'Map Text Value' +isDict :: Word8 -> Bool +isDict = isSmth [isTinyDict, isDict8, isDict16, isDict32] + +-- |Checks whether the represented data is 'Structure' +isStructure :: Word8 -> Bool +isStructure = liftA2 (&&) (>= structureCode) (<= structureCode + 0x0F) + +-- * Helper functions + +-- |Extracts the size of tiny collection ('Text', '[Value]' or 'Map Text Value') +tinySize :: Word8 -> Int +tinySize x = fromIntegral $ x .&. 0x0F + +-- |Gets the collection of predicates and checks whether any is 'True' on some data +isSmth :: (Foldable t, Functor t) => t (b -> Bool) -> b -> Bool +isSmth preds = or . flip fmap preds . flip id + +-- * Codes +-- +-- These are the 'PackStream' constants that mark specific data types. + +nullCode :: Word8 +nullCode = 0xC0 + +falseCode, trueCode :: Word8 +falseCode = 0xC2 +trueCode = 0xC3 + +int8Code, int16Code, int32Code, int64Code :: Word8 +int8Code = 0xC8 +int16Code = 0xC9 +int32Code = 0xCA +int64Code = 0xCB + +floatCode :: Word8 +floatCode = 0xC1 + +bytes8Code, bytes16Code, bytes32Code :: Word8 +bytes8Code = 0xCC +bytes16Code = 0xCD +bytes32Code = 0xCE + +stringTinyCode, string8Code, string16Code, string32Code :: Word8 +stringTinyCode = 0x80 +string8Code = 0xD0 +string16Code = 0xD1 +string32Code = 0xD2 + +listTinyCode, list8Code, list16Code, list32Code :: Word8 +listTinyCode = 0x90 +list8Code = 0xD4 +list16Code = 0xD5 +list32Code = 0xD6 + +dictTinyCode, dict8Code, dict16Code, dict32Code :: Word8 +dictTinyCode = 0xA0 +dict8Code = 0xD8 +dict16Code = 0xD9 +dict32Code = 0xDA + +structureCode :: Word8 +structureCode = 0xB0 diff --git a/src/Data/PackStream/Internal/Hex.hs b/src/Data/PackStream/Internal/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Internal/Hex.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{- + This module is copied from @hex@ module (https://github.com/taruti/haskell-hex), + because it is not supported and was removed from stackage. +-} +module Data.PackStream.Internal.Hex (Hex(..)) where + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +#if !MIN_VERSION_base(4, 13, 0) +import Control.Monad.Fail (MonadFail) +#endif + +-- | Convert strings into hexadecimal and back. +class Hex t where + -- | Convert string into hexadecimal. + hex :: t -> t + -- | Convert from hexadecimal and fail on invalid input. + unhex :: MonadFail m => t -> m t + + +instance Hex String where + hex = Prelude.concatMap w + where w ch = let s = "0123456789ABCDEF" + x = fromEnum ch + in [s !! div x 16,s !! mod x 16] + unhex [] = return [] + unhex (a:b:r) = do x <- c a + y <- c b + (toEnum ((x * 16) + y) :) <$> unhex r + unhex [_] = fail "Non-even length" + + +c :: MonadFail m => Char -> m Int +c '0' = return 0 +c '1' = return 1 +c '2' = return 2 +c '3' = return 3 +c '4' = return 4 +c '5' = return 5 +c '6' = return 6 +c '7' = return 7 +c '8' = return 8 +c '9' = return 9 +c 'A' = return 10 +c 'B' = return 11 +c 'C' = return 12 +c 'D' = return 13 +c 'E' = return 14 +c 'F' = return 15 +c 'a' = return 10 +c 'b' = return 11 +c 'c' = return 12 +c 'd' = return 13 +c 'e' = return 14 +c 'f' = return 15 +c _ = fail "Invalid hex digit!" + +instance Hex B.ByteString where + hex = B.pack . hex . B.unpack + unhex x = fmap B.pack $ unhex $ B.unpack x + +instance Hex L.ByteString where + hex = L.pack . hex . L.unpack + unhex x = fmap L.pack $ unhex $ L.unpack x diff --git a/src/Data/PackStream/Internal/Type.hs b/src/Data/PackStream/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Internal/Type.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeApplications #-} +module Data.PackStream.Internal.Type where + +import Control.Monad.Except (ExceptT, MonadError (..), runExceptT) +import Control.Monad.State (State, MonadState, evalState) +import Data.ByteString (ByteString) +import Data.Binary (Word8) +import Data.Map.Strict (Map) +import Data.Text (Text) + +-- * PackStream basics + +-- PackStream is a general purpose data serialisation format, originally inspired +-- by (but incompatible with) MessagePack. This module provides basic types +-- and typeclasses to help you to parse or to serialize. + +-- |Basic 'PackStream' error type that is used to handle parsing errors. +data PackStreamError = NotNull -- ^This 'ByteString' doesn't represent null object + | NotBool -- ^This 'ByteString' doesn't represent any boolean + | NotWord -- ^This 'ByteString' doesn't represent any unsigned integer + | NotInt -- ^This 'ByteString' doesn't represent any integer + | NotFloat -- ^This 'ByteString' doesn't represent any floating-point number + | NotString -- ^This 'ByteString' doesn't represent any 'Text' string + | NotBytes -- ^This 'ByteString' doesn't represent any 'ByteString' array + | NotList -- ^This 'ByteString' doesn't represent any list of 'PackStream' values + | NotDict -- ^This 'ByteString' doesn't represent any dictionary of 'PackStream' values + | NotStructure -- ^This 'ByteString' doesn't represent any 'Structure' + | NotValue -- ^This 'ByteString' doesn't represent any 'Value' + | WrongStructure Text -- ^This 'ByteString' doesn't represent specific 'Structure' + deriving (Show, Eq, Ord) + +-- |Basic parser type. It works like parser combinators for binary data that represents PackStream. +newtype PackStream a = PackStream { runUnpackS :: ExceptT PackStreamError (State ByteString) a } + deriving (Functor, Applicative, Monad, MonadState ByteString, MonadError PackStreamError) + +-- |Use specific parser combinator to parse the 'ByteString' that represents any 'PackStream' data. +unpackStream :: PackStream a -> ByteString -> Either PackStreamError a +unpackStream action = evalState (runExceptT $ runUnpackS action) + +-- |PackStream offers a number of core data types, many supported by multiple binary representations, as well as a flexible extension mechanism. +data Value = N -- ^Missing or empty value + | B Bool -- ^True or False + | I Int -- ^Signed 64-bit integer + | F Double -- ^64-bit floating point number + | U ByteString -- ^Byte array + | T Text -- ^Unicode text, UTF-8 + | L [Value] -- ^Ordered collection of 'Value's + | D (Map Text Value) -- ^Collection of key-value entries (no order guaranteed) + | S Structure -- ^Composite value with a type signature + deriving (Show, Eq) + +-- |A structure is a composite value, comprised of fields and a unique type code. +-- Structure encodings consist, beyond the marker, of a single byte, the tag byte, followed +-- by a sequence of up to 15 fields, each an individual value. The size of a structure is +-- measured as the number of fields and not the total byte size. This count does not include the tag. +data Structure = Structure { signature :: Word8 -- ^Type code + , fields :: [Value] -- ^Structure fields + } + deriving (Show, Eq) + +-- |The data types that can be serialized as 'PackStream' +class ToValue a where + -- |Convert data type to the generic 'Value' + toValue :: a -> Value + +instance ToValue () where + toValue = const N + +instance ToValue Bool where + toValue = B + +instance ToValue Int where + toValue = I + +instance ToValue Integer where + toValue = toValue @Int . fromIntegral + +instance ToValue Double where + toValue = F + +instance ToValue ByteString where + toValue = U + +instance ToValue Text where + toValue = T + +instance ToValue a => ToValue [a] where + toValue = L . fmap toValue + +instance ToValue a => ToValue (Map Text a) where + toValue = D . fmap toValue + +instance ToValue Structure where + toValue = S + +instance ToValue Value where + toValue = id + +-- |Represent a 'Text' key and some 'ToValue' data into the 'Map' pair. +-- Can be useful to work with 'PackStream' dictionaries. +-- +-- > fromList ["hello" =: 1, "world" =: False] +(=:) :: ToValue a => Text -> a -> (Text, Value) +(=:) key val = (key, toValue val) + +-- |The data types taht can be read from 'PackStream' representation +class FromValue a where + -- |Converts generic 'Value' type to a specific one or raises 'PackStreamError' + fromValue :: Value -> Either PackStreamError a + +instance FromValue () where + fromValue N = pure () + fromValue _ = throwError NotNull + +instance FromValue Bool where + fromValue (B x) = pure x + fromValue _ = throwError NotBool + +instance FromValue Int where + fromValue (I x) = pure x + fromValue _ = throwError NotInt + +instance FromValue Integer where + fromValue = fmap fromIntegral . fromValue @Int + +instance FromValue Double where + fromValue (F x) = pure x + fromValue _ = throwError NotFloat + +instance FromValue ByteString where + fromValue (U x) = pure x + fromValue _ = throwError NotBytes + +instance FromValue Text where + fromValue (T x) = pure x + fromValue _ = throwError NotString + +instance FromValue a => FromValue [a] where + fromValue (L xs) = traverse fromValue xs + fromValue _ = throwError NotList + +instance FromValue a => FromValue (Map Text a) where + fromValue (D mp) = traverse fromValue mp + fromValue _ = throwError NotDict + +instance FromValue Structure where + fromValue (S x) = pure x + fromValue _ = throwError NotStructure + +instance FromValue Value where + fromValue = pure diff --git a/src/Data/PackStream/Parser.hs b/src/Data/PackStream/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Parser.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Data.PackStream.Parser +( + null, bool, integer, float, + bytes, string, list, dict, structure, + value +) where + +import Data.PackStream.Internal.Type ( PackStream, PackStreamError(..), Structure(..), Value(..) ) +import Data.PackStream.Internal.Code +import Data.PackStream.Internal.Binary ( Interpret(..) ) + +import Prelude hiding (null) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (head, tail, drop, take, singleton) +import Data.Text (Text) +import Data.Map.Strict (Map, fromList) +import Data.Binary (Word8) +import Control.Monad.State ( gets, modify ) +import Control.Monad.Except (throwError) +import Control.Monad (replicateM, (>=>)) + + +-- |Parse '()' +null :: PackStream () +null = bite1 >>= select NotNull [ (isNull, pure ()) ] + +-- |Parse 'Bool' +bool :: PackStream Bool +bool = bite1 >>= select NotBool [ (isTrue, pure True) + , (isFalse, pure False) + ] + +-- |Parse 'Int' +integer :: PackStream Int +integer = bite1 >>= \x -> select NotInt [ (isTinyInt, interpret $ BS.singleton x) + , (isInt8, bite 1 >>= interpret) + , (isInt16, bite 2 >>= interpret) + , (isInt32, bite 4 >>= interpret) + , (isInt64, bite 8 >>= interpret) + ] x + +-- |Parse 'Double' +float :: PackStream Double +float = bite1 >>= select NotFloat [ (isFloat, bite 8 >>= interpret) ] + +-- |Parse 'ByteString' +bytes :: PackStream ByteString +bytes = bite1 >>= select NotBytes [ (isBytes8, bite'by'bytes 1) + , (isBytes16, bite'by'bytes 2) + , (isBytes32, bite'by'bytes 4) + ] + +-- |Parse 'Text' +string :: PackStream Text +string = bite1 >>= \x -> select NotBytes [ (isTinyString, bite (tinySize x) >>= interpret) + , (isString8, bite'by'bytes 1 >>= interpret) + , (isString16, bite'by'bytes 2 >>= interpret) + , (isString32, bite'by'bytes 4 >>= interpret) + ] x + +-- |Parse a list of specified 'Value's (e.g. `list integer` will parse some '[Int]') +list :: PackStream a -> PackStream [a] +list action = bite1 >>= \x -> select NotList [ (isTinyList, multiple action (tinySize x)) + , (isList8, collectionSize 1 >>= multiple action) + , (isList16, collectionSize 2 >>= multiple action) + , (isList32, collectionSize 4 >>= multiple action) + ] x + +-- |Parse a dictionary of specified 'Value's (e.g. `dict integer` will parse some 'Map Text Int') +dict :: forall a.PackStream a -> PackStream (Map Text a) +dict action = bite1 >>= \x -> select NotDict [ (isTinyDict, makeDict (tinySize x)) + , (isDict8, collectionSize 1 >>= makeDict) + , (isDict16, collectionSize 2 >>= makeDict) + , (isDict32, collectionSize 4 >>= makeDict) + ] x + where + makeDict :: Int -> PackStream (Map Text a) + makeDict = (fromList <$>) . multiple ((,) <$> string <*> action) + +-- |Parse 'Structure' +structure :: PackStream Structure +structure = bite1 >>= \x -> select NotStructure [ (isStructure, makeStructure (tinySize x)) ] x + where + makeStructure :: Int -> PackStream Structure + makeStructure n = Structure <$> bite1 <*> multiple value n + +-- |Parse any valid 'Value' +value :: PackStream Value +value = look1 >>= byMarker + where + byMarker :: Word8 -> PackStream Value + byMarker n | isNull n = N <$ null + | isBool n = B <$> bool + | isInt n = I <$> integer + | isFloat n = F <$> float + | isBytes n = U <$> bytes + | isString n = T <$> string + | isList n = L <$> list value + | isDict n = D <$> dict value + | isStructure n = S <$> structure + | otherwise = throwError NotValue + +-- |Selects a parser to use by the marker byte predicate. Raises the 'PackStreamError' if nothing is suitable +select :: PackStreamError -> [(Word8 -> Bool, PackStream a)] -> Word8 -> PackStream a +select e [] _ = throwError e +select e ((p, action):xs) w | p w = action + | otherwise = select e xs w + +-- |Gets one byte from the 'ByteString' +bite1 :: PackStream Word8 +bite1 = do b <- gets BS.head + modify BS.tail + pure b + +-- |Gets the specified number of bytes from the 'ByteString' +bite :: Int -> PackStream ByteString +bite n = do bs <- gets $ BS.take n + modify $ BS.drop n + pure bs + +-- |Looks at the first byte of the 'ByteString' without modifying it +look1 :: PackStream Word8 +look1 = gets BS.head + +-- |Gets the specified number of bytes from the 'ByteString', +-- interprets them as some unsigned int ('Word') and then get the specified number of +-- further bytes from the 'ByteString' +bite'by'bytes :: Int -> PackStream ByteString +bite'by'bytes n = collectionSize n >>= bite + +-- |Performs some 'PackStream' parser combinator the specified number of times +multiple :: PackStream a -> Int -> PackStream [a] +multiple action n = replicateM n action + +-- |Gets the specified number of bytes from the 'ByteString' and +-- interprets them as some unsigned int ('Word') +collectionSize :: Int -> PackStream Int +collectionSize n = bite n >>= fmap fromIntegral . interpret @Word diff --git a/src/Data/PackStream/Serializer.hs b/src/Data/PackStream/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Serializer.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE TypeApplications #-} +module Data.PackStream.Serializer +( + null, bool, integer, float, + bytes, string, list, dict, structure, + value +) where + + +import Data.PackStream.Internal.Type (Structure (..), Value (..)) +import Data.PackStream.Internal.Code +import Data.PackStream.Internal.Binary (Serialize(..), inDepth) + +import Prelude hiding (null) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (singleton, cons, append, length, concat, empty) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Map.Strict (Map, toList) +import Data.Word (Word8, Word) + + +-- |Represent '()' as 'PackStream' 'ByteString' +null :: ByteString +null = BS.singleton nullCode + +-- |Represent 'Bool' as 'PackStream' 'ByteString' +bool :: Bool -> ByteString +bool False = BS.singleton falseCode +bool True = BS.singleton trueCode + +-- |Represent 'Int' as 'PackStream' 'ByteString' +integer :: Int -> ByteString +integer n | n >= -16 && n < 128 = serialize n + | inDepth 8 n = int8Code `BS.cons` serialize n + | inDepth 16 n = int16Code `BS.cons` serialize n + | inDepth 32 n = int32Code `BS.cons` serialize n + | inDepth 64 n = int64Code `BS.cons` serialize n + | otherwise = BS.empty + +-- |Represent 'Double' as 'PackStream' 'ByteString' +float :: Double -> ByteString +float x = floatCode `BS.cons` serialize x + +-- |Represent 'ByteString' as 'PackStream' 'ByteString' +bytes :: ByteString -> ByteString +bytes bs = constructCollection mstart bs + where + mstart :: Maybe ByteString + mstart = (`BS.cons` serializeLen (BS.length bs)) <$> firstByte + + firstByte :: Maybe Word8 + firstByte | BS.length bs <= 0xFF = pure bytes8Code + | BS.length bs <= 0xFFFF = pure bytes16Code + | BS.length bs <= 0xFFFFFFFF = pure bytes32Code + | otherwise = Nothing + +-- |Represent 'Text' as 'PackStream' 'ByteString' +string :: Text -> ByteString +string s = constructCollection mstart (serialize s) + where + mstart :: Maybe ByteString + mstart = firstBytes stringTinyCode string8Code string16Code string32Code (BS.length $ encodeUtf8 s) + +-- |Represent '[Value]' as 'PackStream' 'ByteString' +list :: [Value] -> ByteString +list l = constructCollection mstart (BS.concat (value <$> l)) + where + mstart :: Maybe ByteString + mstart = firstBytes listTinyCode list8Code list16Code list32Code (length l) + +-- |Represent 'Map Text Value' as 'PackStream' 'ByteString' +dict :: Map Text Value -> ByteString +dict d = constructCollection mstart (BS.concat (kvs <$> toList d)) + where + mstart :: Maybe ByteString + mstart = firstBytes dictTinyCode dict8Code dict16Code dict32Code (length d) + + kvs :: (Text, Value) -> ByteString + kvs (k, v) = string k `BS.append` value v + +-- |Represent 'Structure' as 'PackStream' 'ByteString' +structure :: Structure -> ByteString +structure s | len < 16 = structureCode + len `BS.cons` signature s `BS.cons` BS.concat (value <$> fields s) + | otherwise = BS.empty + where + len = fromIntegral $ length $ fields s + +-- |Represent 'Value' as 'PackStream' 'ByteString' +value :: Value -> ByteString +value N = null +value (B b) = bool b +value (I i) = integer i +value (F f) = float f +value (U u) = bytes u +value (T t) = string t +value (L l) = list l +value (D d) = dict d +value (S s) = structure s + +-- Helper functions + +constructCollection :: Maybe ByteString -> ByteString -> ByteString +constructCollection mstart end = case mstart of + Just start -> start `BS.append` end + Nothing -> BS.empty + +firstBytes :: Word8 -> Word8 -> Word8 -> Word8 -> Int -> Maybe ByteString +firstBytes bt b8 b16 b32 len | len <= 0xF = pure $ BS.singleton $ bt + fromIntegral len + | len <= 0xFF = pure $ b8 `BS.cons` serializeLen len + | len <= 0xFFFF = pure $ b16 `BS.cons` serializeLen len + | len <= 0xFFFFFFFF = pure $ b32 `BS.cons` serializeLen len + | otherwise = Nothing + +serializeLen :: Int -> ByteString +serializeLen = serialize @Word . fromIntegral diff --git a/src/Data/PackStream/Structure.hs b/src/Data/PackStream/Structure.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream/Structure.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.PackStream.Structure +( ToStructure (..), FromStructure (..) +, Node (..), Relationship (..), UnboundRelationship (..), Path (..) +, Date (..), Time (..), LocalTime (..), DateTime (..), DateTimeZoneId (..), LocalDateTime (..) +, Duration (..) +, Point2D (..), Point3D (..) +) where + +import Data.Text (Text) +import Data.Map.Strict (Map) +import Control.Monad.Except (MonadError(..)) +import Control.Monad ((>=>)) + +import Data.PackStream.Internal.Type +import Data.PackStream ( PackStreamValue(..) ) + +-- * Structure coverters +-- +-- 'PackStream' protocol provides several built-in 'Structure' types. They +-- are the objects with specific fields and one-byte structure signature. +-- The 'ToStructure' and 'FromStructure' typeclasses help to convert +-- Haskell representation of these objects into and from generic 'Structure' +-- type. + +-- |The set of types, that can be presented as 'PackStream' 'Structure's +class ToStructure a where + -- |Convert object to 'Structure' + toStructure :: a -> Structure + +-- |The set of types, that can be parsed from 'PackStream' 'Structure's +class FromStructure a where + -- |Convert 'Structure' to the object of selected type + fromStructure :: Structure -> Either PackStreamError a + +-- * Built-in structure types + +-- |Snapshot of a node within a graph database +data Node = Node { nodeId :: Int -- ^Node identifier + , labels :: [Text] -- ^List of node labels + , nodeProps :: Map Text Value -- ^Dict of node properties + } + deriving (Show, Eq) + +instance ToStructure Node where + toStructure Node{..} = Structure 0x4E [ toValue nodeId + , toValue labels + , toValue nodeProps + ] + +instance FromStructure Node where + fromStructure (Structure 0x4E [I nid, L lbls, D nps]) = Node nid <$> traverse fromValue lbls <*> pure nps + fromStructure _ = throwError $ WrongStructure "Node" + +-- |Snapshot of a relationship within a graph database +data Relationship = Relationship { relId :: Int -- ^Relationship identifier + , startNodeId :: Int -- ^Identifier of the start node + , endNodeId :: Int -- ^Identifier of the end node + , relType :: Text -- ^Relationship type + , relProps :: Map Text Value -- ^Dict of relationship properties + } + deriving (Show, Eq) + +instance ToStructure Relationship where + toStructure Relationship{..} = Structure 0x52 [ toValue relId + , toValue startNodeId + , toValue endNodeId + , toValue relType + , toValue relProps + ] + +instance FromStructure Relationship where + fromStructure (Structure 0x52 [I rid, I snid, I enid, T rt, D rps]) = pure $ Relationship rid snid enid rt rps + fromStructure _ = throwError $ WrongStructure "Relationship" + +-- |Relationship detail without start or end node information +data UnboundRelationship = UnboundRelationship { urelId :: Int -- ^Relationship identifier + , urelType :: Text -- ^Relationship type + , urelProps :: Map Text Value -- ^Dict of relationship properties + } + deriving (Show, Eq) + +instance ToStructure UnboundRelationship where + toStructure UnboundRelationship{..} = Structure 0x72 [ toValue urelId + , toValue urelType + , toValue urelProps + ] + +instance FromStructure UnboundRelationship where + fromStructure (Structure 0x72 [I rid, T rt, D rps]) = pure $ UnboundRelationship rid rt rps + fromStructure _ = throwError $ WrongStructure "UnboundRelationship" + +-- |Alternating sequence of nodes and relationships +data Path = Path { nodes :: [Node] -- ^Chain of 'Node's in path + , rels :: [UnboundRelationship] -- ^Chain of 'UnboundRelationship's in path + , ids :: [Int] -- ^The ids is a list of relationship id and node id to represent the path + } + deriving (Show, Eq) + +instance ToStructure Path where + toStructure Path{..} = Structure 0x50 [ toValue $ fmap toStructure nodes + , toValue $ fmap toStructure rels + , toValue ids + ] + +instance FromStructure Path where + fromStructure (Structure 0x50 [L nds, L rls, L is]) = Path <$> traverse (fromValue >=> fromStructure) nds + <*> traverse (fromValue >=> fromStructure) rls + <*> traverse fromValue is + +-- |The days are days since the Unix epoch +newtype Date = Date { days :: Int -- ^The days are days since the Unix epoch + } + deriving (Show, Eq) + +instance ToStructure Date where + toStructure Date{..} = Structure 0x44 [toValue days] + +instance FromStructure Date where + fromStructure (Structure 0x44 [I ds]) = pure $ Date ds + fromStructure _ = throwError $ WrongStructure "Date" + +data Time +data LocalTime +data DateTime +data DateTimeZoneId +data LocalDateTime +data Duration +data Point2D +data Point3D diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Hspec +import Data.Text (Text) +import qualified Data.Text as T (unpack) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B (pack, unpack, take, empty) +import Data.ByteString.Lazy (toStrict, fromStrict) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M (empty, fromList) + +import Data.PackStream (PackStreamValue (..), Value(..), (=:), unpackFail) +import Data.PackStream.Internal.Hex (Hex(..)) + + +main :: IO () +main = hspec $ do serializeSpec + parseSpec + +serializeSpec :: Spec +serializeSpec = + describe "Serializer" $ do + it "packs ()" $ + hex (pack ()) `shouldBe` "C0" + it "packs Bool" $ do + hex (pack False) `shouldBe` "C2" + hex (pack True) `shouldBe` "C3" + it "packs Int" $ do + hex (pack (1::Int)) `shouldBe` "01" + hex (pack (42::Int)) `shouldBe` "2A" + hex (pack (32767::Int)) `shouldBe` "C97FFF" + hex (pack (-32768::Int)) `shouldBe` "C98000" + hex (pack (9223372036854775807::Int)) `shouldBe` "CB7FFFFFFFFFFFFFFF" + hex (pack (-9223372036854775808::Int)) `shouldBe` "CB8000000000000000" + it "packs Integer" $ do + hex (pack (1::Integer)) `shouldBe` "01" + hex (pack (42::Integer)) `shouldBe` "2A" + hex (pack (1234::Integer)) `shouldBe` "C904D2" + hex (pack (32767::Integer)) `shouldBe` "C97FFF" + hex (pack (-32768::Integer)) `shouldBe` "C98000" + hex (pack (-9223372036854775808::Integer)) `shouldBe` "CB8000000000000000" + it "packs Double" $ do + hex (pack (6.283185307179586::Double)) `shouldBe` "C1401921FB54442D18" + hex (pack (-1.1::Double)) `shouldBe` "C1BFF199999999999A" + it "packs ByteString" $ do + hex (pack B.empty) `shouldBe` "CC00" + hex (pack (B.pack [1, 2, 3])) `shouldBe` "CC03010203" + B.take 12 (hex (pack (B.pack [1 .. 255]))) `shouldBe` "CCFF01020304" + B.take 14 (hex (pack (B.pack [0 .. 255]))) `shouldBe` "CD010000010203" + it "packs Text" $ do + hex (pack (""::Text)) `shouldBe` "80" + hex (pack ("ABCDE"::Text)) `shouldBe` "854142434445" + hex (pack ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"::Text)) `shouldBe` "D01A4142434445464748494A4B4C4D4E4F505152535455565758595A" + hex (pack ("Größenmaßstäbe"::Text)) `shouldBe` "D0124772C3B6C39F656E6D61C39F7374C3A46265" + it "packs []" $ do + hex (pack ([]::[Int])) `shouldBe` "90" + hex (pack [1::Int, 2, 3]) `shouldBe` "93010203" + hex (pack [I 1, F (-1.1), T "", B False]) `shouldBe` "9401C1BFF199999999999A80C2" + hex (pack [1::Int .. 32]) `shouldBe` "D4200102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20" + B.take 14 (hex (pack [0::Int .. 255])) `shouldBe` "D5010000010203" + it "packs Map" $ do + hex (pack (M.empty::Map Text Int)) `shouldBe` "A0" + hex (pack (M.fromList ["A" =: True, "B" =: False])) `shouldBe` "A28141C38142C2" + hex (pack (M.fromList ["A" =: (1::Int), "B" =: ("ABCDE"::Text)])) `shouldBe` "A28141018142854142434445" + hex (pack bigMap) `shouldBe` bigMapBS + +parseSpec :: Spec +parseSpec = + describe "Parser" $ do + it "parses ()" $ do + v <- prepareData "C0" >>= unpackFail :: IO () + v `shouldBe` () + it "parses Bool" $ do + t <- prepareData "C3" >>= unpackFail :: IO Bool + t `shouldBe` True + f <- prepareData "C2" >>= unpackFail :: IO Bool + f `shouldBe` False + it "parses Int" $ do + u1 <- prepareData "01" >>= unpackFail :: IO Int + u1 `shouldBe` 1 + u42 <- prepareData "2A" >>= unpackFail :: IO Int + u42 `shouldBe` 42 + u32767 <- prepareData "C97FFF" >>= unpackFail :: IO Int + u32767 `shouldBe` 32767 + umin <- prepareData "CB8000000000000000" >>= unpackFail :: IO Int + umin `shouldBe` (-9223372036854775808) + it "parses Integer" $ do + u1 <- prepareData "01" >>= unpackFail :: IO Integer + u1 `shouldBe` 1 + u42 <- prepareData "2A" >>= unpackFail :: IO Integer + u42 `shouldBe` 42 + u1234 <- prepareData "C97FFF" >>= unpackFail :: IO Integer + u1234 `shouldBe` 32767 + umin <- prepareData "CB8000000000000000" >>= unpackFail :: IO Integer + umin `shouldBe` (-9223372036854775808) + it "parses Double" $ do + uf <- prepareData "C1BFF199999999999A" >>= unpackFail :: IO Double + uf `shouldBe` (-1.1) + us <- prepareData "C1401921FB54442D18" >>= unpackFail :: IO Double + us `shouldBe` 6.283185307179586 + it "parses ByteString" $ do + uemp <- prepareData "CC00" >>= unpackFail :: IO ByteString + B.unpack uemp `shouldBe` [] + usmall <- prepareData "CC03010203" >>= unpackFail :: IO ByteString + B.unpack usmall `shouldBe` [1, 2, 3] + u255 <- unpackFail (B.pack $ [0xCC, 0xFF] ++ [1 .. 255]) :: IO ByteString + B.unpack u255 `shouldBe` [1 .. 255] + u256 <- unpackFail (B.pack $ [0xCD, 0x01, 0x00] ++ [0 .. 255]) :: IO ByteString + B.unpack u256 `shouldBe` [0 .. 255] + it "parses Text" $ do + uemp <- prepareData "80" >>= unpackFail :: IO Text + T.unpack uemp `shouldBe` "" + usmall <- prepareData "854142434445" >>= unpackFail :: IO Text + T.unpack usmall `shouldBe` "ABCDE" + ubig <- prepareData "D01A4142434445464748494A4B4C4D4E4F505152535455565758595A" >>= unpackFail :: IO Text + T.unpack ubig `shouldBe` "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + uutf <- prepareData "D0124772C3B6C39F656E6D61C39F7374C3A46265" >>= unpackFail :: IO Text + uutf `shouldBe` "Größenmaßstäbe" + it "parses []" $ do + uemp <- prepareData "90" >>= unpackFail :: IO [Bool] + uemp `shouldBe` [] + usmall <- prepareData "9401C1BFF199999999999A80C2" >>= unpackFail :: IO [Value] + usmall `shouldBe` [I 1, F (-1.1), T "", B False] + ubig <- prepareData "D4200102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20" >>= unpackFail :: IO [Int] + ubig `shouldBe` [1 .. 32] + it "parses Map" $ do + uemp <- prepareData "A0" >>= unpackFail :: IO (Map Text Int) + uemp `shouldBe` M.empty + usmall <- prepareData "A28141018142854142434445" >>= unpackFail :: IO (Map Text Value) + usmall `shouldBe` M.fromList ["A" =: (1::Int), "B" =: ("ABCDE"::Text)] + ubig <- prepareData bigMapBS >>= unpackFail :: IO (Map Text Int) + ubig `shouldBe` bigMap + +-- Helper + +prepareData :: MonadFail m => ByteString -> m ByteString +prepareData = (toStrict <$>) . unhex . fromStrict + +bigMap :: Map Text Int +bigMap = M.fromList [ ("A", 1), ("B", 2), ("C", 3), ("D", 4), ("E", 5) + , ("F", 6), ("G", 7), ("H", 8), ("I", 9), ("J", 10) + , ("K", 11), ("L", 12), ("M", 13), ("N", 14), ("O", 15) + , ("P", 16), ("Q", 17), ("R", 18), ("S", 19), ("T", 20) + , ("U", 21), ("V", 22), ("W", 23), ("X", 24), ("Y", 25) + , ("Z", 26)] + + +bigMapBS :: ByteString +bigMapBS = "D81A814101814202814303814404814505814606814707814808814909814A0A814B0B814C0C814D0D814E0E814F0F815010815111815212815313815414815515815616815717815818815919815A1A"