{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-- | 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(..)
, Typed'(..)
, TypeInformation(..)
, Hash5(..)
, mkHash5
, Hash32(..)
, Hash64(..)
, typed
, makeTypeInformation
, TypeFormat(..)
, getFormat
, typecheck
, typecheck'
, erase
, preserialize
-- * 'TypeRep'
, TypeRep(..)
, stripTypeRep
, unStripTypeRep
, hashType5
, hashed5Split
, hashType32
, hashType64
-- * 'TyCon'
, TyCon(..)
, stripTyCon
, unStripTyCon
) where
import GHC.Generics
import Text.Printf
import Data.Bits ((.&.), (.|.))
import Control.Applicative
-- 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 qualified Data.Digest.Murmur32 as H32
import qualified Data.Digest.Murmur64 as H64
-- ^ 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'
| Hashed5' Hash5
| Hashed32' Hash32
| Hashed64' Hash64
| Shown' Hash32 String
| Full' TypeRep
| Cached' BSL.ByteString -- ^ Pre-serialized representation
-- of one of the other fields.
deriving (Eq, Ord, Show, Generic)
instance Binary TypeInformation where
put Untyped' = putWord8 0
put (Hashed5' (Hash5 x)) = putWord8 (x .|. 1) -- See 'Hash5' for info
put (Hashed32' x) = putWord8 2 *> put x
put (Hashed64' x) = putWord8 3 *> put x
put (Shown' x y) = putWord8 4 *> put x *> put y
put (Full' x) = putWord8 5 *> put x
put (Cached' x) = putWord8 6 *> put x
get = getWord8 >>= \case
0 -> return Untyped'
-- "1" case handled at the end
2 -> fmap Hashed32' get
3 -> fmap Hashed64' get
4 -> liftA2 Shown' get get
5 -> fmap Full' get
6 -> fmap Cached' get
n -> case hashed5Split n of
(1, hash) -> return (Hashed5' hash)
_ -> fail ("Invalid TypeInformation (tag: " ++ show (hashed5Split n) ++ ")")
-- | Split a 'Word8' into the last 3 bit (used to tag the constructor) and
-- the first 5 (data payload). Used by the 'Binary' instance of
-- 'TypeInformation'.
hashed5Split :: Word8 -> (Word8, Hash5)
hashed5Split x = let hash = mkHash5 x
tag = getHashed5Tag x
in (tag, hash)
getHashed5Tag :: Word8 -> Word8
getHashed5Tag = (.&. 0x7) -- = 00000111
-- | Extract which 'TypeFormat' was used to create a certain 'TypeInformation'.
--
-- If the type is 'Cached'', then the contained information is assumed
-- well-formed. In the public API, this is safe to do, since only well-typed
-- 'Typed' values can be created in the first place.
getFormat :: TypeInformation -> TypeFormat
getFormat (Untyped' {}) = Untyped
getFormat (Hashed5' {}) = Hashed5
getFormat (Hashed32' {}) = Hashed32
getFormat (Hashed64' {}) = Hashed64
getFormat (Shown' {}) = Shown
getFormat (Full' {}) = Full
getFormat (Cached' bs) = getFormat (decode bs)
-- | A 5-bit hash value.
--
-- Since 'TypeInformation' needs 3 bit to store the sort of the
-- 'TypeInformation', the remaining 5 bit per 'Word8' can be used to store a
-- hash value at no additional space cost. For this reason, it is important that
-- the three rightmost bits of any 'Hashed5' are set to zero, i.e. @('.&.' 7)@
-- is 'id' on the contained 'Word8'.
--
-- This type intentionally doesn't have a 'Binary' instance, since its
-- serialization is part of the 'TypeInformation' 'Binary' instance exclusively.
newtype Hash5 = Hash5 Word8
deriving (Eq, Ord, Show)
-- | Smart constructor for 'Hash5' values. Makes sure the rightmost three bits
-- are not set by applying a bit mask to the input.
mkHash5 :: Integral a => a -> Hash5
mkHash5 x = Hash5 (fromIntegral x .&. 0xF8)
-- = 11111000
-- | A 32-bit hash value.
newtype Hash32 = Hash32 Word32
deriving (Eq, Ord, Show, Generic)
instance Binary Hash32
-- | A 64-bit hash value.
newtype Hash64 = Hash64 Word64
deriving (Eq, Ord, Show, Generic)
instance Binary Hash64
-- | 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 -- Explicitly get both values instead of a (ty,value) tuple
-- in case Binary changes in the future. This ensures caching
-- in 'decodeTyped' can rely on the two values coming in
-- in this particular way.
ty <- get
value <- get
case typecheck (Typed ty value) of
Left err -> fail err -- NB: 'fail' is safe in Get Monad
Right wellTyped -> return wellTyped
put (Typed ty value) = put ty *> put value
-- | Like 'Typed', but the type information is not checked. Useful to read type
-- and value, and do the typechecking externally, as required by the caching
-- of 'Data.Binary.Typed.decodeTyped'. Using 'typecheck'', this can be promoted
-- to a proper 'Typed' value.
data Typed' a = Typed' TypeInformation a
-- | "Typed' \ \"
instance Show a => Show (Typed' a) where
show (Typed' ty x) = printf "Typed' %s (%s)"
(show (getFormat ty))
(show x)
instance (Binary a) => Binary (Typed' a) where
get = liftA2 Typed' get get
put (Typed' ty value) = put ty *> put value
-- | Sometimes it can be beneficial to serialize the type information in
-- advance, so that the maybe costly serialization step does not have to be
-- repeated on every invocation of 'encode'. Preserialization comes at a price
-- though, as the directly contained 'BSL.ByteString' requires its length to
-- be included in the final serialization, yielding a 8-byte overhead for the
-- required 'Data.Int.Int64', and one for the tag of what was serialized
-- (\"shown or full?\").
--
-- This function calculates the serialized version of 'TypeInformation' in
-- cases where the required 9 bytes are negligible (determined by an
-- arbitrary threshold, currently 10*9 bytes).
--
-- Used to make 'Data.Binary.Typed.encodeTyped' more efficient; the source
-- there also makes a good usage example.
preserialize :: TypeInformation -> TypeInformation
preserialize x@(Cached' {}) = x
preserialize x@(Untyped' {}) = x
preserialize x@(Hashed5' {}) = x
preserialize x@(Hashed32' {}) = x
preserialize x@(Hashed64' {}) = x
-- Explicit cases for Shown' and Full' so exhaustiveness can be checked when
-- new constructors are added. (The default pattern of just "x" would do right
-- now as well, but not provide that.)
preserialize x@(Shown' {}) = preserialize' x
preserialize x@(Full' {}) = preserialize' x
-- | Preserializes type information if its encoded byte length is larger than
-- an arbitrary threshold. Less efficient than 'preserialize' since it
-- always preserializes and always calculates the encoded version no matter
-- what.
preserialize' :: TypeInformation -> TypeInformation
preserialize' x | BSL.length encoded > 10*9 = Cached' encoded
| otherwise = x
where encoded = encode x
-- | Different ways of including/verifying type information of serialized
-- messages.
data TypeFormat =
-- | Include no type information.
--
-- * Requires one byte more compared to using 'Binary' directly
-- (to tag the data as untyped, required for the decoding step).
-- * Encoding and decoding require negligible amount of additional
-- computational cost compared to direct (intrinsically untyped)
-- 'Binary'.
Untyped
-- | Like 'Hashed32', but uses a 5-bit hash value.
--
-- * Requires the same amount of space as 'Untyped', i.e. the only
-- overhead compared to it is the computational cost to calculate
-- the hash, which is almost identical to the one of 'Hashed32'.
-- * Collisions occur with a probability of 1\/2^5 = 1\/32. For this
-- reason, this format is only recommended when minimal data size
-- is top priority.
--
| Hashed5
-- | Compare types by their hash values (using the MurmurHash2
-- algorithm).
--
-- * Requires five bytes more compared to using 'Binary' directly for
-- the type information (one to tag as 'Hashed32', four for the
-- hash value)
-- * 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")
-- * Computational cost similar to 'Hashed64'.
| Hashed32
-- | Like 'Hashed32', but uses a 64-bit hash value.
--
-- * Requires nine bytes more compared to using 'Binary'.
-- * Hash collisions are even less likely to occur than with
-- 'Hashed32'.
-- * Computational cost similar to 'Hashed32'.
| Hashed64
-- | Compare 'String' representation of types, obtained by calling
-- 'show' on the 'TypeRep', and also include a hash value
-- (like 'Hashed32'). The former is mostly for readable error
-- messages, the latter provides better collision resistance.
--
-- * Data size larger than 'Hashed32', 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. Remember this when you get a
-- seemingly silly error "expected Foo, but given Foo".
| Shown
-- | Compare the full representation of a data type.
--
-- * More verbose than '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. Remember this when you get a
-- seemingly silly error "expected Foo, but given Foo".
| Full
deriving (Eq, Ord, Show)
-- | Construct a 'Typed' value using the chosen type format.
--
-- Example:
--
-- @
-- value = 'typed' 'Full' ("hello", 1 :: 'Int', 2.34 :: 'Double')
-- encoded = '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 (makeTypeInformation format (typeOf x)) x
-- | Create the 'TypeInformation' to be stored inside a 'Typed' value from
-- a 'Ty.TypeRep'.
makeTypeInformation :: TypeFormat -> Ty.TypeRep -> TypeInformation
makeTypeInformation Untyped _ = Untyped'
makeTypeInformation Hashed5 ty = Hashed5' (hashType5 ty)
makeTypeInformation Hashed32 ty = Hashed32' (hashType32 ty)
makeTypeInformation Hashed64 ty = Hashed64' (hashType64 ty)
makeTypeInformation Shown ty = Shown' (hashType32 ty) (show ty)
makeTypeInformation Full ty = 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)
Hashed5' hash5 | exHash5 /= hash5 -> Left (hashError exHash5 hash5)
Hashed32' hash32 | exHash32 /= hash32 -> Left (hashError exHash32 hash32)
Hashed64' hash64 | exHash64 /= hash64 -> Left (hashError exHash64 hash64)
Shown' hash32 str | (exHash32, exShow) /= (hash32, str)
-> Left (shownError hash32 str)
_no_type_error -> Right ty
where
-- ex = expected
exType = typeOf x
exHash5 = hashType5 exType
exHash32 = hashType32 exType
exHash64 = hashType64 exType
exShow = show exType
exFull = stripTypeRep exType
hashError eHash hash = printf pat exShow (show eHash) (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 exHash32) 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
-- | Typecheck a 'Typed\'' value so it can be used as a safe 'Typed' value.
typecheck' :: Typeable a => Typed' a -> Either String (Typed a)
typecheck' (Typed' ty value) = typecheck (Typed ty value)
-- | Hash a 'Ty.TypeRep' to a 5-bit digest.
hashType5 :: Ty.TypeRep -> Hash5
hashType5 = mkHash5 . H32.asWord32 . H32.hash32 . stripTypeRep
-- | Hash a 'Ty.TypeRep' to a 32-bit digest.
hashType32 :: Ty.TypeRep -> Hash32
hashType32 = Hash32 . H32.asWord32 . H32.hash32 . stripTypeRep
-- | Hash a 'Ty.TypeRep' to a 64-bit digest.
hashType64 :: Ty.TypeRep -> Hash64
hashType64 = Hash64 . H64.asWord64 . H64.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 H32.Hashable32 TypeRep where
hash32Add (TypeRep tycon args) = H32.hash32Add (tycon, args)
instance H64.Hashable64 TypeRep where
hash64Add (TypeRep tycon args) = H64.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 H32.Hashable32 TyCon where
hash32Add (TyCon p m c) = H32.hash32Add (p, m, c)
instance H64.Hashable64 TyCon where
hash64Add (TyCon p m c) = H64.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