diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +(BSD2) + +Copyright (c) 2014, David Luposchainsky +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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 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/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/benchmark/Criterion.hs b/benchmark/Criterion.hs new file mode 100644 --- /dev/null +++ b/benchmark/Criterion.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE ExistentialQuantification #-} + +import Criterion.Main + + +import Data.Binary +import Data.Binary.Typed +import Data.Typeable +import Control.DeepSeq +import Control.Exception (evaluate) + + + + + + +-- Test values + +someInt :: Int +someInt = 12345 + +someShortString :: String +someShortString = "Hello" + +someLongString :: String +someLongString = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam\ + \ vitae lacinia tellus. Maecenas posuere." + +someComplicated :: Complicated +someComplicated = Right (Left "Hello") + + +-- | Data with a normal form. +data NF = forall a. NFData a => NF a + +-- | Evaluate 'NF' data to normal form. +force' :: NF -> () +force' (NF x) = x `deepseq` () + + + +type Complicated = Either (Char, Int) (Either String (Maybe Integer)) + + + +main :: IO () +main = do + forceCafs + defaultMain [ bgroup "Encode" bench_binaryVsTyped ] + +-- | List of all data that should be fully evaluated before the benchmark is +-- run. +cafs :: [NF] +cafs = + [ NF someInt + , NF someShortString + , NF someLongString + , NF defaultInt + , NF defaultString + , NF (encode intValUntyped) -- Evaluate the encodings to NF to force a 'Typed'. Hacky but works :-) + , NF (encode intValHashed) + , NF (encode intValShown) + , NF (encode intValFull) + , NF (encode strSValUntyped) + , NF (encode strSValHashed) + , NF (encode strSValShown) + , NF (encode strSValFull) + , NF (encode strLValUntyped) + , NF (encode strLValHashed) + , NF (encode strLValShown) + , NF (encode strLValFull) + ] + +forceCafs :: IO () +forceCafs = mapM_ (evaluate . force') cafs + + +bench_binaryVsTyped :: [Benchmark] +bench_binaryVsTyped = + [ bgroup "Int" + [ bench_int_untyped + , bgroup "recalculate" bench_int + , bgroup "precache" (bench_encode_precached intValUntyped + intValHashed + intValShown + intValFull + someInt) + ] + , bgroup "\"hello\"" + [ bench_short_string_untyped + , bgroup "recalculate" bench_short_string + , bgroup "precache" (bench_encode_precached strSValUntyped + strSValHashed + strSValShown + strSValFull + someShortString) + ] + , bgroup "Lipsum (length 100)" + [ bench_long_string_untyped + , bgroup "recalculate" bench_long_string + , bgroup "precache" (bench_encode_precached strLValUntyped + strLValHashed + strLValShown + strLValFull + someLongString) + ] + , bgroup "Complicated type" + [ bench_complicated_untyped + , bgroup "recalculate" bench_complicated + , bgroup "precache" (bench_encode_precached compLValUntyped + compLValHashed + compLValShown + compLValFull + someComplicated) + ] + ] + + + +defaultInt :: Int +defaultInt = 0 + +defaultString :: String +defaultString = "" + +defaultComplicated :: Complicated +defaultComplicated = Left (' ', 0) + +intValUntyped, intValHashed, intValShown, intValFull :: Typed Int +intValUntyped = precache (typed Untyped defaultInt) +intValHashed = precache (typed Hashed defaultInt) +intValShown = precache (typed Shown defaultInt) +intValFull = precache (typed Full defaultInt) + +strSValUntyped, strSValHashed, strSValShown, strSValFull :: Typed String +strSValUntyped = precache (typed Untyped defaultString) +strSValHashed = precache (typed Hashed defaultString) +strSValShown = precache (typed Shown defaultString) +strSValFull = precache (typed Full defaultString) + +strLValUntyped, strLValHashed, strLValShown, strLValFull :: Typed String +strLValUntyped = precache (typed Untyped defaultString) +strLValHashed = precache (typed Hashed defaultString) +strLValShown = precache (typed Shown defaultString) +strLValFull = precache (typed Full defaultString) + +compLValUntyped, compLValHashed, compLValShown, compLValFull :: Typed Complicated +compLValUntyped = precache (typed Untyped defaultComplicated) +compLValHashed = precache (typed Hashed defaultComplicated) +compLValShown = precache (typed Shown defaultComplicated) +compLValFull = precache (typed Full defaultComplicated) + + + +bench_int :: [Benchmark] +bench_int = map (bench_encode someInt) formats + +bench_int_untyped :: Benchmark +bench_int_untyped = bench "Binary only" (nf encode someInt) + +bench_short_string :: [Benchmark] +bench_short_string = map (bench_encode someShortString) formats + +bench_short_string_untyped :: Benchmark +bench_short_string_untyped = bench "Binary only" (nf encode someShortString) + +bench_long_string :: [Benchmark] +bench_long_string = map (bench_encode someLongString) formats + +bench_long_string_untyped :: Benchmark +bench_long_string_untyped = bench "Binary only" (nf encode someLongString) + +bench_complicated :: [Benchmark] +bench_complicated = map (bench_encode someComplicated) formats + +bench_complicated_untyped :: Benchmark +bench_complicated_untyped = bench "Binary only" (nf encode someComplicated) + +formats :: [TypeFormat] +formats = [ Untyped + , Hashed + , Shown + , Full + ] + +-- | Simply encode a value using the specified 'TypeFormat'. +bench_encode + :: (Binary a, Typeable a) + => a + -> TypeFormat + -> Benchmark +bench_encode x format = bench description (nf (encodeTyped format) x) + where description = "Typed: " ++ show format + + + +-- | Encode a value using a precached 'Typed' value. +bench_encode_precached + :: (Binary a, Typeable a) + => Typed a -- ^ Precached 'Untyped' dummy value + -> Typed a -- ^ dito, with 'Hashed' + -> Typed a -- ^ dito, with 'Shown' + -> Typed a -- ^ dito, with 'Full' + -> a -- ^ Actual value to encode + -> [Benchmark] +bench_encode_precached untyped hashed shown full x = + [ bench (description Untyped) (nf (encodeTypedLike untyped) x) + , bench (description Hashed) (nf (encodeTypedLike hashed ) x) + , bench (description Shown) (nf (encodeTypedLike shown ) x) + , bench (description Full) (nf (encodeTypedLike full ) x) + ] + where description format = "Typed: " ++ show format diff --git a/benchmark/CriterionOverview.hs b/benchmark/CriterionOverview.hs new file mode 100644 --- /dev/null +++ b/benchmark/CriterionOverview.hs @@ -0,0 +1,135 @@ +-- | This generates the benchmark to be shown in the readme and the .cabal +-- file. + +{-# LANGUAGE ExistentialQuantification #-} + +import Criterion.Main + + +import Data.Binary +import Data.Binary.Typed +import Data.ByteString.Lazy (ByteString) +import Control.DeepSeq +import Control.Exception (evaluate) + + +-- Encoding mode to be used +mode :: TypeFormat +mode = Hashed + +type Complicated = Either (Char, Int) (Either String (Maybe Integer)) + +value :: Complicated +value = Right (Left ("Lorem ipsum dolor sit amet, consectetur adipiscing elit.\ + \ Nam vitae lacinia tellus. Maecenas posuere.")) + +-- Precalcualte encoded values for decoding benchmark +value_encodedBinary, value_encodedTyped :: ByteString +value_encodedBinary = encode value +value_encodedTyped = encodeTyped mode value + + + +-- Cached typed encoder +encodeTyped' :: Complicated -> ByteString +encodeTyped' = encodeTypedLike (typed mode dummyValue) + where dummyValue :: Complicated + dummyValue = Left ('x', 0) + + + +main :: IO () +main = do + evaluate (value `deepseq` ()) + defaultMain [ bgroup "encode only" bench_encode + , bgroup "decode only" bench_decode + , bgroup "encode+decode" bench_both + ] + + +-- ############################################################################# +-- ### Encode only ########################################################### +-- ############################################################################# + + + +bench_encode :: [Benchmark] +bench_encode = [ bench_encode_binaryOnly + , bench_encode_uncached + , bench_encode_cached + ] + +bench_encode_binaryOnly :: Benchmark +bench_encode_binaryOnly = bench d (nf f value) + where d = "Binary only" + f = encode + +bench_encode_uncached :: Benchmark +bench_encode_uncached = bench d (nf f value) + where d = "Uncached" + f = encodeTyped mode + +bench_encode_cached :: Benchmark +bench_encode_cached = bench d (nf f value) + where d = "Cached" + f = encodeTyped' + + + + + +-- ############################################################################# +-- ### Decode only ########################################################### +-- ############################################################################# + + + +bench_decode :: [Benchmark] +bench_decode = [ bench_decode_binaryOnly + , bench_decode_typed + ] + +bench_decode_binaryOnly :: Benchmark +bench_decode_binaryOnly = bench d (nf f value_encodedBinary) + where d = "Binary only" + f :: ByteString -> Complicated + f = decode + +bench_decode_typed :: Benchmark +bench_decode_typed = bench d (nf f value_encodedTyped) + where d = "Typed" + f :: ByteString -> Complicated + f = unsafeDecodeTyped + + + + + +-- ############################################################################# +-- ### Encode+decode ######################################################### +-- ############################################################################# + +bench_both :: [Benchmark] +bench_both = [ bench_both_binaryOnly + , bench_both_uncached + , bench_both_cached + ] + + +bench_both_binaryOnly :: Benchmark +bench_both_binaryOnly = bench d (nf f value) + where d = "Binary only" + f :: Complicated -> Complicated + f = decode . encode + +bench_both_uncached :: Benchmark +bench_both_uncached = bench d (nf f value) + where d = "Uncached" + f :: Complicated -> Complicated + f = unsafeDecodeTyped . encodeTyped mode + +bench_both_cached :: Benchmark +bench_both_cached = bench d (nf f value) + where d = "Cached" + f :: Complicated -> Complicated + f = unsafeDecodeTyped . encodeTyped' diff --git a/binary-typed.cabal b/binary-typed.cabal new file mode 100644 --- /dev/null +++ b/binary-typed.cabal @@ -0,0 +1,104 @@ +name: binary-typed +version: 0.1.0.0 +synopsis: Type-safe binary serialization +Description: + `Binary` serialization tagged with type information, allowing for + typechecking and useful error messages at the receiving site. + . + This package serves the same purpose as tagged-binary, with a couple of + key differences: + . + * Support of different kinds of serialized type annotations, each with + specific strengths and weaknesses. + . + * Error messages can provide details on type errors at the cost of + longer message lengths to include the necessary information. + . + * Serialization computationally almost as efficient as "Data.Binary" when + precaching type representations; decoding however is slower. + These values obviously depend a lot on the involved data and its type; + an example benchmark is shown in the picture below. + . + * No depencency on @Internal@ modules of other libraries, and a very small + dependency footprint in general. + . + For information about usage, see the "Data.Binary.Typed.Tutorial" module. + . + Performance-wise, here is a value @Right (Left \<100 chars lipsum\>)@ of + type @Either (Char, Int) (Either String (Maybe Integer))@ benchmarked + using the @Hashed@ type representation: + . + <> + . + +homepage: https://github.com/quchen/binary-typed +bug-reports: https://github.com/quchen/binary-typed/issues +license: BSD2 +license-file: LICENSE +author: David Luposchainsky +maintainer: dluposchainsky on googles email service +copyright: David Luposchainsky +category: Data, Serialization +build-type: Simple +cabal-version: >= 1.20 +extra-source-files: doc/*.png + +source-repository head + type: git + location: https://github.com/quchen/binary-typed + +library + default-language: Haskell2010 + exposed-modules: Data.Binary.Typed + Data.Binary.Typed.Internal + Data.Binary.Typed.Tutorial + ghc-options: -Wall + hs-source-dirs: src + other-extensions: GADTs, DeriveGeneric + build-depends: base >= 4.7 && < 5 + , binary >= 0.7 + , bytestring >= 0.9 + , murmur-hash >= 0.1 + + +test-suite tasty + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans + hs-source-dirs: tests + main-is: Tests.hs + other-modules: HUnit, QuickCheck + other-extensions: ScopedTypeVariables, NumDecimals + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5 + , binary >= 0.7 + , binary-typed + , tasty >= 0.8 + , tasty-hunit >= 0.8 + , tasty-quickcheck >= 0.8 + +benchmark criterion + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: Criterion.hs + build-depends: base + , binary + , binary-typed + , criterion + , deepseq + ghc-options: -Wall + + + +benchmark criterion-overview + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: CriterionOverview.hs + build-depends: base + , binary + , binary-typed + , criterion + , deepseq + , bytestring + ghc-options: -Wall diff --git a/doc/bench-overview.png b/doc/bench-overview.png new file mode 100644 Binary files /dev/null and b/doc/bench-overview.png differ diff --git a/src/Data/Binary/Typed.hs b/src/Data/Binary/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Typed.hs @@ -0,0 +1,176 @@ +-- | Defines a type-safe 'Data.Binary.Binary' instance to ensure data is +-- decoded with the type it was serialized from. +-- +-- For usage information, see the "Data.Binary.Typed.Tutorial" module. + +module Data.Binary.Typed ( + + -- * Core functions + Typed + , typed + , TypeFormat(..) + , erase + + + -- * Useful general helpers + , mapTyped + , reValue + , reType + , precache + + + -- * Typed serialization + + -- ** Encoding + , encodeTyped + , encodeTypedLike + + -- ** Decoding + , decodeTyped + , decodeTypedOrFail + , unsafeDecodeTyped + +) where + + + +import qualified Data.ByteString.Lazy as BSL + +import Data.Typeable (Typeable) + +import Data.Binary +import Data.Binary.Get (ByteOffset) + +import Data.Binary.Typed.Internal + + + + +-- | Modify the value contained in a 'Typed', keeping the same sort of type +-- representation. In other words, calling 'mapTyped' on something that is +-- typed using 'Hashed' will yield a 'Hashed' value again. +-- +-- Note: this destroys 'precache'd information, so that values have to be +-- 'precache'd again if desired. As a consequence, @'mapTyped' 'id'@ +-- can be used to un-'precache' values. +mapTyped :: Typeable b => (a -> b) -> Typed a -> Typed b +mapTyped f (Typed ty x) = typed (getFormat ty) (f x) + + + +-- | Change the value contained in a 'Typed', leaving the type representation +-- unchanged. This can be useful to avoid recomputation of the included type +-- information, and can improve performance significantly if many individual +-- messages are serialized. +-- +-- Can be seen as a more efficient 'mapTyped' in case @f@ is an endomorphism +-- (i.e. has type @a -> a@). +reValue :: (a -> a) -> Typed a -> Typed a +reValue f (Typed ty x) = Typed ty (f x) + + + +-- | Change the way a type is represented inside a 'Typed' value. +-- +-- @ +-- 'reType' format x = 'typed' format ('erase' x) +-- @ +reType :: Typeable a => TypeFormat -> Typed a -> Typed a +reType format (Typed _ty x) = typed format x + + + +-- | Encode a 'Typeable' value to 'BSL.ByteString' that includes type +-- information. If at all possible, prefer the more efficient 'encodeTypedLike' +-- though. +-- +-- @ +-- 'encodeTyped' format value = 'encode' ('typed' format value) +-- @ +encodeTyped :: (Typeable a, Binary a) + => TypeFormat + -> a + -> BSL.ByteString +encodeTyped format value = encode (typed format value) + + + +-- | Version of 'encodeTyped' that avoids recomputing the type representation +-- of the input by using the one already contained in the first parameter. +-- This is usually /much/ more efficient than using 'encode', having a +-- computational cost similar to using 'Binary' directly. +-- +-- @ +-- 'encodeTypedLike' ty x +-- -- is observationally identical to +-- 'encode' ('reValue' ('const' x) ty) +-- @ +-- +-- This function is intended to generate new encoding functions like so: +-- +-- @ +-- encodeInt :: 'Int' -> 'Data.ByteString.Lazy.ByteString' +-- encodeInt = 'encodeTypedLike' ('typed' 'Full' 0) +-- @ +encodeTypedLike + :: (Typeable a, Binary a) + => Typed a + -> a + -> BSL.ByteString +encodeTypedLike dummy = let (Typed ty _) = precache dummy + in encode . Typed ty + + + +-- | Decode a typed value, throwing an error at runtime on failure. +-- Typed cousin of 'Data.Binary.decode'. +-- +-- @ +-- encoded = 'encodeTyped' 'Full' ("hello", 1 :: 'Int', 2.34 :: 'Double') +-- +-- -- \ +-- 'unsafeDecodeTyped' encoded :: ('String', 'Int', 'Double') +-- +-- -- (Descriptive) runtime error +-- 'unsafeDecodeTyped' encoded :: ('Char', 'Int', 'Double') +-- @ +unsafeDecodeTyped :: (Typeable a, Binary a) + => BSL.ByteString + -> a +unsafeDecodeTyped = erase . decode + + + +-- | Safely decode data, yielding 'Either' an error 'String' or the value, +-- along with meta-information of the consumed binary data. +-- +-- * Typed cousin of 'Data.Binary.decodeOrFail'. +-- * Like 'decodeTyped', but with additional data. +decodeTypedOrFail :: (Typeable a, Binary a) + => BSL.ByteString + -> Either (BSL.ByteString, ByteOffset, String) + (BSL.ByteString, ByteOffset, a) +decodeTypedOrFail input = case decodeOrFail input of + Right (rest, offset, value) -> Right (rest, offset, erase value) + Left l -> Left l + + + +-- | Safely decode data, yielding 'Either' an error 'String' or the value. +-- Equivalent to 'decodeTypedOrFail' stripped of the non-essential data. +-- +-- @ +-- encoded = 'encodeTyped' 'Full' ("hello", 1 :: 'Int', 2.34 :: 'Double') +-- +-- -- Right \: +-- 'decodeTyped' encoded :: 'Either' 'String' ('String', 'Int', 'Double') +-- +-- -- Left "Type error: expected (Char, Int, Double), got (String, Int, Double)" +-- 'decodeTyped' encoded :: 'Either' 'String' ('Char', 'Int', 'Double') +-- @ +decodeTyped :: (Typeable a, Binary a) + => BSL.ByteString + -> Either String a +decodeTyped bs = case decodeTypedOrFail bs of + Left (_rest, _offset, err) -> Left err + Right (_rest, _offset, value) -> Right value diff --git a/src/Data/Binary/Typed/Internal.hs b/src/Data/Binary/Typed/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Typed/Internal.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE DeriveGeneric #-} + + + +-- | Internals, exposed mostly for potential use by testsuites and benchmarks. +-- +-- __Not recommended to be used from within other independent libraries.__ +module Data.Binary.Typed.Internal ( + + -- * 'Typed' + Typed(..) + , TypeInformation(..) + , Hash(..) + , typed + , TypeFormat(..) + , getFormat + , typecheck + , erase + , precache + + -- * 'TypeRep' + , TypeRep(..) + , stripTypeRep + , unStripTypeRep + , hashType + + -- * 'TyCon' + , TyCon(..) + , stripTyCon + , unStripTyCon + +) where + + + +import GHC.Generics +import Text.Printf +-- import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import Data.Typeable (Typeable, typeOf) +import qualified Data.Typeable as Ty + +import Data.Binary + +-- Crypto stuff for hashing +import Data.Digest.Murmur64 + + + +-- ^ Type information stored alongside a value to be serialized, so that the +-- recipient can do consistency checks. See 'TypeFormat' for more detailed +-- information on the fields. +data TypeInformation = Untyped' + | Hashed' Hash + | Shown' Hash String + | Full' TypeRep + | Cached' BSL.ByteString + deriving (Eq, Ord, Show, Generic) + +instance Binary TypeInformation + + + +-- | Extract which 'TypeFormat' was used to create a certain 'TypeInformation'. +getFormat :: TypeInformation -> TypeFormat +getFormat (Untyped' {}) = Untyped +getFormat (Hashed' {}) = Hashed +getFormat (Shown' {}) = Shown +getFormat (Full' {}) = Full +getFormat (Cached' bs) = getFormat (decode bs) + -- decode is safe here since caching ensures + -- a well-formed input ByteString + + + +-- | A hash value of a 'TypeRep'. Currently a 64-bit value created using +-- the MurmurHash2 algorithm. +newtype Hash = Hash Word64 + deriving (Eq, Ord, Show, Generic) +instance Binary Hash + + + +-- | A value suitable to be typechecked using the contained extra type +-- information. +data Typed a = Typed TypeInformation a + -- ^ Using this data constructor directly is unsafe, as it allows + -- construction of ill-typed 'Typed' data. Use the 'typed' smart + -- constructor unless you really need 'Typed'. + +-- | "typed \ \" +instance Show a => Show (Typed a) where + show (Typed ty x) = printf "typed %s (%s)" + (show (getFormat ty)) + (show x) + +-- | Ensures data is decoded as the appropriate type with high or total +-- confidence (depending on with what 'TypeFormat' the 'Typed' was +-- constructed). +instance (Binary a, Typeable a) => Binary (Typed a) where + get = do (ty, value) <- get + either fail return (typecheck (Typed ty value)) + -- NB: 'fail' is safe in Get Monad + put (Typed ty value) = put (ty, value) + + + +-- | Calculate the serialization of a 'TypeInformation' and store it in a +-- 'Typed' value so it does not have to be recalculated on every call to +-- 'encode'. +-- +-- This is typically applied to a dummy value created using 'typed' and +-- the desired 'TypeFormat'; the actual data is then inserted using +-- 'Data.Binary.Typed.reValue', which is how +-- 'Data.Binary.Typed.encodeTyped' works. +precache :: Typed a -> Typed a +precache t@(Typed (Cached' _) _) = t +precache (Typed ty x) = Typed (Cached' (encode ty)) x + -- This is the only place that constructs a + -- Cached' value. + + + +-- | Different ways of including/verifying type information of serialized +-- messages. +data TypeFormat = + + -- | Include no type information. + -- + -- * Requires one byte more than using 'Binary' directly (namely to + -- tag the data as untyped, required for the decoding step). + Untyped + + -- | Compare types by their hash values (using the MurmurHash2 + -- algorithm). + -- + -- * Requires only 8 additional bytes for the type information. + -- * Subject to false positive due to hash collisions, although in + -- practice this should almost never happen. + -- * Type errors cannot tell the provided type ("Expected X, received + -- type with hash H") + + | Hashed + + -- | Compare 'String' representation of types, obtained by calling + -- 'show' on the 'TypeRep', and also include a hash value + -- (like 'Hashed'). The former is mostly for readable error messages, + -- the latter provides collision resistance. + -- + -- * Data size larger than 'Hashed', but usually smaller than 'Full'. + -- * Both the hash and the shown type must match to satisfy the + -- typechecker. + -- * Useful type errors ("expected X, received Y"). All types are + -- shown unqualified though, making @Foo.X@ and @Bar.X@ look + -- identical in error messages. + | Shown + + -- | Compare the full representation of a data type. + -- + -- * More verbose than 'Hashed' and 'Shown'. As a rule of thumb, + -- transmitted data is roughly the same as 'Shown', but all names + -- are fully qualified (package, module, type name). + -- * Correct comparison (no false positives). An semi-exception here + -- is when types change between package versions: + -- @package-1.0 Foo.X@ and @package-1.1 Foo.X@ count as the same + -- type. + -- * Useful type errors ("expected X, received Y"). All types are + -- shown unqualified though, making @Foo.X@ and @Bar.X@ look + -- identical in error messages. + | Full + + deriving (Eq, Ord, Show) + + + +-- | Construct a 'Typed' value using the chosen type format. +-- +-- Example: +-- +-- @ +-- value = 'typed' 'Full' ("hello", 1 :: 'Int', 2.34 :: 'Double') +-- encded = 'encode' value +-- @ +-- +-- The decode site can now verify whether decoding happens with the right type. +typed :: Typeable a => TypeFormat -> a -> Typed a +typed format x = Typed typeInformation x where + ty = typeOf x + typeInformation = case format of + Untyped -> Untyped' + Hashed -> Hashed' (hashType ty) + Shown -> Shown' (hashType ty) (show ty) + Full -> Full' (stripTypeRep ty) + + + +-- | Extract the value of a 'Typed', i.e. strip off the explicit type +-- information. +-- +-- This function is safe to use for all 'Typed' values created by the public +-- API, since all construction sites ensure the actual type matches the +-- contained type description. +-- +-- @ +-- 'erase' ('typed' format x) == x +-- @ +erase :: Typed a -> a +erase (Typed _ty value) = value + + + +-- | Typecheck a 'Typed'. Returns the (well-typed) input, or an error message +-- if the types don't work out. +typecheck :: Typeable a => Typed a -> Either String (Typed a) +typecheck ty@(Typed typeInformation x) = case typeInformation of + Cached' cache -> decode' cache >>= \ty' -> typecheck (Typed ty' x) + Full' full | exFull /= full -> Left (fullError full) + Hashed' hash | exHash /= hash -> Left (hashError hash) + Shown' hash str | (exHash, exShow) /= (hash, str) + -> Left (shownError hash str) + _no_type_error -> Right ty + + + where + + -- ex = expected + exType = typeOf x + exHash = hashType exType + exShow = show exType + exFull = stripTypeRep exType + + hashError hash = printf pat exShow (show exHash) (show hash) + where pat = "Type error: expected type %s with hash %s,\ + \ but received data with hash %s" + shownError hash str = printf pat exShow (show exHash) str (show hash) + where pat = "Type error: expected type %s and hash %s,\ + \ but received data with type %s and hash %s" + fullError full = printf pat exShow (show full) + where pat = "Type error: expected type %s,\ + \ but received data with type %s" + + decode' bs = case decodeOrFail bs of + Left (_,_,err) -> Left ("Cache error! " ++ err) + Right (_,_,val) -> Right val + + + +-- | Hash a 'Ty.TypeRep'. +hashType :: Ty.TypeRep -> Hash +hashType = Hash . asWord64 . hash64 . stripTypeRep + + + +-- | 'Ty.TypeRep' without the (internal) fingerprint. +data TypeRep = TypeRep TyCon [TypeRep] + deriving (Eq, Ord, Generic) +instance Binary TypeRep + +instance Show TypeRep where + show = show . unStripTypeRep + +instance Hashable64 TypeRep where + hash64Add (TypeRep tycon args) = hash64Add (tycon, args) + + + + +-- | 'Ty.TyCon' without the (internal) fingerprint. +data TyCon = TyCon String String String -- ^ Package, module, constructor name + deriving (Eq, Ord, Generic) +instance Binary TyCon + +instance Show TyCon where + show = show . unStripTyCon + +instance Hashable64 TyCon where + hash64Add (TyCon p m c) = hash64Add (p, m, c) + + + +-- | Strip a 'Ty.TypeRep' off the fingerprint. Inverse of 'unStripTypeRep'. +stripTypeRep :: Ty.TypeRep -> TypeRep +stripTypeRep typerep = TypeRep (stripTyCon tycon) (map stripTypeRep args) + where (tycon, args) = Ty.splitTyConApp typerep + + + +-- | Add a fingerprint to a 'TypeRep'. Inverse of 'stripTypeRep'. +unStripTypeRep :: TypeRep -> Ty.TypeRep +unStripTypeRep (TypeRep tyCon args) = Ty.mkTyConApp (unStripTyCon tyCon) + (map unStripTypeRep args) + + + +-- | Strip a 'Ty.TyCon' off the fingerprint. Inverse of 'unStripTyCon'. +stripTyCon :: Ty.TyCon -> TyCon +stripTyCon tycon = TyCon (Ty.tyConPackage tycon) + (Ty.tyConModule tycon) + (Ty.tyConName tycon) + -- The Typeable API doesn't expose the + -- TyCon constructor, so pattern matching + -- is not possible here (without depending + -- on Typeable.Internal). + + + +-- | Add a fingerprint to a 'TyCon'. Inverse of 'stripTyCon'. +unStripTyCon :: TyCon -> Ty.TyCon +unStripTyCon (TyCon p m n) = Ty.mkTyCon3 p m n -- package, module, name diff --git a/src/Data/Binary/Typed/Tutorial.hs b/src/Data/Binary/Typed/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Typed/Tutorial.hs @@ -0,0 +1,139 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + + + +-- | This meta-module exists only for documentational purposes; the library +-- functionality is found in "Data.Binary.Typed". + + + +module Data.Binary.Typed.Tutorial ( + + -- * Motivation + -- $motivation + + -- * Basic usage + -- $usage + + -- * API overview + -- $api + +) where + + + +import Data.Binary.Typed +import Data.Binary.Typed.Internal + +-- $motivation +-- +-- Standard 'Binary' serializes to 'Data.ByteString.ByteString', which +-- is an untyped format; deserialization of unexpected input usually results +-- in unusable data. +-- +-- This module defines a 'Typed' type, which allows serializing both a value +-- and the type of that value; deserialization can then check whether the +-- received data was sent assuming the right type, and error messages +-- may provide insight into the type mismatch. +-- +-- For example, this uses 'Data.Binary.Binary' directly: +-- +-- @ +-- test1 = let val = 10 :: 'Int' +-- enc = 'Data.Binary.encode' val +-- dec = 'Data.Binary.decode' enc :: 'Bool' +-- in 'print' dec +-- @ +-- +-- This behaves unexpectedly: An 'Int' value is converted to a 'Bool', which +-- corresponds to a wacky type coercion. The receiving end has no way of +-- knowing what the incoming data should have been interpreted as. +-- +-- Using 'Typed', this can be avoided: +-- +-- @ +-- test2 = let val = 10 :: 'Int' +-- enc = 'Data.Binary.encode' ('typed' 'Full' val) +-- dec = 'Data.Binary.decode' enc :: 'Typed' 'Bool' +-- in 'print' dec +-- @ +-- +-- This time 'Data.Binary.decode' raises an error: the incoming data is tagged +-- as an 'Int', but is attempted to be decoded as 'Bool'. + + + + + + +-- $usage +-- +-- This package is typically used for debugging purposes. 'Hashed' type +-- information keeps the size overhead relatively low, but requires a certain +-- amount of computational ressources. It is reliable at detecting errors, but +-- not very good at telling specifics about it. If a problem is identified, the +-- typing level can be increased to 'Shown' or 'Full', providing information +-- about the involved types. If performance is critical, 'Untyped' \"typed\" +-- encoding can be used, with minimal overhead compared to using 'Binary' +-- directly. +-- +-- For convenience, this module exports a couple of convenience functions that +-- have the type-mangling baked in already. The above example could have been +-- written as +-- +-- @ +-- test3 = let val = 10 :: 'Int' +-- enc = 'encodeTyped' val +-- dec = 'decodeTyped' enc :: 'Either' 'String' 'Bool' +-- in 'print' dec +-- @ +-- +-- However, using 'encodeTyped' is computationally inefficient when many +-- messages of the same type are serialized, since it recomputes a serialized +-- version of that type for every single serialized value from scratch. +-- 'encodeTypedLike' exists to remedy that: it takes a separately constructed +-- 'Typed' dummy value, and computes a new serialization function for that type +-- out of it. This serialization function then re-uses the type representation +-- of the dummy value, and simply replaces the contained value on each +-- serialization so that no unnecessary overhead is introduced. +-- +-- @ +-- -- Computes 'Int's type representation 100 times: +-- manyIntsNaive = map 'encodeTyped' [1..100 :: 'Int'] +-- +-- -- Much more efficient: prepare dummy value to precache the +-- -- type representation, computing it only once: +-- 'encodeInt' = 'encodeTypedLike' ('typed' 'Full' (0 :: 'Int')) +-- manyIntsCached = map 'encodeInt' [1..100] +-- @ + + + + + +-- $api +-- +-- +-- The core definitions in "Data.Binary.Typed" are: +-- +-- * 'Typed' (the main type) +-- * 'typed' (construct 'Typed' values) +-- * 'TypeFormat' (a helper type for 'typed') +-- * 'erase' (deconstruct 'Typed' vales) +-- +-- In addition to those, a couple of useful helper functions with more efficient +-- implementation than what the core definitions could offer: +-- +-- * 'mapTyped' (change values contained in 'Typed's) +-- * 'reValue' (change value, but don't recompute type representation) +-- * 'reType' (change type representation, but keep value) +-- * 'precache' (compute serialized type representation, useful as an optimization) +-- +-- Lastly, there are a number of encoding/decoding functions, mostly for +-- convenience: +-- +-- * 'encodeTyped' (pack in 'Typed' and then 'encode') +-- * 'encodeTypedLike' (usually much more efficient version of 'encodeTyped') +-- * 'decodeTyped' (decode 'Typed' 'Data.ByteString.Lazy.ByteString' to @'Either' 'String' a@) +-- * 'decodeTypedOrFail' (like 'decodeTyped', but with more meta information) +-- * 'unsafeDecodeTyped' (which throws a runtime error on type mismatch) diff --git a/tests/HUnit.hs b/tests/HUnit.hs new file mode 100644 --- /dev/null +++ b/tests/HUnit.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE AutoDeriveTypeable #-} + +module HUnit (props) where + + +import Data.Either + +import Data.Binary.Typed +import Data.Binary (Binary(..)) +import Data.Typeable (Typeable) + +import Test.Tasty +import Test.Tasty.HUnit + + +-- | Used as a dummy placeholder for fields that never carry values. +data X deriving (Typeable) +instance Binary X where + get = undefined + put = undefined + + + + +-- | The entire HUnit test tree, to be imported qualified +props :: TestTree +props = tree tests where + tree = testGroup "HUnit" + tests = [ error_coercions_simple_large_to_small + , error_coercions_simple_small_to_large + , error_coercions_complicated + ] + + + + + +-- ############################################################################# +-- ### Simple bad type coercions ############################################# +-- ############################################################################# + + + +-- | Decode a typed value as something else. +wackyCoercion :: (Binary a, Typeable a, Binary b, Typeable b) + => TypeFormat + -> a + -> Either String b +wackyCoercion format value = decodeTyped (encodeTyped format value) + + + +-- | Test whether encoding an Int and decoding it as Bool produces a type error. +-- This converts a large field (Int) to one that requires only very little +-- memory (Bool). +error_coercions_simple_large_to_small :: TestTree +error_coercions_simple_large_to_small = tree tests where + tree = testGroup "Encode Int, decode Bool => Type error" + tests = [ error_int_bool_hashed + , error_int_bool_shown + , error_int_bool_full + ] + +-- | See 'error_coercions_simple_large_to_small' +error_int_bool_hashed :: TestTree +error_int_bool_hashed = + testCase "Hashed" $ + + isLeft (wackyCoercion Hashed (123 :: Int) :: Either String Bool) + @? + "No type error when coercing Int to Bool (with hashed type info)" + +-- | See 'error_coercions_simple_large_to_small' +error_int_bool_shown :: TestTree +error_int_bool_shown = + testCase "Shown" $ + + isLeft (wackyCoercion Shown (123 :: Int) :: Either String Bool) + @? + "No type error when coercing Int to Bool (with shown type info)" + +-- | See 'error_coercions_simple_large_to_small' +error_int_bool_full :: TestTree +error_int_bool_full = + testCase "Full" $ + + isLeft (wackyCoercion Full (123 :: Int) :: Either String Bool) + @? + "No type error when coercing Int to Bool (with full type info)" + + + + +-- | Test whether encoding an Int and decoding it as Bool produces a type error. +-- This converts a large field (Int) to one that requires only very little +-- memory (Bool). +error_coercions_simple_small_to_large :: TestTree +error_coercions_simple_small_to_large = tree tests where + tree = testGroup "Encode Bool, decode Int => Type error" + tests = [ error_bool_int_hashed + , error_bool_int_shown + , error_bool_int_full + ] + +-- | See 'error_coercions_simple_small_to_large' +error_bool_int_hashed :: TestTree +error_bool_int_hashed = + testCase "Hashed" $ + + isLeft (wackyCoercion Hashed True :: Either String Int) + @? + "No type error when coercing Bool to Int (with hashed type info)" + +-- | See 'error_coercions_simple_small_to_large' +error_bool_int_shown :: TestTree +error_bool_int_shown = + testCase "Shown" $ + + isLeft (wackyCoercion Shown True :: Either String Int) + @? + "No type error when coercing Bool to Int (with shown type info)" + +-- | See 'error_coercions_simple_small_to_large' +error_bool_int_full :: TestTree +error_bool_int_full = + testCase "Full" $ + + isLeft (wackyCoercion Full True :: Either String Int) + @? + "No type error when coercing Bool to Int (with full type info)" + + + + + +-- ############################################################################# +-- ### Complicated bad type coercion ######################################### +-- ############################################################################# + + + +-- | Test whether doing a coercion of a complicated type with a small +-- discrepancy produces a type error +error_coercions_complicated :: TestTree +error_coercions_complicated = tree tests where + tree = testGroup "Complicated type coercion with small discrepancy" + tests = [ error_long_type_hashed + , error_long_type_shown + , error_long_type_full + ] + + + +-- | See 'error_coercions_complicated' +error_long_type_hashed :: TestTree +error_long_type_hashed = + testCase "Hashed" $ + + isLeft (wackyCoercion Hashed long_type_input `asTypeOf` long_type_output) + @? + "No type error doing a complicated coercion (with hashed type info)" + + + +-- | See 'error_coercions_complicated' +error_long_type_shown :: TestTree +error_long_type_shown = + testCase "Shown" $ + + isLeft (wackyCoercion Shown long_type_input `asTypeOf` long_type_output) + @? + "No type error doing a complicated coercion (with shown type info)" + +-- | See 'error_coercions_complicated' +error_long_type_full :: TestTree +error_long_type_full = + testCase "Full" $ + + isLeft (wackyCoercion Full long_type_input `asTypeOf` long_type_output) + @? + "No type error doing a complicated coercion (with full type info)" + + + +long_type_input :: (Either (Either X (), Either X (Either String X)) X, String) +long_type_input = (Left (Right (), Right (Left "hello")), "world") ------ Different types deep down + ------ +long_type_output :: Either String (Either (Either X (), Either X (Either Char X)) X, String) +long_type_output = error "long_type_output should never be evaluated, it is\ + \ only provided for its type" diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/tests/QuickCheck.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE NumDecimals #-} + +module QuickCheck (props) where + + +import Control.Applicative +import Data.Typeable (Typeable) + +import Data.Binary +import Data.Binary.Typed +import Data.Binary.Typed.Internal + +import Test.Tasty +import Test.Tasty.QuickCheck +import Text.Show.Functions () -- This fixes the missing Show (a->b) instance in + -- Travis. Can probably be removed in the future. + + + +-- | The entire QuickCheck test tree, to be imported qualified +props :: TestTree +props = tree tests where + tree = testGroup "QuickCheck" + tests = [ prop_typerep + , prop_inverses + , prop_api + , prop_internal + ] + + + +-- | Check whether typed encoding and decoding are inverses of each other +prop_inverses :: TestTree +prop_inverses = tree tests where + tree = testGroup "decode.encode = id" + tests = [ prop_inverses_int + , prop_inverses_string + ] + + + +-- | Check whether encoding and decoding an Int works properly +prop_inverses_int :: TestTree +prop_inverses_int = tree tests where + + tree = localOption (QuickCheckMaxSize maxBound) + . localOption (QuickCheckTests 1e3) + . testGroup "Int" + + tests = [ testProperty "Untyped" (prop Untyped) + , testProperty "Hashed" (prop Hashed) + , testProperty "Shown" (prop Shown) + , testProperty "Full" (prop Full) + , testProperty "Cached" prop_cached + ] + + prop :: TypeFormat -> Int -> Bool + prop format i = unsafeDecodeTyped (encodeTyped format i) == i + + prop_cached :: Typed Int -> Int -> Bool + prop_cached dummy i = unsafeDecodeTyped (encodeTypedLike dummy i) == i + + + +-- | Check whether encoding and decoding a String works properly +prop_inverses_string :: TestTree +prop_inverses_string = tree tests where + + tree = localOption (QuickCheckMaxSize 100) + . localOption (QuickCheckTests 1e3) + . testGroup "String" + + tests = [ testProperty "Untyped" (prop Untyped) + , testProperty "Hashed" (prop Hashed) + , testProperty "Shown" (prop Shown) + , testProperty "Full" (prop Full) + , testProperty "Cached" prop_cached + ] + + prop :: TypeFormat -> String -> Bool + prop format i = unsafeDecodeTyped (encodeTyped format i) == i + + prop_cached :: Typed String -> String -> Bool + prop_cached dummy i = unsafeDecodeTyped (encodeTypedLike dummy i) == i + + + +-- | Test properties of 'TypeRep's and 'TyCon's. +prop_typerep :: TestTree +prop_typerep = tree tests where + tree = localOption (QuickCheckTests 1e3) + . localOption (QuickCheckMaxSize 10) + . testGroup "TypeRep, TyCon" + + tests = [ prop_hash_total + ] + + + +-- | Generate lots of hashes from random 'typeRep's and see whether one of them +-- crashes. +prop_hash_total :: TestTree +prop_hash_total = testProperty "Hash function total" prop where + prop = forAll arbitrary + (\tyCon -> hashType (unStripTypeRep tyCon) `seq` True) + + + +instance Arbitrary TyCon where + arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary TypeRep where + arbitrary = TypeRep <$> arbitrary <*> args + where args = listOf (modifySize (`div` 2) arbitrary) + + + +-- | Modify the size parameter of a 'Gen'. +modifySize :: (Int -> Int) -> Gen a -> Gen a +modifySize f gen = sized (\n -> resize (f n) gen) + + + +-- | Check whether the laws mentioned in the docs hold +prop_api :: TestTree +prop_api = tree tests where + + tree = testGroup "API" + + tests = [ testProperty "erase" prop_erase + , testProperty "mapTyped id law" prop_mapTyped_id + , testProperty "mapTyped f.g law" prop_mapTyped_compose + , testProperty "reType" prop_reType + , testProperty "encodeTyped" prop_encodeTyped + , testProperty "encodeTypedLike" prop_encodeTypedLike + ] + + prop_erase :: TypeFormat -> Int -> Bool + prop_erase format x = erase (typed format x) == x + + prop_mapTyped_id :: Typed Double -> Bool + prop_mapTyped_id x = x `isEqual` mapTyped id x + + prop_mapTyped_compose + :: (Int -> Maybe Integer) + -> (Double -> Int) + -> Typed Double + -> Bool + prop_mapTyped_compose f g x = + mapTyped (f . g) x `isIdentical` (mapTyped f . mapTyped g) x + + prop_reType :: TypeFormat -> Typed Int -> Bool + prop_reType format x =reType format x `isIdentical` typed format (erase x) + + prop_encodeTyped :: TypeFormat -> Int -> Bool + prop_encodeTyped format value = + encodeTyped format value == encode (typed format value) + + prop_encodeTypedLike :: Typed Int -> Int -> Bool + prop_encodeTypedLike ty value = + (unsafeDecodeTyped (encodeTypedLike ty value) :: Int) + == + unsafeDecodeTyped (encode (reValue (const value) ty)) + + + +-- | Equality of 'Typed' values, taking only the contained value into account. +-- See also 'isIdentical'. +isEqual :: Eq a => Typed a -> Typed a -> Bool +isEqual (Typed _tyA a) (Typed _tyB b) = a == b + + + +-- | Equality of 'Typed' values, taking the contained type representation into +-- account. This means that a cached and an uncached (otherwise identical) +-- type representation are unequal. +-- See also 'isEqual'. +isIdentical :: Eq a => Typed a -> Typed a -> Bool +isIdentical (Typed tyA a) (Typed tyB b) = (tyA, a) == (tyB, b) + + + +instance (Arbitrary a, Typeable a) => Arbitrary (Typed a) where + arbitrary = frequency [(10, plain), (5, cached), (3, cached2)] + where plain = typed <$> arbitrary <*> arbitrary + cached = fmap precache plain + cached2 = fmap precache cached + +instance Arbitrary TypeFormat where + arbitrary = elements [Untyped, Hashed, Shown, Full] + + + +prop_internal :: TestTree +prop_internal = tree tests where + + tree = testGroup "Internal" + + tests = [ testProperty "getFormat" prop_getFormat + ] + + -- getFormat extracts the right format + prop_getFormat :: Typed Double -> Bool + prop_getFormat t@(Typed ty x) = t `isEqual` typed (getFormat ty) x diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,13 @@ +module Main where + +import Test.Tasty +import qualified QuickCheck +import qualified HUnit + + + +main :: IO () +main = defaultMain (testGroup "binary-typed testsuite" + [ QuickCheck.props + , HUnit.props + ])