binary-typed (empty) → 0.1.0.0
raw patch · 12 files changed
+1514/−0 lines, 12 filesdep +basedep +binarydep +binary-typedsetup-changedbinary-added
Dependencies added: base, binary, binary-typed, bytestring, criterion, deepseq, murmur-hash, tasty, tasty-hunit, tasty-quickcheck
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- benchmark/Criterion.hs +212/−0
- benchmark/CriterionOverview.hs +135/−0
- binary-typed.cabal +104/−0
- doc/bench-overview.png binary
- src/Data/Binary/Typed.hs +176/−0
- src/Data/Binary/Typed/Internal.hs +310/−0
- src/Data/Binary/Typed/Tutorial.hs +139/−0
- tests/HUnit.hs +191/−0
- tests/QuickCheck.hs +204/−0
- tests/Tests.hs +13/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Criterion.hs view
@@ -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
+ benchmark/CriterionOverview.hs view
@@ -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'
+ binary-typed.cabal view
@@ -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:+ .+ <<http://i.imgur.com/nY6hgMP.png>>+ .+ <doc/bench-overview.png (local copy)>+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
+ doc/bench-overview.png view
binary file changed (absent → 22136 bytes)
+ src/Data/Binary/Typed.hs view
@@ -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')+--+-- -- \<value\>+-- '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 \<value\>:+-- '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
+ src/Data/Binary/Typed/Internal.hs view
@@ -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 \<format\> \<value\>"+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
+ src/Data/Binary/Typed/Tutorial.hs view
@@ -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)
+ tests/HUnit.hs view
@@ -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"
+ tests/QuickCheck.hs view
@@ -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
+ tests/Tests.hs view
@@ -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+ ])