diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2016 Mikhail Vorozhtsov +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 names of the copyright owners nor the names of the + 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,15 @@ +Data-Serializer +=============== + +[![Hackage](https://img.shields.io/hackage/v/data-serializer.svg)](http://hackage.haskell.org/package/data-serializer) + +This package provides a common API for serialization libraries like +[binary](http://hackage.haskell.org/package/binary) and +[cereal](http://hackage.haskell.org/package/cereal). + +Installation +------------ +The usual: + + $ cabal install + 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/data-serializer.cabal b/data-serializer.cabal new file mode 100644 --- /dev/null +++ b/data-serializer.cabal @@ -0,0 +1,56 @@ +Name: data-serializer +Version: 0.1 +Category: Data +Stability: experimental +Synopsis: Common API for serialization libraries +Description: + This package provides a common API for serialization libraries like + and + . + +Homepage: https://github.com/mvv/data-serializer +Bug-Reports: https://github.com/mvv/data-serializer/issues + +Author: Mikhail Vorozhtsov +Maintainer: Mikhail Vorozhtsov +Copyright: 2016 Mikhail Vorozhtsov +License: BSD3 +License-File: LICENSE + +Extra-Source-Files: + README.md + +Cabal-Version: >= 1.10.0 +Build-Type: Simple + +Source-Repository head + Type: git + Location: https://github.com/mvv/data-serializer.git + +Library + Default-Language: Haskell2010 + Build-Depends: base >= 4.7 && < 5 + , bytestring >= 0.10.4 + , binary >= 0.7.2 + , cereal >= 0.5 + , data-endian >= 0.1.1 + , parsers >= 0.12.3 + Hs-Source-Dirs: src + GHC-Options: -Wall + Exposed-Modules: + Data.Serializer + Data.Deserializer + +Test-Suite tests + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + Build-Depends: base + , bytestring + , binary + , cereal + , tasty >= 0.8 + , tasty-quickcheck >= 0.8 + , data-serializer + Hs-Source-Dirs: tests + GHC-Options: -Wall + Main-Is: Tests.hs diff --git a/src/Data/Deserializer.hs b/src/Data/Deserializer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Deserializer.hs @@ -0,0 +1,770 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Deserialization monad and deserializable types. +module Data.Deserializer + ( + -- * Deserialization monad + Deserializer(..) + , BinaryDeserializer(..) + , CerealDeserializer(..) + -- ** Binary word parsing + , word16H + , word32H + , word64H + , word + , wordL + , wordB + , wordH + , int8 + , int16 + , int16L + , int16B + , int16H + , int32 + , int32L + , int32B + , int32H + , int64 + , int64L + , int64B + , int64H + , int + , intL + , intB + , intH + -- ** Parsing combinators + , module Text.Parser.Combinators + , label + , module Text.Parser.LookAhead + -- ** Endian deserializers + , LittleEndianDeserializer(..) + , BigEndianDeserializer(..) + , deserializeIn + , deserializeH + -- * Deserializable types + , Deserializable(..) + , getIn + , getL + , getB + , getH + , RestDeserializable(..) + ) where + +import Prelude hiding (take) +import GHC.Generics (Generic) +import Data.Typeable (Typeable) +import Data.Data (Data) +import Data.Proxy (Proxy(..)) +import Data.Endian (Endian(..), swapEndian) +import Data.Word +import Data.Int +import Data.Bits ((.|.), shiftL) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Builder as BB +import qualified Data.Binary.Get as B +import qualified Data.Binary.Get.Internal as B +import qualified Data.Serialize.Get as S +import Text.Parser.Combinators +import Text.Parser.LookAhead +import Control.Applicative (Applicative(..), Alternative, + (<$>), (<$), (<*>), (*>), (<|>)) +import Control.Monad (unless) + +-- | Deserialization monad. +class (Monad μ, Parsing μ) ⇒ Deserializer μ where + {-# MINIMAL ensure, take, chunk, isolate #-} + -- | Default byte order of the deserializer. + endian ∷ Proxy μ → Endian +#ifdef WORDS_BIGENDIAN + endian _ = BigEndian +#else + endian _ = LittleEndian +#endif + -- | Deserialze a byte. + word8 ∷ μ Word8 + word8 = BS.unsafeHead <$> take 1 "word8" + {-# INLINE word8 #-} + -- | Deserialize an unsigned 16-bit integer in default byte order. + word16 ∷ μ Word16 + word16 = getIn (endian (Proxy ∷ Proxy μ)) + {-# INLINE word16 #-} + -- | Deserialize an unsigned 32-bit integer in default byte order. + word32 ∷ μ Word32 + word32 = getIn (endian (Proxy ∷ Proxy μ)) + {-# INLINE word32 #-} + -- | Deserialize an unsigned 64-bit integer in default byte order. + word64 ∷ μ Word64 + word64 = getIn (endian (Proxy ∷ Proxy μ)) + {-# INLINE word64 #-} + -- | Deserialize an unsigned 16-bit integer in little endian. + word16L ∷ μ Word16 + word16L = ( "word16") + $ do bs ← take 2 + let l = BS.unsafeIndex bs 0 + h = BS.unsafeIndex bs 1 + return $ shiftL (fromIntegral h) 8 .|. fromIntegral l + -- | Deserialize an unsigned 16-bit integer in big endian. + word16B ∷ μ Word16 + word16B = swapEndian <$> word16L + -- | Deserialize an unsigned 32-bit integer in little endian. + word32L ∷ μ Word32 + word32L = ( "word32") + $ do bs ← take 4 + let o₀ = BS.unsafeIndex bs 0 + o₁ = BS.unsafeIndex bs 1 + o₂ = BS.unsafeIndex bs 2 + o₃ = BS.unsafeIndex bs 3 + return $ shiftL (fromIntegral o₃) 24 + .|. shiftL (fromIntegral o₂) 16 + .|. shiftL (fromIntegral o₁) 8 + .|. fromIntegral o₀ + -- | Deserialize an unsigned 32-bit integer in big endian. + word32B ∷ μ Word32 + word32B = swapEndian <$> word32L + -- | Deserialize an unsigned 64-bit integer in little endian. + word64L ∷ μ Word64 + word64L = ( "word64") + $ do bs ← take 8 + let o₀ = BS.unsafeIndex bs 0 + o₁ = BS.unsafeIndex bs 1 + o₂ = BS.unsafeIndex bs 2 + o₃ = BS.unsafeIndex bs 3 + o₄ = BS.unsafeIndex bs 4 + o₅ = BS.unsafeIndex bs 5 + o₆ = BS.unsafeIndex bs 6 + o₇ = BS.unsafeIndex bs 7 + return $ shiftL (fromIntegral o₇) 56 + .|. shiftL (fromIntegral o₆) 48 + .|. shiftL (fromIntegral o₅) 40 + .|. shiftL (fromIntegral o₄) 32 + .|. shiftL (fromIntegral o₃) 24 + .|. shiftL (fromIntegral o₂) 16 + .|. shiftL (fromIntegral o₁) 8 + .|. fromIntegral o₀ + -- | Deserialize an unsigned 64-bit integer in big endian. + word64B ∷ μ Word64 + word64B = swapEndian <$> word64L + -- | 'satisfy' /p/ deserializes a byte that satisfies the predicate /p/, + -- failing otherwise. + satisfy ∷ (Word8 → Bool) → μ Word8 + satisfy p = do w ← word8 + if p w then return w + else unexpected (show w) + {-# INLINE satisfy #-} + -- | Deserialize the specified byte value, failing on any other input. + byte ∷ Word8 → μ Word8 + byte w = ( "byte " ++ show w) + $ do w' ← word8 + if w' == w then return w' + else unexpected (show w') + {-# INLINE byte #-} + -- | 'notByte' /c/ deserializes any byte that is not equal to /c/, failing + -- if /c/ is encountered. + notByte ∷ Word8 → μ Word8 + notByte w = ( "not byte " ++ show w) + $ do w' ← word8 + if w' == w then unexpected (show w') + else return w' + {-# INLINE notByte #-} + -- | 'bytes' /bs/ deserializes a sequence of bytes given by /bs/, failing + -- on any other input. + bytes ∷ BS.ByteString → μ BS.ByteString + bytes bs = ( "bytes " ++ show (BS.unpack bs)) + $ do bs' ← take (BS.length bs) + if bs' == bs then return bs' + else unexpected (show $ BS.unpack bs') + {-# INLINE bytes #-} + -- | Skip exactly the given number of bytes. + skip ∷ Int → μ () + skip n | n <= 0 = pure () + | otherwise = word8 *> skip (n - 1) + -- | 'ensure' /n/ checks that the input has at least /n/ more bytes and + -- returns a portion of the input of length greater or equal to /n/ + -- (without consuming it). + ensure ∷ Int → μ BS.ByteString + -- | 'ensure_' /n/ fails if the input has less than /n/ more bytes. + ensure_ ∷ Int → μ () + ensure_ = (() <$) . ensure + {-# INLINE ensure_ #-} + -- | Consume exactly the given number of bytes. + take ∷ Int → μ BS.ByteString + -- | Consume a portion of the input (the size of the returned + -- 'BS.ByteString' is implementation dependent). Empty result means that + -- the 'eof' is reached. + chunk ∷ μ BS.ByteString + -- | 'isolate' /n/ /d/ feeds the next /n/ bytes to the deserializer /d/. + -- If /d/ consumes less or more that /n/ bytes, 'isolate' will fail. + isolate ∷ Int → μ α → μ α + +-- | A wrapper around the 'B.Get' monad (to avoid orphan instances). +newtype BinaryDeserializer α = + BinaryDeserializer { binaryDeserializer ∷ B.Get α } + deriving (Typeable, Generic, Functor, Applicative, + Alternative, Monad) + +instance Parsing BinaryDeserializer where + try p = p + {-# INLINE try #-} + p l = BinaryDeserializer (B.label l (binaryDeserializer p)) + {-# INLINE () #-} + skipMany p = ((True <$ p) <|> pure False) >>= \case + True → skipMany p + False → return () + unexpected = fail + {-# INLINE unexpected #-} + eof = BinaryDeserializer + $ B.isEmpty >>= \case + True → return () + False → fail "Parsing.eof" + {-# INLINABLE eof #-} + notFollowedBy p = BinaryDeserializer + $ (B.lookAheadE (Left <$> (binaryDeserializer p)) <|> + pure (Right ())) >>= \case + Left e → fail (show e) + Right _ → return () + {-# INLINABLE notFollowedBy #-} + +instance LookAheadParsing BinaryDeserializer where + lookAhead = BinaryDeserializer . B.lookAhead . binaryDeserializer + {-# INLINE lookAhead #-} + +instance Deserializer BinaryDeserializer where + word8 = BinaryDeserializer B.getWord8 + {-# INLINE word8 #-} + word16L = BinaryDeserializer B.getWord16le + {-# INLINE word16L #-} + word16B = BinaryDeserializer B.getWord16be + {-# INLINE word16B #-} + word32L = BinaryDeserializer B.getWord32le + {-# INLINE word32L #-} + word32B = BinaryDeserializer B.getWord32be + {-# INLINE word32B #-} + word64L = BinaryDeserializer B.getWord64le + {-# INLINE word64L #-} + word64B = BinaryDeserializer B.getWord64be + {-# INLINE word64B #-} + skip = BinaryDeserializer . B.skip + {-# INLINE skip #-} + ensure n = BinaryDeserializer (B.ensureN n *> B.get) + {-# INLINE ensure #-} + ensure_ = BinaryDeserializer . B.ensureN + {-# INLINE ensure_ #-} + take = BinaryDeserializer . B.getByteString + {-# INLINE take #-} + chunk = BinaryDeserializer + $ do bs ← B.get + if BS.null bs + then do + e ← B.isEmpty + if e + then return bs + else B.get + else + return bs + {-# INLINABLE chunk #-} + isolate n d = BinaryDeserializer $ B.isolate n (binaryDeserializer d) + {-# INLINE isolate #-} + +-- | A wrapper around the 'S.Get' monad (to avoid orphan instances). +newtype CerealDeserializer α = + CerealDeserializer { cerealDeserializer ∷ S.Get α } + deriving (Typeable, Generic, Functor, Applicative, + Alternative, Monad) + +instance Parsing CerealDeserializer where + try p = p + {-# INLINE try #-} + p l = CerealDeserializer (S.label l (cerealDeserializer p)) + {-# INLINE () #-} + skipMany p = ((True <$ p) <|> pure False) >>= \case + True → skipMany p + False → return () + unexpected = fail + {-# INLINE unexpected #-} + eof = CerealDeserializer + $ ((False <$ S.lookAheadM (Nothing <$ S.getWord8)) <|> + pure True) >>= \case + True → return () + False → fail "Parsing.eof" + {-# INLINABLE eof #-} + notFollowedBy p = CerealDeserializer + $ (S.lookAheadE (Left <$> (cerealDeserializer p)) <|> + pure (Right ())) >>= \case + Left e → fail (show e) + Right _ → return () + {-# INLINABLE notFollowedBy #-} + +instance LookAheadParsing CerealDeserializer where + lookAhead = CerealDeserializer . S.lookAhead . cerealDeserializer + {-# INLINE lookAhead #-} + +instance Deserializer CerealDeserializer where + word8 = CerealDeserializer S.getWord8 + {-# INLINE word8 #-} + word16L = CerealDeserializer S.getWord16le + {-# INLINE word16L #-} + word16B = CerealDeserializer S.getWord16be + {-# INLINE word16B #-} + word32L = CerealDeserializer S.getWord32le + {-# INLINE word32L #-} + word32B = CerealDeserializer S.getWord32be + {-# INLINE word32B #-} + word64L = CerealDeserializer S.getWord64le + {-# INLINE word64L #-} + word64B = CerealDeserializer S.getWord64be + {-# INLINE word64B #-} + skip = CerealDeserializer . S.skip + {-# INLINE skip #-} + ensure = CerealDeserializer . S.ensure + {-# INLINE ensure #-} + take = CerealDeserializer . S.getBytes + {-# INLINE take #-} + chunk = CerealDeserializer + $ (<|> pure BS.empty) + $ do bs ← S.ensure 1 + S.uncheckedSkip (BS.length bs) + return bs + {-# INLINE chunk #-} + isolate n d = CerealDeserializer (S.isolate n (cerealDeserializer d)) + {-# INLINE isolate #-} + +-- | Deserialize an unsigned 16-bit integer in host byte order. +word16H ∷ Deserializer μ ⇒ μ Word16 +#ifdef WORDS_BIGENDIAN +word16H = word16B +#else +word16H = word16L +#endif +{-# INLINE word16H #-} + +-- | Deserialize an unsigned 32-bit integer in host byte order. +word32H ∷ Deserializer μ ⇒ μ Word32 +#ifdef WORDS_BIGENDIAN +word32H = word32B +#else +word32H = word32L +#endif +{-# INLINE word32H #-} + +-- | Deserialize an unsigned 64-bit integer in host byte order. +word64H ∷ Deserializer μ ⇒ μ Word64 +#ifdef WORDS_BIGENDIAN +word64H = word64B +#else +word64H = word64L +#endif +{-# INLINE word64H #-} + +-- | Deserialize an unsigned native-sized integer in serializer default +-- byte order. +word ∷ Deserializer μ ⇒ μ Word +#if WORD_SIZE_IN_BITS == 32 +word = fromIntegral <$> word32 +#else +word = fromIntegral <$> word64 +#endif +{-# INLINE word #-} + +-- | Deserialize an unsigned native-sized integer in little endian. +wordL ∷ Deserializer μ ⇒ μ Word +#if WORD_SIZE_IN_BITS == 32 +wordL = fromIntegral <$> word32L +#else +wordL = fromIntegral <$> word64L +#endif +{-# INLINE wordL #-} + +-- | Deserialize an unsigned native-sized integer in big endian. +wordB ∷ Deserializer μ ⇒ μ Word +#if WORD_SIZE_IN_BITS == 32 +wordB = fromIntegral <$> word32B +#else +wordB = fromIntegral <$> word64B +#endif +{-# INLINE wordB #-} + +-- | Deserialize an unsigned native-sized integer in host byte order. +wordH ∷ Deserializer μ ⇒ μ Word +#ifdef WORDS_BIGENDIAN +wordH = wordB +#else +wordH = wordL +#endif +{-# INLINE wordH #-} + +-- | Deserialize a signed 8-bit integer. +int8 ∷ Deserializer μ ⇒ μ Int8 +int8 = fromIntegral <$> word8 +{-# INLINE int8 #-} + +-- | Deserialize a signed 16-bit integer in serializer default byte order. +int16 ∷ Deserializer μ ⇒ μ Int16 +int16 = fromIntegral <$> word16 +{-# INLINE int16 #-} + +-- | Deserialize a signed 16-bit integer in little endian. +int16L ∷ Deserializer μ ⇒ μ Int16 +int16L = fromIntegral <$> word16L +{-# INLINE int16L #-} + +-- | Deserialize a signed 16-bit integer in big endian. +int16B ∷ Deserializer μ ⇒ μ Int16 +int16B = fromIntegral <$> word16B +{-# INLINE int16B #-} + +-- | Deserialize a signed 16-bit integer in host byte order. +int16H ∷ Deserializer μ ⇒ μ Int16 +int16H = fromIntegral <$> word16H +{-# INLINE int16H #-} + +-- | Deserialize a signed 32-bit integer in serializer default byte order. +int32 ∷ Deserializer μ ⇒ μ Int32 +int32 = fromIntegral <$> word32 +{-# INLINE int32 #-} + +-- | Deserialize a signed 32-bit integer in little endian. +int32L ∷ Deserializer μ ⇒ μ Int32 +int32L = fromIntegral <$> word32L +{-# INLINE int32L #-} + +-- | Deserialize a signed 32-bit integer in big endian. +int32B ∷ Deserializer μ ⇒ μ Int32 +int32B = fromIntegral <$> word32B +{-# INLINE int32B #-} + +-- | Deserialize a signed 32-bit integer in host byte order. +int32H ∷ Deserializer μ ⇒ μ Int32 +int32H = fromIntegral <$> word32H +{-# INLINE int32H #-} + +-- | Deserialize a signed 64-bit integer in serializer default byte order. +int64 ∷ Deserializer μ ⇒ μ Int64 +int64 = fromIntegral <$> word64 +{-# INLINE int64 #-} + +-- | Deserialize a signed 64-bit integer in little endian. +int64L ∷ Deserializer μ ⇒ μ Int64 +int64L = fromIntegral <$> word64L +{-# INLINE int64L #-} + +-- | Deserialize a signed 64-bit integer in big endian. +int64B ∷ Deserializer μ ⇒ μ Int64 +int64B = fromIntegral <$> word64B +{-# INLINE int64B #-} + +-- | Deserialize a signed 64-bit integer in host byte order. +int64H ∷ Deserializer μ ⇒ μ Int64 +int64H = fromIntegral <$> word64H +{-# INLINE int64H #-} + +-- | Deserialize a signed native-sized integer in serializer default byte +-- order. +int ∷ Deserializer μ ⇒ μ Int +#if WORD_SIZE_IN_BITS == 32 +int = fromIntegral <$> int32 +#else +int = fromIntegral <$> int64 +#endif +{-# INLINE int #-} + +-- | Deserialize a signed native-sized integer in little endian. +intL ∷ Deserializer μ ⇒ μ Int +#if WORD_SIZE_IN_BITS == 32 +intL = fromIntegral <$> int32L +#else +intL = fromIntegral <$> int64L +#endif +{-# INLINE intL #-} + +-- | Deserialize a signed native-sized integer in big endian. +intB ∷ Deserializer μ ⇒ μ Int +#if WORD_SIZE_IN_BITS == 32 +intB = fromIntegral <$> int32B +#else +intB = fromIntegral <$> int64B +#endif +{-# INLINE intB #-} + +-- | Deserialize a signed native-sized integer in host byte order. +intH ∷ Deserializer μ ⇒ μ Int +#if WORD_SIZE_IN_BITS == 32 +intH = fromIntegral <$> int32H +#else +intH = fromIntegral <$> int64H +#endif +{-# INLINE intH #-} + +-- | A shorthand for 'flip' (''). +label ∷ Parsing μ ⇒ String → μ α → μ α +label = flip () +{-# INLINE label #-} + +-- | Deserializer wrapper with little endian default byte order. +newtype LittleEndianDeserializer μ α = + LittleEndianDeserializer { deserializeL ∷ μ α } + deriving (Typeable, Data, Generic, Functor, Applicative, + Alternative, Monad, Parsing, LookAheadParsing) + +instance Deserializer μ ⇒ Deserializer (LittleEndianDeserializer μ) where + endian _ = LittleEndian + {-# INLINE endian #-} + word8 = LittleEndianDeserializer word8 + {-# INLINE word8 #-} + word16 = LittleEndianDeserializer word16L + {-# INLINE word16 #-} + word32 = LittleEndianDeserializer word32L + {-# INLINE word32 #-} + word64 = LittleEndianDeserializer word64L + {-# INLINE word64 #-} + word16L = LittleEndianDeserializer word16L + {-# INLINE word16L #-} + word16B = LittleEndianDeserializer word16B + {-# INLINE word16B #-} + word32L = LittleEndianDeserializer word32L + {-# INLINE word32L #-} + word32B = LittleEndianDeserializer word32B + {-# INLINE word32B #-} + word64L = LittleEndianDeserializer word64L + {-# INLINE word64L #-} + word64B = LittleEndianDeserializer word64B + {-# INLINE word64B #-} + satisfy = LittleEndianDeserializer . satisfy + {-# INLINE satisfy #-} + byte = LittleEndianDeserializer . byte + {-# INLINE byte #-} + notByte = LittleEndianDeserializer . notByte + {-# INLINE notByte #-} + bytes = LittleEndianDeserializer . bytes + {-# INLINE bytes #-} + skip = LittleEndianDeserializer . skip + {-# INLINE skip #-} + ensure = LittleEndianDeserializer . ensure + {-# INLINE ensure #-} + ensure_ = LittleEndianDeserializer . ensure_ + {-# INLINE ensure_ #-} + take = LittleEndianDeserializer . take + {-# INLINE take #-} + chunk = LittleEndianDeserializer chunk + {-# INLINE chunk #-} + isolate n = LittleEndianDeserializer . isolate n . deserializeL + {-# INLINE isolate #-} + +-- | Deserializer wrapper with big endian default byte order. +newtype BigEndianDeserializer μ α = + BigEndianDeserializer { deserializeB ∷ μ α } + deriving (Typeable, Data, Generic, Functor, Applicative, + Alternative, Monad, Parsing, LookAheadParsing) + +instance Deserializer μ ⇒ Deserializer (BigEndianDeserializer μ) where + endian _ = BigEndian + {-# INLINE endian #-} + word8 = BigEndianDeserializer word8 + {-# INLINE word8 #-} + word16 = BigEndianDeserializer word16B + {-# INLINE word16 #-} + word32 = BigEndianDeserializer word32B + {-# INLINE word32 #-} + word64 = BigEndianDeserializer word64B + {-# INLINE word64 #-} + word16L = BigEndianDeserializer word16L + {-# INLINE word16L #-} + word16B = BigEndianDeserializer word16B + {-# INLINE word16B #-} + word32L = BigEndianDeserializer word32L + {-# INLINE word32L #-} + word32B = BigEndianDeserializer word32B + {-# INLINE word32B #-} + word64L = BigEndianDeserializer word64L + {-# INLINE word64L #-} + word64B = BigEndianDeserializer word64B + {-# INLINE word64B #-} + satisfy = BigEndianDeserializer . satisfy + {-# INLINE satisfy #-} + byte = BigEndianDeserializer . byte + {-# INLINE byte #-} + notByte = BigEndianDeserializer . notByte + {-# INLINE notByte #-} + bytes = BigEndianDeserializer . bytes + {-# INLINE bytes #-} + skip = BigEndianDeserializer . skip + {-# INLINE skip #-} + ensure = BigEndianDeserializer . ensure + {-# INLINE ensure #-} + ensure_ = BigEndianDeserializer . ensure_ + {-# INLINE ensure_ #-} + take = BigEndianDeserializer . take + {-# INLINE take #-} + chunk = BigEndianDeserializer chunk + {-# INLINE chunk #-} + isolate n = BigEndianDeserializer . isolate n . deserializeB + {-# INLINE isolate #-} + +-- | Force the default byte order. +deserializeIn ∷ Deserializer μ + ⇒ Endian → (∀ μ' . (Deserializer μ') ⇒ μ' α) → μ α +deserializeIn LittleEndian = deserializeL +deserializeIn BigEndian = deserializeB +{-# INLINE deserializeIn #-} + +-- | Force the default byte order to be the host byte order. +deserializeH ∷ Deserializer μ ⇒ (∀ μ' . (Deserializer μ') ⇒ μ' α) → μ α +#ifdef WORDS_BIGENDIAN +deserializeH = deserializeB +#else +deserializeH = deserializeL +#endif + +-- | Deserializable type. 'get' must not rely on 'eof'. +class Deserializable α where + get ∷ Deserializer μ ⇒ μ α + +instance Deserializable Bool where + get = do w ← word8 + case w of + 0 → return False + 1 → return True + _ → unexpected (show w) + +instance Deserializable Word8 where + get = word8 + {-# INLINE get #-} + +instance Deserializable Word16 where + get = word16 + {-# INLINE get #-} + +instance Deserializable Word32 where + get = word32 + {-# INLINE get #-} + +instance Deserializable Word64 where + get = word64 + {-# INLINE get #-} + +instance Deserializable Word where + get = word + {-# INLINE get #-} + +instance Deserializable Int8 where + get = int8 + {-# INLINE get #-} + +instance Deserializable Int16 where + get = int16 + {-# INLINE get #-} + +instance Deserializable Int32 where + get = int32 + {-# INLINE get #-} + +instance Deserializable Int64 where + get = int64 + {-# INLINE get #-} + +instance Deserializable Int where + get = int + {-# INLINE get #-} + +instance (Deserializable α, Deserializable β) ⇒ Deserializable (α, β) where + get = (,) <$> get <*> get + {-# INLINE get #-} + +instance Deserializable α ⇒ Deserializable (Maybe α) where + get = do w ← word8 + case w of + 0 → return Nothing + 1 → Just <$> get + _ → unexpected (show w) + +instance (Deserializable α, Deserializable β) + ⇒ Deserializable (Either α β) where + get = do w ← word8 + case w of + 0 → Left <$> get + 1 → Right <$> get + _ → unexpected (show w) + +instance Deserializable BS.ByteString where + get = do l ← int "length" + unless (l >= 0) $ unexpected "negative length" + take l "contents" + {-# INLINABLE get #-} + +instance Deserializable SBS.ShortByteString where + get = SBS.toShort <$> get + {-# INLINE get #-} + +-- | Deserialize a value using the provided default byte order. +getIn ∷ (Deserializer μ, Deserializable α) ⇒ Endian → μ α +getIn e = deserializeIn e get +{-# INLINE getIn #-} + +-- | Deserialize a value using little endian as the default byte order. +getL ∷ (Deserializer μ, Deserializable α) ⇒ μ α +getL = deserializeL get +{-# INLINE getL #-} + +-- | Deserialize a value using big endian as the default byte order. +getB ∷ (Deserializer μ, Deserializable α) ⇒ μ α +getB = deserializeB get +{-# INLINE getB #-} + +-- | Deserialize a value using host byte order as the default byte order. +getH ∷ (Deserializer μ, Deserializable α) ⇒ μ α +#ifdef WORDS_BIGENDIAN +getH = getB +#else +getH = getL +#endif +{-# INLINE getH #-} + +-- | Deserializable type. 'getRest' must consume all the remaining input +-- or fail. +class RestDeserializable α where + getRest ∷ Deserializer μ ⇒ μ α + +instance RestDeserializable BS.ByteString where + getRest = go [] + where go acc = do bs ← chunk + if BS.null bs then return $ BS.concat $ reverse acc + else go (bs : acc) + +instance RestDeserializable SBS.ShortByteString where + getRest = SBS.toShort <$> getRest + {-# INLINE getRest #-} + +instance RestDeserializable LBS.ByteString where + getRest = go [] + where go acc = do bs ← chunk + if BS.null bs then return $ LBS.fromChunks $ reverse acc + else go (bs : acc) + +instance RestDeserializable BB.Builder where + getRest = BB.lazyByteString <$> getRest + {-# INLINE getRest #-} + +instance (RestDeserializable α, RestDeserializable β) + ⇒ RestDeserializable (Either α β) where + getRest = word8 >>= \case + 0 → Left <$> getRest + 1 → Right <$> getRest + w → unexpected (show w) + {-# INLINABLE getRest #-} + +instance (Deserializable α, RestDeserializable β) + ⇒ RestDeserializable (α, β) where + getRest = (,) <$> get <*> getRest + {-# INLINE getRest #-} + +instance Deserializable α ⇒ RestDeserializable [α] where + getRest = ([] <$ eof) <|> ((:) <$> get <*> getRest) diff --git a/src/Data/Serializer.hs b/src/Data/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Serializer.hs @@ -0,0 +1,673 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Serialization monoid and serializable types. +module Data.Serializer + ( + -- * Serialization monoid + Serializer(..) + -- ** Binary words serialization + , word16H + , word32H + , word64H + , word + , wordL + , wordB + , wordH + , int8 + , int16 + , int16L + , int16B + , int16H + , int32 + , int32L + , int32B + , int32H + , int64 + , int64L + , int64B + , int64H + , int + , intL + , intB + , intH + -- ** Endian serializers + , LittleEndianSerializer(..) + , BigEndianSerializer(..) + , serializeIn + , serializeH + -- * Serializable types + , Serializable(..) + , putIn + , putL + , putB + , putH + , SizedSerializable(..) + , RestSerializable(..) + ) where + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) +import Data.Data (Data) +import Data.Proxy (Proxy(..)) +import Data.Monoid (Monoid, (<>)) +import Data.Endian (Endian(..), swapEndian) +import Data.Word +import Data.Int +import Data.Bits (shiftR) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Builder as BB +import qualified Data.Binary.Put as B +import qualified Data.Serialize.Put as S + +-- | Serialization monoid. +class Monoid s ⇒ Serializer s where + {-# MINIMAL word8 #-} + -- | Default byte order of the serializer. + endian ∷ Proxy s → Endian +#ifdef WORDS_BIGENDIAN + endian _ = BigEndian +#else + endian _ = LittleEndian +#endif + {-# INLINE endian #-} + -- | Serialize a byte. 'word8' /x/ = 'byteString' ('BS.singleton' /x/) + word8 ∷ Word8 → s + -- | Serialize an unsigned 16-bit integer in the default byte order. + word16 ∷ Word16 → s + word16 = putIn (endian (Proxy ∷ Proxy s)) + {-# INLINE word16 #-} + -- | Serialize an unsigned 32-bit integer in the default byte order. + word32 ∷ Word32 → s + word32 = putIn (endian (Proxy ∷ Proxy s)) + {-# INLINE word32 #-} + -- | Serialize an unsigned 64-bit integer in the default byte order. + word64 ∷ Word64 → s + word64 = putIn (endian (Proxy ∷ Proxy s)) + {-# INLINE word64 #-} + -- | Serialize an unsigned 16-bit integer in little endian. + word16L ∷ Word16 → s + word16L w = word8 (fromIntegral w) + <> word8 (fromIntegral (shiftR w 8)) + {-# INLINE word16L #-} + -- | Serialize an unsigned 16-bit integer in big endian. + word16B ∷ Word16 → s + word16B = word16L . swapEndian + {-# INLINE word16B #-} + -- | Serialize an unsigned 32-bit integer in little endian. + word32L ∷ Word32 → s + word32L w = word8 (fromIntegral w) + <> word8 (fromIntegral (shiftR w 8)) + <> word8 (fromIntegral (shiftR w 16)) + <> word8 (fromIntegral (shiftR w 24)) + {-# INLINE word32L #-} + -- | Serialize an unsigned 32-bit integer in big endian. + word32B ∷ Word32 → s + word32B = word32L . swapEndian + {-# INLINE word32B #-} + -- | Serialize an unsigned 64-bit integer in little endian. + word64L ∷ Word64 → s + word64L w = word8 (fromIntegral w) + <> word8 (fromIntegral (shiftR w 8)) + <> word8 (fromIntegral (shiftR w 16)) + <> word8 (fromIntegral (shiftR w 24)) + <> word8 (fromIntegral (shiftR w 32)) + <> word8 (fromIntegral (shiftR w 40)) + <> word8 (fromIntegral (shiftR w 48)) + <> word8 (fromIntegral (shiftR w 56)) + {-# INLINE word64L #-} + -- | Serialize an unsigned 64-bit integer in big endian. + word64B ∷ Word64 → s + word64B = word64L . swapEndian + {-# INLINE word64B #-} + -- | Serialize a 'BS.ByteString'. Must be a monoid homomorphism. + byteString ∷ BS.ByteString → s + byteString = mconcat . fmap word8 . BS.unpack + {-# INLINE byteString #-} + -- | Serialize a 'SBS.ShortByteString'. Must be a monoid homomorphism. + shortByteString ∷ SBS.ShortByteString → s + shortByteString = mconcat . fmap word8 . SBS.unpack + {-# INLINE shortByteString #-} + -- | Serialize a lazy 'LBS.ByteString'. Must be a monoid homomorphism. + lazyByteString ∷ LBS.ByteString → s + lazyByteString = mconcat . fmap byteString . LBS.toChunks + {-# INLINE lazyByteString #-} + -- | Serialize a 'BB.Builder'. Must be a monoid homomorphism. + builder ∷ BB.Builder → s + builder = lazyByteString . BB.toLazyByteString + {-# INLINE builder #-} + +instance Serializer [Word8] where + word8 = pure + {-# INLINE word8 #-} + +instance Serializer BB.Builder where + word8 = BB.word8 + {-# INLINE word8 #-} + word16L = BB.word16LE + {-# INLINE word16L #-} + word16B = BB.word16BE + {-# INLINE word16B #-} + word32L = BB.word32LE + {-# INLINE word32L #-} + word32B = BB.word32BE + {-# INLINE word32B #-} + word64L = BB.word64LE + {-# INLINE word64L #-} + word64B = BB.word64BE + {-# INLINE word64B #-} + byteString = BB.byteString + {-# INLINE byteString #-} + shortByteString = BB.shortByteString + {-# INLINE shortByteString #-} + lazyByteString = BB.lazyByteString + {-# INLINE lazyByteString #-} + builder = id + {-# INLINE builder #-} + +instance Serializer B.Put where + word8 = B.putWord8 + {-# INLINE word8 #-} + word16L = B.putWord16le + {-# INLINE word16L #-} + word16B = B.putWord16be + {-# INLINE word16B #-} + word32L = B.putWord32le + {-# INLINE word32L #-} + word32B = B.putWord32be + {-# INLINE word32B #-} + word64L = B.putWord64le + {-# INLINE word64L #-} + word64B = B.putWord64be + {-# INLINE word64B #-} + byteString = B.putByteString + {-# INLINE byteString #-} + shortByteString = B.putShortByteString + {-# INLINE shortByteString #-} + lazyByteString = B.putLazyByteString + {-# INLINE lazyByteString #-} + builder = B.putBuilder + {-# INLINE builder #-} + +#if !MIN_VERSION_cereal(0,5,3) +instance Monoid S.Put where + mempty = return () + {-# INLINE mempty #-} + mappend = (>>) + {-# INLINE mappend #-} +#endif + +instance Serializer S.Put where + word8 = S.putWord8 + {-# INLINE word8 #-} + word16L = S.putWord16le + {-# INLINE word16L #-} + word16B = S.putWord16be + {-# INLINE word16B #-} + word32L = S.putWord32le + {-# INLINE word32L #-} + word32B = S.putWord32be + {-# INLINE word32B #-} + word64L = S.putWord64le + {-# INLINE word64L #-} + word64B = S.putWord64be + {-# INLINE word64B #-} + byteString = S.putByteString + {-# INLINE byteString #-} + shortByteString = S.putShortByteString + {-# INLINE shortByteString #-} + lazyByteString = S.putLazyByteString + {-# INLINE lazyByteString #-} + builder = S.putBuilder + {-# INLINE builder #-} + +-- | Serialize an usigned 16-bit integer in host byte order. +word16H ∷ Serializer s ⇒ Word16 → s +#ifdef WORDS_BIGENDIAN +word16H = word16B +#else +word16H = word16L +#endif +{-# INLINE word16H #-} + +-- | Serialize an unsigned 32-bit integer in host byte order. +word32H ∷ Serializer s ⇒ Word32 → s +#ifdef WORDS_BIGENDIAN +word32H = word32B +#else +word32H = word32L +#endif +{-# INLINE word32H #-} + +-- | Serialize an unsigned 64-bit integer in host byte order. +word64H ∷ Serializer s ⇒ Word64 → s +#ifdef WORDS_BIGENDIAN +word64H = word64B +#else +word64H = word64L +#endif +{-# INLINE word64H #-} + +-- | Serialize an unsigned native-sized integer in serializer default +-- byte order. +word ∷ Serializer s ⇒ Word → s +#ifdef WORDS_BIGENDIAN +word = wordB +#else +word = wordL +#endif +{-# INLINE word #-} + +-- | Serialize an unsigned native-sized integer in little endian. +wordL ∷ Serializer s ⇒ Word → s +#if WORD_SIZE_IN_BITS == 32 +wordL = word32L . fromIntegral +#else +wordL = word64L . fromIntegral +#endif +{-# INLINE wordL #-} + +-- | Serialize an unsigned native-sized integer in big endian. +wordB ∷ Serializer s ⇒ Word → s +#if WORD_SIZE_IN_BITS == 32 +wordB = word32B . fromIntegral +#else +wordB = word64B . fromIntegral +#endif +{-# INLINE wordB #-} + +-- | Serialize an unsigned native-sized integer in host byte order. +wordH ∷ Serializer s ⇒ Word → s +#if WORD_SIZE_IN_BITS == 32 +wordH = word32H . fromIntegral +#else +wordH = word64H . fromIntegral +#endif +{-# INLINE wordH #-} + +-- | Serialize a signed 8-bit integer. +int8 ∷ Serializer s ⇒ Int8 → s +int8 = word8 . fromIntegral +{-# INLINE int8 #-} + +-- | Serialize a signed 16-bit integer in serializer default byte order. +int16 ∷ Serializer s ⇒ Int16 → s +int16 = word16 . fromIntegral +{-# INLINE int16 #-} + +-- | Serialize a signed 16-bit integer in little endian. +int16L ∷ Serializer s ⇒ Int16 → s +int16L = word16L . fromIntegral +{-# INLINE int16L #-} + +-- | Serialize a signed 16-bit integer in big endian. +int16B ∷ Serializer s ⇒ Int16 → s +int16B = word16B . fromIntegral +{-# INLINE int16B #-} + +-- | Serialize a signed 16-bit integer in host byte order. +int16H ∷ Serializer s ⇒ Int16 → s +#ifdef WORDS_BIGENDIAN +int16H = int16B +#else +int16H = int16L +#endif +{-# INLINE int16H #-} + +-- | Serialize a signed 32-bit integer in serializer default byte order. +int32 ∷ Serializer s ⇒ Int32 → s +int32 = word32 . fromIntegral +{-# INLINE int32 #-} + +-- | Serialize a signed 32-bit integer in little endian. +int32L ∷ Serializer s ⇒ Int32 → s +int32L = word32L . fromIntegral +{-# INLINE int32L #-} + +-- | Serialize a signed 32-bit integer in big endian. +int32B ∷ Serializer s ⇒ Int32 → s +int32B = word32B . fromIntegral +{-# INLINE int32B #-} + +-- | Serialize a signed 32-bit integer in host byte order. +int32H ∷ Serializer s ⇒ Int32 → s +#ifdef WORDS_BIGENDIAN +int32H = int32B +#else +int32H = int32L +#endif +{-# INLINE int32H #-} + +-- | Serialize a signed 64-bit integer in serializer default byte order. +int64 ∷ Serializer s ⇒ Int64 → s +int64 = word64 . fromIntegral +{-# INLINE int64 #-} + +-- | Serialize a signed 64-bit integer in little endian. +int64L ∷ Serializer s ⇒ Int64 → s +int64L = word64L . fromIntegral +{-# INLINE int64L #-} + +-- | Serialize a signed 64-bit integer in big endian. +int64B ∷ Serializer s ⇒ Int64 → s +int64B = word64B . fromIntegral +{-# INLINE int64B #-} + +-- | Serialize a signed 64-bit integer in host byte order. +int64H ∷ Serializer s ⇒ Int64 → s +#ifdef WORDS_BIGENDIAN +int64H = int64B +#else +int64H = int64L +#endif +{-# INLINE int64H #-} + +-- | Serialize a signed native-sized integer in serializer default byte order. +int ∷ Serializer s ⇒ Int → s +#ifdef WORDS_BIGENDIAN +int = intB +#else +int = intL +#endif +{-# INLINE int #-} + +-- | Serialize a signed native-sized integer in little endian. +intL ∷ Serializer s ⇒ Int → s +#if WORD_SIZE_IN_BITS == 32 +intL = word32L . fromIntegral +#else +intL = word64L . fromIntegral +#endif +{-# INLINE intL #-} + +-- | Serialize a signed native-sized integer in big endian. +intB ∷ Serializer s ⇒ Int64 → s +#if WORD_SIZE_IN_BITS == 32 +intB = word32B . fromIntegral +#else +intB = word64B . fromIntegral +#endif +{-# INLINE intB #-} + +-- | Serialize a signed native-sized integer in host byte order. +intH ∷ Serializer s ⇒ Int → s +#if WORD_SIZE_IN_BITS == 32 +intH = word32H . fromIntegral +#else +intH = word64H . fromIntegral +#endif +{-# INLINE intH #-} + +-- | Serializer wrapper with little endian default byte order. +newtype LittleEndianSerializer s = LittleEndianSerializer { serializeL ∷ s } + deriving (Typeable, Data, Generic, Monoid) + +instance Serializer s ⇒ Serializer (LittleEndianSerializer s) where + endian _ = LittleEndian + {-# INLINE endian #-} + word8 = LittleEndianSerializer . word8 + {-# INLINE word8 #-} + word16 = LittleEndianSerializer . word16L + {-# INLINE word16 #-} + word32 = LittleEndianSerializer . word32L + {-# INLINE word32 #-} + word64 = LittleEndianSerializer . word64L + {-# INLINE word64 #-} + word16L = LittleEndianSerializer . word16L + {-# INLINE word16L #-} + word16B = LittleEndianSerializer . word16B + {-# INLINE word16B #-} + word32L = LittleEndianSerializer . word32L + {-# INLINE word32L #-} + word32B = LittleEndianSerializer . word32B + {-# INLINE word32B #-} + word64L = LittleEndianSerializer . word64L + {-# INLINE word64L #-} + word64B = LittleEndianSerializer . word64B + {-# INLINE word64B #-} + byteString = LittleEndianSerializer . byteString + {-# INLINE byteString #-} + shortByteString = LittleEndianSerializer . shortByteString + {-# INLINE shortByteString #-} + lazyByteString = LittleEndianSerializer . lazyByteString + {-# INLINE lazyByteString #-} + builder = LittleEndianSerializer . builder + {-# INLINE builder #-} + +-- | Serializer wrapper with big endian default byte order. +newtype BigEndianSerializer s = BigEndianSerializer { serializeB ∷ s } + deriving (Typeable, Data, Generic, Monoid) + +instance Serializer s ⇒ Serializer (BigEndianSerializer s) where + endian _ = BigEndian + {-# INLINE endian #-} + word8 = BigEndianSerializer . word8 + {-# INLINE word8 #-} + word16 = BigEndianSerializer . word16B + {-# INLINE word16 #-} + word32 = BigEndianSerializer . word32B + {-# INLINE word32 #-} + word64 = BigEndianSerializer . word64B + {-# INLINE word64 #-} + word16L = BigEndianSerializer . word16L + {-# INLINE word16L #-} + word16B = BigEndianSerializer . word16B + {-# INLINE word16B #-} + word32L = BigEndianSerializer . word32L + {-# INLINE word32L #-} + word32B = BigEndianSerializer . word32B + {-# INLINE word32B #-} + word64L = BigEndianSerializer . word64L + {-# INLINE word64L #-} + word64B = BigEndianSerializer . word64B + {-# INLINE word64B #-} + byteString = BigEndianSerializer . byteString + {-# INLINE byteString #-} + shortByteString = BigEndianSerializer . shortByteString + {-# INLINE shortByteString #-} + lazyByteString = BigEndianSerializer . lazyByteString + {-# INLINE lazyByteString #-} + builder = BigEndianSerializer . builder + {-# INLINE builder #-} + +-- | Force the default byte order. +serializeIn ∷ Serializer s ⇒ Endian → (∀ s' . (Serializer s') ⇒ s') → s +serializeIn LittleEndian = serializeL +serializeIn BigEndian = serializeB +{-# INLINE serializeIn #-} + +-- | Force the default byte order to be the host byte order. +serializeH ∷ Serializer s ⇒ (∀ s' . (Serializer s') ⇒ s') → s +#ifdef WORDS_BIGENDIAN +serializeH = serializeB +#else +serializeH = serializeL +#endif +{-# INLINE serializeH #-} + +-- | Serializable type. 'put' must work under assumption that it will be +-- followed by more output. +class Serializable α where + put ∷ Serializer s ⇒ α → s + +instance Serializable Bool where + put False = word8 0 + put True = word8 1 + {-# INLINE put #-} + +instance Serializable Word8 where + put = word8 + {-# INLINE put #-} + +instance Serializable Word16 where + put = word16 + {-# INLINE put #-} + +instance Serializable Word32 where + put = word32 + {-# INLINE put #-} + +instance Serializable Word64 where + put = word64 + {-# INLINE put #-} + +instance Serializable Word where + put = word + {-# INLINE put #-} + +instance Serializable Int8 where + put = int8 + {-# INLINE put #-} + +instance Serializable Int16 where + put = word16 . fromIntegral + {-# INLINE put #-} + +instance Serializable Int32 where + put = word32 . fromIntegral + {-# INLINE put #-} + +instance Serializable Int64 where + put = word64 . fromIntegral + {-# INLINE put #-} + +instance Serializable Int where + put = int + {-# INLINE put #-} + +instance (Serializable α, Serializable β) ⇒ Serializable (α, β) where + put (a, b) = put a <> put b + {-# INLINE put #-} + +instance Serializable α ⇒ Serializable (Maybe α) where + put Nothing = word8 0 + put (Just a) = word8 1 <> put a + +instance (Serializable α, Serializable β) ⇒ Serializable (Either α β) where + put (Left a) = word8 0 <> put a + put (Right b) = word8 1 <> put b + +instance Serializable BS.ByteString where + put bs = int (BS.length bs) <> byteString bs + +instance Serializable SBS.ShortByteString where + put bs = int (SBS.length bs) <> shortByteString bs + +-- | Serialize a value using the provided default byte order. +putIn ∷ (Serializer s, Serializable α) ⇒ Endian → α → s +putIn e a = serializeIn e (put a) +{-# INLINE putIn #-} + +-- | Serialize a value using little endian as the default byte order. +putL ∷ (Serializer s, Serializable α) ⇒ α → s +putL a = serializeL (put a) +{-# INLINE putL #-} + +-- | Serialize a value using big endian as the default byte order. +putB ∷ (Serializer s, Serializable α) ⇒ α → s +putB a = serializeB (put a) +{-# INLINE putB #-} + +-- | Serialize a value using host byte order as the default byte order. +putH ∷ (Serializer s, Serializable α) ⇒ α → s +putH a = serializeH (put a) +{-# INLINE putH #-} + +-- | Types with fixed serialized size. +class Serializable α ⇒ SizedSerializable α where + -- | Serialized size in bytes. + size ∷ Proxy α → Int + +instance SizedSerializable Bool where + size _ = 1 + {-# INLINE size #-} + +instance SizedSerializable Word8 where + size _ = 1 + {-# INLINE size #-} + +instance SizedSerializable Word16 where + size _ = 2 + {-# INLINE size #-} + +instance SizedSerializable Word32 where + size _ = 4 + {-# INLINE size #-} + +instance SizedSerializable Word64 where + size _ = 8 + {-# INLINE size #-} + +instance SizedSerializable Word where +#if WORD_SIZE_IN_BITS == 32 + size _ = 4 +#else + size _ = 8 +#endif + {-# INLINE size #-} + +instance SizedSerializable Int8 where + size _ = 1 + {-# INLINE size #-} + +instance SizedSerializable Int16 where + size _ = 2 + {-# INLINE size #-} + +instance SizedSerializable Int32 where + size _ = 4 + {-# INLINE size #-} + +instance SizedSerializable Int64 where + size _ = 8 + {-# INLINE size #-} + +instance SizedSerializable Int where +#if WORD_SIZE_IN_BITS == 32 + size _ = 4 +#else + size _ = 8 +#endif + {-# INLINE size #-} + +instance (SizedSerializable α, SizedSerializable β) + ⇒ SizedSerializable (α, β) where + size _ = size (Proxy ∷ Proxy α) + size (Proxy ∷ Proxy β) + {-# INLINE size #-} + +-- | Serializable type. 'putRest' must work under assumption that it will not +-- be followed by any more output. +class RestSerializable α where + putRest ∷ Serializer s ⇒ α → s + +instance RestSerializable BS.ByteString where + putRest = byteString + {-# INLINE putRest #-} + +instance RestSerializable SBS.ShortByteString where + putRest = shortByteString + {-# INLINE putRest #-} + +instance RestSerializable LBS.ByteString where + putRest = lazyByteString + {-# INLINE putRest #-} + +instance RestSerializable BB.Builder where + putRest = builder + {-# INLINE putRest #-} + +instance Serializable α ⇒ RestSerializable [α] where + putRest = mconcat . fmap put + {-# INLINE putRest #-} + +instance (Serializable α, RestSerializable β) ⇒ RestSerializable (α, β) where + putRest (a, b) = put a <> putRest b + {-# INLINE putRest #-} diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck + +import Data.Word (Word8, Word32) +import Data.Either (isLeft, isRight) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Builder as BB +import qualified Data.Binary.Put as B +import qualified Data.Binary.Get as B +import qualified Data.Serialize.Put as C +import qualified Data.Serialize.Get as C +import Data.Serializer (Serializer) +import qualified Data.Serializer as S +import Data.Deserializer (Deserializer) +import qualified Data.Deserializer as D +import Control.Applicative ((<|>)) + +byteStringBuilder = LBS.unpack . BB.toLazyByteString +binaryBuilder = LBS.unpack . B.runPut +cerealBuilder = LBS.unpack . C.runPutLazy + +serializerTests ∷ Serializer s ⇒ String → (s → [Word8]) → TestTree +serializerTests name build = + testGroup name + [ testProperty "word32L" $ + build (S.word32L 0x12345678) == [0x78, 0x56, 0x34, 0x12] + , testProperty "word32B" $ + build (S.word32B 0x12345678) == [0x12, 0x34, 0x56, 0x78] + , testProperty "putL Word32" $ + build (S.putL (0x12345678 ∷ Word32)) == [0x78, 0x56, 0x34, 0x12] + , testProperty "putB Word32" $ + build (S.putB (0x12345678 ∷ Word32)) == [0x12, 0x34, 0x56, 0x78] + ] + +binaryParser p = either (\(_, _, e) → Left e) (\(_, _, r) → Right r) + . B.runGetOrFail (D.binaryDeserializer p) + . LBS.pack +cerealParser p = C.runGet (D.cerealDeserializer p) . BS.pack + +deserializerTests ∷ Deserializer μ + ⇒ String → (∀ α . μ α → [Word8] → Either String α) → TestTree +deserializerTests name parse = + testGroup name + [ testProperty "word32L" $ + parse D.word32L [0x12, 0x34, 0x56, 0x78] == Right 0x78563412 + , testProperty "word32B" $ + parse D.word32B [0x12, 0x34, 0x56, 0x78] == Right 0x12345678 + , testProperty "getL Word32" $ + parse D.getL [0x12, 0x34, 0x56, 0x78] == Right (0x78563412 ∷ Word32) + , testProperty "getB Word32" $ + parse D.getB [0x12, 0x34, 0x56, 0x78] == Right (0x12345678 ∷ Word32) + , testProperty "eof succeeds on empty input" $ + isRight (parse D.eof []) + , testProperty "eof fails on non-empty input" $ + isLeft (parse D.eof [0x00]) + , testProperty "try and <|>" $ + isRight (parse (D.try (D.byte 0x01 >> D.bytes "\x02\x03") <|> + D.bytes "\x01\x03\x02") + [0x01, 0x03, 0x02]) + ] + +main = defaultMain + $ testGroup "Tests" + [ testGroup "Serializers" + [ serializerTests "Builder" byteStringBuilder + , serializerTests "Binary.Put" binaryBuilder + , serializerTests "Cereal.Put" cerealBuilder + ] + , testGroup "Deserializers" + [ deserializerTests "Binary.Get" binaryParser + , deserializerTests "Cereal.Get" cerealParser + ] + ]