store 0.4.3.2 → 0.7.22
raw patch · 19 files changed
Files
- ChangeLog.md +191/−0
- README.md +53/−20
- bench/Bench.hs +0/−5
- src/Data/Store.hs +19/−0
- src/Data/Store/Impl.hs +25/−8
- src/Data/Store/Internal.hs +191/−60
- src/Data/Store/Streaming.hs +0/−223
- src/Data/Store/Streaming/Internal.hs +0/−26
- src/Data/Store/TH.hs +2/−1
- src/Data/Store/TH/Internal.hs +88/−41
- src/Data/Store/TypeHash.hs +1/−4
- src/Data/Store/TypeHash/Internal.hs +6/−2
- src/Data/Store/Version.hs +1/−2
- src/System/IO/ByteBuffer.hs +2/−1
- store.cabal +184/−132
- test/Allocations.hs +7/−0
- test/Data/Store/StreamingSpec.hs +0/−206
- test/Data/Store/UntrustedSpec.hs +186/−0
- test/Data/StoreSpec.hs +187/−57
ChangeLog.md view
@@ -1,8 +1,199 @@ # ChangeLog +## 0.7.22++* Fix test compilation on platforms where libc lacks POSIX `timer_t`+ (e.g. macOS), so `System.Posix.Types.CTimer` is not exported. The test+ guarded `[t| CTimer |]` with `#if MIN_VERSION_base(4,10,0)`, but+ `CTimer`'s availability is platform-dependent (gated on `HTYPE_TIMER_T`+ by base's `configure`), not base-version-dependent. Use `lookupTypeName`+ to detect the symbol at splice time.+ See [#185][].++[#185]: https://github.com/mgsloan/store/pull/185++## 0.7.21++* Fix test compilation on GHC 9.10+, where `template-haskell` types+ (`Type`, `TySynEqn`, `PkgName`, etc.) live in `GHC.Internal.TH.Syntax`+ rather than `Language.Haskell.TH.Syntax`. The `isThName` filter that+ skips TH AST types from the auto-generated `Store` roundtrip enumeration+ was matching only the old module name and silently let the TH types+ through, causing `No instance for 'Serial IO Type'` style errors.+ See [#182][].++[#182]: https://github.com/mgsloan/store/issues/182++## 0.7.20++* Fixes build of test with `vector-0.13.2.0`. See [#181][].++[#181]: https://github.com/mgsloan/store/issues/181++## 0.7.19++* Adds support for `vector-0.13.2.0`. See [#179][].++[#174]: https://github.com/mgsloan/store/issues/179++## 0.7.16++* Adds support for `vector-0.13.0.0`. See [#174][].++[#174]: https://github.com/mgsloan/store/issues/174+++## 0.7.15++* Adds support for `text >= 2`. See [#170][].++[#170]: https://github.com/mgsloan/store/issues/170+++## 0.7.14++* Fixes build with ghc-8.10 (broken in last release due to differences+ in TH API). See [#165][].++[#165]: https://github.com/mgsloan/store/issues/165+++## 0.7.13++* Fix build with `time >= 1.11`. See [#162][].++* Adds missing `liftTyped` method for `Lift TypeHash`. See [#163][].++[#162]: https://github.com/mgsloan/store/issues/162+[#163]: https://github.com/mgsloan/store/issues/163++## 0.7.12++* Build with ghc-9.0.1++## 0.7.11++* Fixes testsuite compilation with `network >= 3.1.2`. See [#159][].++## 0.7.10++* Adds `Store` instances for all serializable datatypes exported by+ the `time` library. See [#158][].++[#158]: https://github.com/mgsloan/store/issues/158++## 0.7.9++* Attempts to fix build on ghc-7.8.4. See [#157][].++[#157]: https://github.com/mgsloan/store/issues/157++## 0.7.8++* Adds a `Store` instance for `Natural`. See [#154][].++[#154]: https://github.com/mgsloan/store/issues/154++## 0.7.7++* Test now compiles with `smallcheck >= 1.2` and `base >= 4.14`.+ See [#153][].++[#153]: https://github.com/fpco/store/issues/153++## 0.7.6++* Now only depends on `fail` / `semigroups` shim for `ghc < 8`.++## 0.7.4++* Fix for compilation with `ghc-8.10` in `0.7.3` did not use enough+ CPP, and so broke builds for older versions. This release fixes+ that.++## 0.7.3++* Fixes compilation with `ghc-8.10`, particularly+ `template-haskell-2.16.0.0`. See [#149][].++[#149]: https://github.com/fpco/store/issues/149++## 0.7.2++* Fixes compilation with `vector >= 0.12.1.1` by making+ `deriveManyStoreUnboxVector` capable of handling more complex+ instance constraints. In particular, it now correctly generates+ instances `Store (Vector (f (g a))) => Store (Vector (Compose f g+ a))` and `Store (Vector (f a)) => Store (Vector (Alt f a))`.++## 0.7.1++* Fixes compilation with GHC-7.10 due to it not defining `Generic`+ instances for `Complex` and `Identity`. See [#142][].++* Documents some gotchas about using store vs other libraries++[#142]: https://github.com/fpco/store/issues/142++## 0.7.0++* Fixes a bug where the `Store` instances for `Identity`, `Const`, and+ `Complex` all have `Storable` superclasses instead of `Store. See+ [#143][].++[#143]: https://github.com/fpco/store/issues/143++## 0.6.1++* Can now optionally be built with `integer-simple` instead of+ `integer-gmp`, via the `integer-simple` cabal flag. Note that the+ serialization of `Integer` with `integer-simple` differs from what+ is used by the GMP default. See [#147][].++[#147]: https://github.com/fpco/store/pull/147++## 0.6.0.1++* Now builds with GHC-7.10 - compatibility was broken in 0.6.0 due to+ the fix for GHC-8.8. See+ [#146][https://github.com/fpco/store/issues/146].++## 0.6.0++* Now builds with GHC-8.8. This is a major version bump because+ MonadFail constraints were added to some functions, which is+ potentially a breaking change.++## 0.5.1.2++* Fixes compilation with GHC < 8.0. See+ [#142](https://github.com/fpco/store/issues/142).++## 0.5.1.1++* Update to the instances for generics, to improve error messages for+ sum types with more than 255 constructors. See+ [#141](https://github.com/fpco/store/issues/141)++## 0.5.1.0++* Update to TH to support sum types with more than 62 constructors.++* Uses TH to derive Either instance, so that it can sometimes have ConstSize #119.++## 0.5.0.1++* Updates to test-suite enabling `store` to build with newer dependencies.++## 0.5.0++* `Data.Store.Streaming` moved to a separate package, `store-streaming`.+ ## 0.4.3.2 * Buildable with GHC 8.2++* Fix to haddock formatting of Data.Store.TH code example ## 0.4.3.1
README.md view
@@ -1,37 +1,70 @@ # store -The 'store' package provides efficient binary serialization. There are a couple-features that particularly distinguish it from most prior Haskell serialization-libraries:+The 'store' package provides efficient binary serialization. There are+a couple features that particularly distinguish it from most prior+Haskell serialization libraries: -* Its primary goal is speed. By default, direct machine representations are used- for things like numeric values (`Int`, `Double`, `Word32`, etc) and buffers- (`Text`, `ByteString`, `Vector`, etc). This means that much of serialization- uses the equivalent of `memcpy`.+* Its primary goal is speed. By default, direct machine+ representations are used for things like numeric values (`Int`,+ `Double`, `Word32`, etc) and buffers (`Text`, `ByteString`,+ `Vector`, etc). This means that much of serialization uses the+ equivalent of `memcpy`. - We have plans for supporting architecture independent serialization - see- [#36](https://github.com/fpco/store/issues/36) and- [#31](https://github.com/fpco/store/issues/31). This plan makes little endian- the default, so that the most common endianness has no overhead.+ We have plans for supporting architecture independent+ serialization - see [#36](https://github.com/fpco/store/issues/36)+ and [#31](https://github.com/fpco/store/issues/31). This plan makes+ little endian the default, so that the most common endianness has no+ overhead. -* Instead of implementing lazy serialization / deserialization involving- multiple input / output buffers, `peek` and `poke` always work with a single- buffer. This buffer is allocated by asking the value for its size before- encoding. This simplifies the encoding logic, and allows for highly optimized- tight loops.+ - Another way that the serialization behavior can vary is if+ integer-simple is used instead of GHC's default of using+ GMP. `Integer` serialized with the `integer-simple` flag enabled+ are not compatible with those serialized without the flag enabled. -* `store` can optimize size computations by knowing when some types always- use the same number of bytes. This allows us to compute the byte size of a- `Vector Int32` by just doing `length v * 4`.+* Instead of implementing lazy serialization / deserialization+ involving multiple input / output buffers, `peek` and `poke` always+ work with a single buffer. This buffer is allocated by asking the+ value for its size before encoding. This simplifies the encoding+ logic, and allows for highly optimized tight loops. +* `store` can optimize size computations by knowing when some types+ always use the same number of bytes. This allows us to compute the+ byte size of a `Vector Int32` by just doing `length v * 4`.+ It also features: * Optimized serialization instances for many types from base, vector, bytestring, text, containers, time, template-haskell, and more. -* TH and GHC Generics based generation of Store instances for datatypes+* TH and GHC Generics based generation of Store instances for+ datatypes. * TH generation of testcases.++* Utilities for streaming encoding / decoding of Store encoded+ messages, via the `store-streaming` package.++## Gotchas++Store is best used for communication between trusted processes and+local caches. It can certainly be used for other purposes, but the+builtin set of instances have some gotchas to be aware of:++* Store's builtin instances serialize in a format which depends on+ machine endianness.++* Store's builtin instances trust the data when deserializing. For+ example, the deserialization of `Vector` will read the vector's+ length from the first 8 bytes. It will then allocate enough memory+ to store all the elements. Malicious or malformed input could cause+ allocation of large amounts of memory. See [issue #122][].++* Serialization may vary based on the version of datatypes. For+ example, `Text` serialized from `text < 2` will not be compatible+ with `Text` from `text >= 2`, because the internal representation+ switched from UTF-16 to UTF-8.++[issue #122]: https://github.com/fpco/store/issues/122 ## Blog posts
bench/Bench.hs view
@@ -24,7 +24,6 @@ import Data.Word import GHC.Generics --- TODO: add packer #if COMPARISON_BENCH import qualified Data.Binary as Binary import qualified Data.Serialize as Cereal@@ -160,8 +159,6 @@ benchDecode :: Ctx a => a -> Benchmark benchDecode = benchDecode' "" --- TODO: comparison bench for decode- benchDecode' :: forall a. Ctx a => String -> a -> Benchmark #if COMPARISON_BENCH benchDecode' prefix x0 =@@ -234,8 +231,6 @@ poke (SSM2 x) = poke (1 :: Word8) >> poke x poke (SSM3 x) = poke (2 :: Word8) >> poke x poke (SSM4 x) = poke (3 :: Word8) >> poke x---- TODO: add TH generation of the above, and add LargeSum / LargeProduct cases #if COMPARISON_BENCH instance Binary.Binary SmallProduct
src/Data/Store.hs view
@@ -7,6 +7,25 @@ -- There are some tradeoffs here - the generics instances do not require -- @-XTemplateHaskell@, but they do not optimize as well for sum types -- that only require a constant number of bytes.+--+-- If you need streaming encode / decode of multiple store encoded+-- messages, take a look at the @store-streaming@ package.+--+-- = Gotchas+--+-- Store is best used for communication between trusted processes and+-- local caches. It can certainly be used for other purposes, but the+-- builtin set of instances have some gotchas to be aware of:+--+-- * Store's builtin instances serialize in a format which depends on+-- machine endianness.+--+-- * Store's builtin instances trust the data when deserializing. For+-- example, the deserialization of `Vector` will read the vector's+-- link from the first 8 bytes. It will then allocate enough memory+-- to store all the elements. Malicious or malformed input could+-- cause allocation of large amounts of memory. See+-- https://github.com/fpco/store/issues/122 module Data.Store ( -- * Encoding and decoding strict ByteStrings.
src/Data/Store/Impl.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -28,6 +30,7 @@ import Data.Typeable (Typeable, typeRep) import Data.Word import Foreign.Storable (Storable, sizeOf)+import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits import Prelude@@ -36,8 +39,6 @@ ------------------------------------------------------------------------ -- Store class --- TODO: write down more elaborate laws- -- | The 'Store' typeclass provides efficient serialization and -- deserialization to raw pointer addresses. --@@ -259,23 +260,39 @@ -- The machinery for sum types is why UndecidableInstances is necessary. --- FIXME: check that this type level stuff dosen't get turned into--- costly runtime computation--instance (SumArity (a :+: b) <= 255, GStoreSizeSum 0 (a :+: b))+instance (FitsInByte (SumArity (a :+: b)), GStoreSizeSum 0 (a :+: b)) => GStoreSize (a :+: b) where gsize = VarSize $ \x -> sizeOf (undefined :: Word8) + gsizeSum x (Proxy :: Proxy 0) {-# INLINE gsize #-}-instance (SumArity (a :+: b) <= 255, GStorePokeSum 0 (a :+: b))+instance (FitsInByte (SumArity (a :+: b)), GStorePokeSum 0 (a :+: b)) => GStorePoke (a :+: b) where gpoke x = gpokeSum x (Proxy :: Proxy 0) {-# INLINE gpoke #-}-instance (SumArity (a :+: b) <= 255, GStorePeekSum 0 (a :+: b))+instance (FitsInByte (SumArity (a :+: b)), GStorePeekSum 0 (a :+: b)) => GStorePeek (a :+: b) where gpeek = do tag <- peekStorable gpeekSum tag (Proxy :: Proxy 0) {-# INLINE gpeek #-}++-- See https://github.com/fpco/store/issues/141 - this constraint type+-- family machinery improves error messages for generic deriving on+-- sum types with many constructors.++type FitsInByte n = FitsInByteResult (n <=? 255)++type family FitsInByteResult (b :: Bool) :: Constraint where+ FitsInByteResult 'True = ()+ FitsInByteResult 'False = TypeErrorMessage+ "Generic deriving of Store instances can only be used on datatypes with fewer than 256 constructors."++type family TypeErrorMessage (a :: Symbol) :: Constraint where+#if MIN_VERSION_base(4,9,0)+ TypeErrorMessage a = TypeError ('Text a)+-- GHC < 8.0 does not support empty closed type families+#elif __GLASGOW_HASKELL__ < 800+ TypeErrorMessage a = a ~ ""+#endif -- Similarly to splitting up the generic class into multiple classes, we -- also split up the one for sum types.
src/Data/Store/Internal.hs view
@@ -4,13 +4,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes#-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -76,13 +79,16 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short.Internal as SBS import Data.Containers (IsMap, ContainerKey, MapValue, mapFromList, mapToList, IsSet, setFromList)+import Data.Complex (Complex (..)) import Data.Data (Data) import Data.Fixed (Fixed (..), Pico) import Data.Foldable (forM_, foldl') import Data.Functor.Contravariant+import Data.Functor.Identity (Identity (..)) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Hashable (Hashable)+import Data.Int import Data.IntMap (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet)@@ -107,35 +113,71 @@ import qualified Data.Text.Foreign as T import qualified Data.Text.Internal as T import qualified Data.Time as Time+import qualified Data.Time.Clock.TAI as Time import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as MSV+import qualified Data.Vector.Unboxed as UV+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as SCV+import qualified Data.Vector.Strict.Mutable as MSCV+#endif import Data.Void import Data.Word import Foreign.C.Types () import Foreign.Ptr (plusPtr, minusPtr) import Foreign.Storable (Storable, sizeOf) import GHC.Generics (Generic)-import qualified GHC.Integer.GMP.Internals as I import GHC.Real (Ratio(..)) import GHC.TypeLits-import GHC.Types (Int (I#)) import Instances.TH.Lift () import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.ReifyMany import Language.Haskell.TH.Syntax import Network.Socket (AddrInfo)+import Numeric.Natural (Natural) import Prelude import TH.Derive +#if MIN_VERSION_time(1,8,0)+import qualified Data.Time.Clock.System as Time+#endif+#if MIN_VERSION_time(1,9,0)+import qualified Data.Time.Format.ISO8601 as Time+#endif+#if MIN_VERSION_time(1,11,0)+import qualified Data.Time.Calendar.Quarter as Time+import qualified Data.Time.Calendar.WeekDate as Time+#endif++#ifdef INTEGER_GMP+import qualified GHC.Integer.GMP.Internals as I+import GHC.Types (Int (I#))+#else+import GHC.Types (Word (W#))+import qualified GHC.Integer.Simple.Internals as I+#endif+ -- Conditional import to avoid warning+#ifdef INTEGER_GMP #if MIN_VERSION_integer_gmp(1,0,0) import GHC.Prim (sizeofByteArray#) #endif+#endif +-- TODO: higher arities? Limited now by Generics instances for tuples+$(return $ map deriveTupleStoreInstance [2..7])++$(deriveManyStoreFromStorable+ (\ty ->+ case ty of+ ConT n | elem n [''Char, ''Int, ''Int64, ''Word, ''Word8, ''Word32] -> True+ _ -> False+ ))+ ------------------------------------------------------------------------ -- Utilities for defining list-like 'Store' instances in terms of 'IsSequence' @@ -291,26 +333,7 @@ f <$> peek {-# INLINE peekOrdMapWith #-} -{- --------------------------------------------------------------------------- Utilities for defining list-like 'Store' instances in terms of Foldable---- | Implement 'size' for a 'Foldable' of 'Store' instances. Note that--- this assumes the extra 'Foldable' structure is discardable - this--- only serializes the elements.-sizeListLikeFoldable :: forall t a. (Foldable t, Store a) => Size (t a)-sizeListLikeFoldable = VarSize $ \t ->- case size :: Size e of- ConstSize n -> n * length x + sizeOf (undefined :: Int)- VarSize f -> foldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int))-{-# INLINE sizeSequence #-}--pokeListLikeFoldable :: forall t a. Foldable t => t a -> Poke ()-pokeListLikeFoldable x = do- poke (length x)--}-------------------------------------------------------------------------- -- Utilities for implementing 'Store' instances for list-like mutable things -- | Implementation of peek for mutable sequences. The user provides a@@ -364,6 +387,13 @@ poke = pokeSequence peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write +#if MIN_VERSION_vector(0,13,2)+instance Store a => Store (SCV.Vector a) where+ size = sizeSequence+ poke = pokeSequence+ peek = SCV.unsafeFreeze =<< peekMutableSequence MSCV.new MSCV.write+#endif+ instance Storable a => Store (SV.Vector a) where size = VarSize $ \x -> sizeOf (undefined :: Int) +@@ -390,6 +420,22 @@ fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" len return (BS.PS fp 0 len) +#if MIN_VERSION_template_haskell(2,16,0)+-- | Template Haskell Bytes are nearly identical to ByteString, but it+-- can't depend on ByteString.+instance Store Bytes where+ size = VarSize $ \x ->+ sizeOf (undefined :: Int) ++ fromIntegral (bytesSize x)+ poke (Bytes sourceFp sourceOffset sourceLength) = do+ poke sourceLength+ pokeFromForeignPtr sourceFp (fromIntegral sourceOffset) (fromIntegral sourceLength)+ peek = do+ len <- peek+ fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" (fromIntegral len)+ return (Bytes fp 0 len)+#endif+ instance Store SBS.ShortByteString where size = VarSize $ \x -> sizeOf (undefined :: Int) +@@ -404,20 +450,29 @@ return (SBS.SBS array) instance Store LBS.ByteString where- -- FIXME: faster conversion? Is this ever going to be a problem?- --- -- I think on 64 bit systems, Int will have 64 bits. On 32 bit- -- systems, we'll never exceed the range of Int by this conversion. size = VarSize $ \x -> sizeOf (undefined :: Int) + fromIntegral (LBS.length x)- -- FIXME: more efficient implementation that avoids the double copy+ -- TODO: more efficient implementation that avoids the double copy poke = poke . LBS.toStrict peek = fmap LBS.fromStrict peek instance Store T.Text where+#if MIN_VERSION_text(2,0,0) size = VarSize $ \x -> sizeOf (undefined :: Int) ++ T.lengthWord8 x+ poke x = do+ let !(T.Text (TA.ByteArray array) w8Off w8Len) = x+ poke w8Len+ pokeFromByteArray array w8Off w8Len+ peek = do+ w8Len <- peek+ ByteArray array <- peekToByteArray "Data.Text.Text" w8Len+ return (T.Text (TA.ByteArray array) 0 w8Len)+#else+ size = VarSize $ \x ->+ sizeOf (undefined :: Int) + 2 * (T.lengthWord16 x) poke x = do let !(T.Text (TA.Array array) w16Off w16Len) = x@@ -427,13 +482,11 @@ w16Len <- peek ByteArray array <- peekToByteArray "Data.Text.Text" (2 * w16Len) return (T.Text (TA.Array array) 0 w16Len)+#endif ------------------------------------------------------------------------ -- Known size instances --- TODO: this doesn't scale nicely to 'Text'. Force it to be byte size?--- 'StaticByteSize'?- newtype StaticSize (n :: Nat) a = StaticSize { unStaticSize :: a } deriving (Eq, Show, Ord, Data, Typeable, Generic) @@ -456,7 +509,6 @@ instance KnownNat n => Store (StaticSize n BS.ByteString) where size = ConstSize (fromInteger (natVal (Proxy :: Proxy n))) poke (StaticSize x) = do- -- TODO: worth it to put an assert here? let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x pokeFromForeignPtr sourceFp sourceOffset sourceLength peek = do@@ -472,7 +524,11 @@ let numTy = litT $ numTyLit $ natVal (Proxy :: Proxy n) [| StaticSize $(lift x) :: StaticSize $(numTy) $(tyq) |] +#if MIN_VERSION_template_haskell(2,17,0)+staticByteStringExp :: Quote m => BS.ByteString -> m Exp+#else staticByteStringExp :: BS.ByteString -> ExpQ+#endif staticByteStringExp bs = [| StaticSize bs :: StaticSize $(litT (numTyLit (fromIntegral len))) BS.ByteString |] where@@ -538,13 +594,11 @@ peek = peekSet instance (A.Ix i, Store i, Store e) => Store (A.Array i e) where- -- TODO: Speed up poke and peek size = sizeArray poke = pokeArray peek = peekArray instance (A.Ix i, A.IArray A.UArray e, Store i, Store e) => Store (A.UArray i e) where- -- TODO: Speed up poke and peek size = sizeArray poke = pokeArray peek = peekArray@@ -573,6 +627,7 @@ {-# INLINE peekArray #-} instance Store Integer where+#ifdef INTEGER_GMP #if MIN_VERSION_integer_gmp(1,0,0) size = VarSize $ \ x -> sizeOf (undefined :: Word8) + case x of@@ -640,15 +695,62 @@ when (r /= 0) (peekException "Buffer size stored for encoded Integer not divisible by Word size (to get limb count).") return (I.J# sz arr) #endif+#else+ -- NOTE: integer-simple uses a different encoding than GMP+ size = VarSize $ \ x ->+ sizeOf (undefined :: Word8) + case x of+ I.Positive ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word)+ I.Negative ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word)+ I.Naught -> 0+ where+ poke x = case x of+ I.Naught -> poke (0 :: Word8)+ I.Positive ds -> do+ poke (1 :: Word8)+ poke (numDigits ds)+ pokeDigits ds+ I.Negative ds -> do+ poke (2 :: Word8)+ poke (numDigits ds)+ pokeDigits ds+ where+ pokeDigits I.None = pure ()+ pokeDigits (I.Some d ds) = poke (W# d) *> pokeDigits ds+ peek = do+ tag <- peek :: Peek Word8+ case tag of+ 0 -> pure I.Naught+ 1 -> do+ len <- peek :: Peek Word+ I.Positive <$> peekDigits len+ 2 -> do+ len <- peek :: Peek Word+ I.Negative <$> peekDigits len+ _ -> peekException "Invalid Integer tag"+ where+ peekDigits i+ | i <= 0 = pure I.None+ | otherwise = do+ W# d <- peek+ ds <- peekDigits (i - 1)+ pure $! I.Some d ds --- instance Store GHC.Fingerprint.Types.Fingerprint where+numDigits :: I.Digits -> Word+numDigits = go 0+ where go !acc I.None = acc+ go !acc (I.Some _ ds) = go (acc + 1) ds+#endif -instance Store (Fixed a) where- size = contramap (\(MkFixed x) -> x) (size :: Size Integer)- poke (MkFixed x) = poke x- peek = MkFixed <$> peek+-- Piggybacks off of the Integer instance --- instance Store a => Store (Tree a) where+instance Store Natural where+ size = contramap fromIntegral (size :: Size Integer)+ poke = poke . toInteger+ peek = do+ x <- peek :: Peek Integer+ if x < 0+ then peekException "Encountered negative integer when expecting a Natural"+ else return $ fromIntegral x ------------------------------------------------------------------------ -- Other instances@@ -666,20 +768,20 @@ poke (x :% y) = poke (x, y) peek = uncurry (:%) <$> peek -instance Store Time.Day where- size = contramap Time.toModifiedJulianDay (size :: Size Integer)- poke = poke . Time.toModifiedJulianDay- peek = Time.ModifiedJulianDay <$> peek+-- Similarly, manual implementation due to no Generic instance for+-- Complex and Identity in GHC-7.10 and earlier. +$($(derive [d| instance Deriving (Store (Fixed a)) |]))+ instance Store Time.DiffTime where- size = contramap (realToFrac :: Time.DiffTime -> Pico) (size :: Size Pico)- poke = (poke :: Pico -> Poke ()) . realToFrac- peek = Time.picosecondsToDiffTime <$> peek+ size = contramap (realToFrac :: Time.DiffTime -> Pico) size+ poke = poke . (realToFrac :: Time.DiffTime -> Pico)+ peek = (realToFrac :: Pico -> Time.DiffTime) <$> peek -instance Store Time.UTCTime where- size = combineSize Time.utctDay Time.utctDayTime- poke (Time.UTCTime day time) = poke (day, time)- peek = uncurry Time.UTCTime <$> peek+instance Store Time.NominalDiffTime where+ size = contramap (realToFrac :: Time.NominalDiffTime -> Pico) size+ poke = poke . (realToFrac :: Time.NominalDiffTime -> Pico)+ peek = (realToFrac :: Pico -> Time.NominalDiffTime) <$> peek instance Store () instance Store a => Store (Dual a)@@ -688,24 +790,57 @@ instance Store a => Store (First a) instance Store a => Store (Last a) instance Store a => Store (Maybe a)-instance (Store a, Store b) => Store (Either a b)+instance Store a => Store (Const a b) --- FIXME: have TH deriving handle unboxed fields?+#if MIN_VERSION_vector(0,13,2)+deriving newtype instance Store a => Store (UV.DoNotUnboxLazy a)+deriving newtype instance Store a => Store (UV.DoNotUnboxStrict a)+deriving newtype instance Store a => Store (UV.DoNotUnboxNormalForm a)+#endif ------------------------------------------------------------------------ -- Instances generated by TH $($(derive [d|- -- TODO- -- instance Deriving (Store ())+ instance Store a => Deriving (Store (Complex a))+ instance Store a => Deriving (Store (Identity a))+ instance Deriving (Store All) instance Deriving (Store Any) instance Deriving (Store Void) instance Deriving (Store Bool)+ instance (Store a, Store b) => Deriving (Store (Either a b))++ instance Deriving (Store Time.AbsoluteTime)+ instance Deriving (Store Time.Day)+ instance Deriving (Store Time.LocalTime)+ instance Deriving (Store Time.TimeOfDay)+ instance Deriving (Store Time.TimeZone)+ instance Deriving (Store Time.UTCTime)+ instance Deriving (Store Time.UniversalTime)+ instance Deriving (Store Time.ZonedTime)+ instance Deriving (Store Time.TimeLocale)++#if MIN_VERSION_time(1,8,0)+ instance Deriving (Store Time.SystemTime)+#endif++#if MIN_VERSION_time(1,9,0)+ instance Deriving (Store Time.CalendarDiffDays)+ instance Deriving (Store Time.CalendarDiffTime)+ instance Deriving (Store Time.FormatExtension)+#endif++#if MIN_VERSION_time(1,11,0)+ instance Deriving (Store Time.DayOfWeek)+ instance Deriving (Store Time.FirstWeekType)+ instance Deriving (Store Time.Quarter)+ instance Deriving (Store Time.QuarterOfYear)+#endif+ |])) --- TODO: higher arities? Limited now by Generics instances for tuples-$(return $ map deriveTupleStoreInstance [2..7])+$(deriveManyStorePrimVector) $(deriveManyStoreUnboxVector) @@ -732,10 +867,7 @@ _ -> True )) -$(deriveManyStorePrimVector)- $(reifyManyWithoutInstances ''Store [''ModName, ''NameSpace, ''PkgName] (const True) >>=--- mapM (\name -> deriveStore [] (ConT name) .dtCons =<< reifyDataType name)) mapM (\name -> return (deriveGenericInstance [] (ConT name)))) -- Explicit definition needed because in template-haskell <= 2.9 (GHC@@ -780,5 +912,4 @@ #endif $(reifyManyWithoutInstances ''Store [''Info] (const True) >>=--- mapM (\name -> deriveStore [] (ConT name) .dtCons =<< reifyDataType name))- mapM (\name -> return (deriveGenericInstance [] (ConT name))))+ mapM deriveGenericInstanceFromName)
− src/Data/Store/Streaming.hs
@@ -1,223 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-|-Module: Data.Store.Streaming-Description: A thin streaming layer that uses 'Store' for serialisation.--For efficiency reasons, 'Store' does not provide facilities for-incrementally consuming input. In order to avoid partial input, this-module introduces 'Message's that wrap values of instances of 'Store'.--In addition to the serialisation of a value, the serialised message-also contains the length of the serialisation. This way, instead of-consuming input incrementally, more input can be demanded before-serialisation is attempted in the first place.--Each message starts with a fixed magic number, in order to detect-(randomly) invalid data.---}-module Data.Store.Streaming- ( -- * 'Message's to stream data using 'Store' for serialisation.- Message (..)- -- * Encoding 'Message's- , encodeMessage- -- * Decoding 'Message's- , PeekMessage- , FillByteBuffer- , peekMessage- , decodeMessage- , peekMessageBS- , decodeMessageBS-#ifndef mingw32_HOST_OS- , ReadMoreData(..)- , peekMessageFd- , decodeMessageFd-#endif- -- * Conduits for encoding and decoding- , conduitEncode- , conduitDecode- ) where--import Control.Exception (throwIO)-import Control.Monad (unless)-import Control.Monad.IO.Class-import Control.Monad.Trans.Resource (MonadResource)-import Data.ByteString (ByteString)-import qualified Data.Conduit as C-import qualified Data.Conduit.List as C-import Data.Store-import Data.Store.Impl (getSize)-import Data.Store.Core (decodeIOWithFromPtr, unsafeEncodeWith)-import qualified Data.Text as T-import Data.Word-import Foreign.Ptr-import Prelude-import System.IO.ByteBuffer (ByteBuffer)-import qualified System.IO.ByteBuffer as BB-import Control.Monad.Trans.Free.Church (FT, iterTM, wrap)-import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)-import Control.Monad.Trans.Class (lift)-import System.Posix.Types (Fd(..))-import GHC.Conc (threadWaitRead)-import Data.Store.Streaming.Internal---- | If @a@ is an instance of 'Store', @Message a@ can be serialised--- and deserialised in a streaming fashion.-newtype Message a = Message { fromMessage :: a } deriving (Eq, Show)---- | Encode a 'Message' to a 'ByteString'.-encodeMessage :: Store a => Message a -> ByteString-encodeMessage (Message x) =- unsafeEncodeWith pokeFunc totalLength- where- bodyLength = getSize x- totalLength = headerLength + bodyLength- pokeFunc = do- poke messageMagic- poke bodyLength- poke x---- | The result of peeking at the next message can either be a--- successfully deserialised object, or a request for more input.-type PeekMessage i m a = FT ((->) i) m a--needMoreInput :: PeekMessage i m i-needMoreInput = wrap return---- | Given some sort of input, fills the 'ByteBuffer' with it.------ The 'Int' is how many bytes we'd like: this is useful when the filling--- function is 'fillFromFd', where we can specify a max size.-type FillByteBuffer i m = ByteBuffer -> Int -> i -> m ()---- | Decode a value, given a 'Ptr' and the number of bytes that make--- up the encoded message.-decodeFromPtr :: (MonadIO m, Store a) => Ptr Word8 -> Int -> m a-decodeFromPtr ptr n = liftIO $ decodeIOWithFromPtr peek ptr n--peekSized :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> Int -> PeekMessage i m a-peekSized fill bb n = go- where- go = do- mbPtr <- BB.unsafeConsume bb n- case mbPtr of- Left needed -> do- inp <- needMoreInput- lift (fill bb needed inp)- go- Right ptr -> decodeFromPtr ptr n---- | Read and check the magic number from a 'ByteBuffer'-peekMessageMagic :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m ()-peekMessageMagic fill bb =- peekSized fill bb magicLength >>= \case- mm | mm == messageMagic -> return ()- mm -> liftIO . throwIO $ PeekException 0 . T.pack $- "Wrong message magic, " ++ show mm---- | Decode a 'SizeTag' from a 'ByteBuffer'.-peekMessageSizeTag :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m SizeTag-peekMessageSizeTag fill bb = peekSized fill bb sizeTagLength---- | Decode some object from a 'ByteBuffer', by first reading its--- header, and then the actual data.-peekMessage :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m (Message a)-peekMessage fill bb =- fmap Message $ do- peekMessageMagic fill bb- peekMessageSizeTag fill bb >>= peekSized fill bb---- | Decode a 'Message' from a 'ByteBuffer' and an action that can get--- additional inputs to refill the buffer when necessary.------ The only conditions under which this function will give 'Nothing',--- is when the 'ByteBuffer' contains zero bytes, and refilling yields--- 'Nothing'. If there is some data available, but not enough to--- decode the whole 'Message', a 'PeekException' will be thrown.-decodeMessage :: (Store a, MonadIO m) => FillByteBuffer i m -> ByteBuffer -> m (Maybe i) -> m (Maybe (Message a))-decodeMessage fill bb getInp =- maybeDecode (peekMessageMagic fill bb) >>= \case- Just () -> maybeDecode (peekMessageSizeTag fill bb >>= peekSized fill bb) >>= \case- Just x -> return (Just (Message x))- Nothing -> do- -- We have already read the message magic, so a failure to- -- read the whole message means we have an incomplete message.- available <- BB.availableBytes bb- liftIO $ throwIO $ PeekException available $ T.pack- "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message"- Nothing -> do- available <- BB.availableBytes bb- -- At this point, we have not consumed anything yet, so if bb is- -- empty, there simply was no message to read.- unless (available == 0) $ liftIO $ throwIO $ PeekException available $ T.pack- "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message"- return Nothing- where- maybeDecode m = runMaybeT (iterTM (\consumeInp -> consumeInp =<< MaybeT getInp) m)---- | Decode some 'Message' from a 'ByteBuffer', by first reading its--- header, and then the actual 'Message'.-peekMessageBS :: (MonadIO m, Store a) => ByteBuffer -> PeekMessage ByteString m (Message a)-peekMessageBS = peekMessage (\bb _ bs -> BB.copyByteString bb bs)--decodeMessageBS :: (MonadIO m, Store a)- => ByteBuffer -> m (Maybe ByteString) -> m (Maybe (Message a))-decodeMessageBS = decodeMessage (\bb _ bs -> BB.copyByteString bb bs)--#ifndef mingw32_HOST_OS---- | We use this type as a more descriptive unit to signal that more input--- should be read from the Fd.------ This data-type is only available on POSIX systems (essentially, non-windows)-data ReadMoreData = ReadMoreData- deriving (Eq, Show)---- | Peeks a message from a _non blocking_ 'Fd'.------ This function is only available on POSIX systems (essentially, non-windows)-peekMessageFd :: (MonadIO m, Store a) => ByteBuffer -> Fd -> PeekMessage ReadMoreData m (Message a)-peekMessageFd bb fd =- peekMessage (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb---- | Decodes all the message using 'registerFd' to find out when a 'Socket' is--- ready for reading.------ This function is only available on POSIX systems (essentially, non-windows)-decodeMessageFd :: (MonadIO m, Store a) => ByteBuffer -> Fd -> m (Message a)-decodeMessageFd bb fd = do- mbMsg <- decodeMessage- (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb- (liftIO (threadWaitRead fd) >> return (Just ReadMoreData))- case mbMsg of- Just msg -> return msg- Nothing -> liftIO (fail "decodeMessageFd: impossible: got Nothing")--#endif---- | Conduit for encoding 'Message's to 'ByteString's.-conduitEncode :: (Monad m, Store a) => C.Conduit (Message a) m ByteString-conduitEncode = C.map encodeMessage---- | Conduit for decoding 'Message's from 'ByteString's.-conduitDecode :: (MonadResource m, Store a)- => Maybe Int- -- ^ Initial length of the 'ByteBuffer' used for- -- buffering the incoming 'ByteString's. If 'Nothing',- -- use the default value of 4MB.- -> C.Conduit ByteString m (Message a)-conduitDecode bufSize =- C.bracketP- (BB.new bufSize)- BB.free- go- where- go buffer = do- mmessage <- decodeMessageBS buffer C.await- case mmessage of- Nothing -> return ()- Just message -> C.yield message >> go buffer
− src/Data/Store/Streaming/Internal.hs
@@ -1,26 +0,0 @@-module Data.Store.Streaming.Internal- ( messageMagic- , magicLength- , sizeTagLength- , headerLength- , SizeTag- ) where--import Data.Word (Word64)-import qualified Foreign.Storable as Storable---- | Type used to store the length of a 'Message'.-type SizeTag = Int---- | Some fixed arbitrary magic number that precedes every 'Message'.-messageMagic :: Word64-messageMagic = 18205256374652458875--magicLength :: Int-magicLength = Storable.sizeOf messageMagic--sizeTagLength :: Int-sizeTagLength = Storable.sizeOf (undefined :: SizeTag)--headerLength :: Int-headerLength = sizeTagLength + magicLength
src/Data/Store/TH.hs view
@@ -37,6 +37,7 @@ , assertRoundtrip ) where +import qualified Control.Monad.Fail as Fail import Data.Complex () import Data.Store.Impl import Data.Typeable (Typeable, typeOf)@@ -60,7 +61,7 @@ expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |] return ("Roundtrips (" ++ pprint ty ++ ")", expr) -assertRoundtrip :: (Eq a, Show a, Store a, Monad m, Typeable a) => Bool -> a -> m ()+assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m () assertRoundtrip verbose x | checkRoundtrip verbose x = return () | otherwise = fail $ "Failed to roundtrip " ++ show (typeOf x)
src/Data/Store/TH/Internal.hs view
@@ -13,6 +13,7 @@ deriveManyStoreFromStorable , deriveTupleStoreInstance , deriveGenericInstance+ , deriveGenericInstanceFromName , deriveManyStorePrimVector , deriveManyStoreUnboxVector , deriveStore@@ -24,11 +25,11 @@ import Control.Applicative import Data.Complex ()-import Data.Generics.Aliases (extT)-import Data.Generics.Schemes (listify, everywhere)-import Data.List (find, nub)+import Data.Generics.Aliases (extT, mkQ, extQ)+import Data.Generics.Schemes (listify, everywhere, something)+import Data.List (find) import qualified Data.Map as M-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Primitive.ByteArray import Data.Primitive.Types import Data.Store.Core@@ -103,9 +104,16 @@ sizeNames = zipWith (\_ -> mkName . ("sz" ++) . show) cons ints tagName = mkName "tag" valName = mkName "val"- sizeExpr =- caseE (tupE (concatMap (map sizeAtType . snd) cons))- (if null sizeNames then [matchConstSize] else [matchConstSize, matchVarSize])+ sizeExpr+ -- Maximum size of GHC tuples+ | length cons <= 62 =+ caseE (tupE (concatMap (map sizeAtType . snd) cons))+ (case cons of+ -- Avoid overlapping matches when the case expression is ()+ [] -> [matchConstSize]+ [c] | null (snd c) -> [matchConstSize]+ _ -> [matchConstSize, matchVarSize])+ | otherwise = varSizeExpr where sizeAtType :: (Name, Type) -> ExpQ sizeAtType (_, ty) = [| size :: Size $(return ty) |]@@ -139,9 +147,11 @@ matchVarSize :: MatchQ matchVarSize = do match (tupP (map (\(n, _) -> varP n) (concatMap snd cons)))- (normalB [| VarSize $ \x -> tagSize +- $(caseE [| x |] (map matchVar cons)) |])+ (normalB varSizeExpr) []+ varSizeExpr :: ExpQ+ varSizeExpr =+ [| VarSize $ \x -> tagSize + $(caseE [| x |] (map matchVar cons)) |] matchVar :: (Name, [(Name, Type)]) -> MatchQ matchVar (cname, []) = match (conP cname []) (normalB [| 0 |]) []@@ -186,18 +196,6 @@ pokeTag ix = noBindS [| poke (ix :: $(conT tagType)) |] pokeField (fn, _) = noBindS [| poke $(varE fn) |] --- FIXME: make this work even when there are too many fields---- FIXME: make the ConstSize stuff explicit in the API. Have an option--- that always errors at runtime if it isn't ConstSize?---- TODO: It would be really awesome, though a bit tricky, to know at--- compile time if we have a static size.---- TODO: make sure that this tends to optimize even with tons of fields.--- It should also optimize when some fields are known to be , but others--- are unknown (determined by polymorphic var)- {- What the generated code looks like data Foo = Foo Int Double Float@@ -265,6 +263,11 @@ deriveGenericInstance :: Cxt -> Type -> Dec deriveGenericInstance cs ty = plainInstanceD cs (AppT (ConT ''Store) ty) [] +deriveGenericInstanceFromName :: Name -> Q Dec+deriveGenericInstanceFromName n = do+ tvs <- map VarT . dtTvs <$> reifyDataType n+ return $ deriveGenericInstance (map storePred tvs) (appsT (ConT n) tvs)+ ------------------------------------------------------------------------ -- Storable @@ -278,13 +281,24 @@ \(TypeclassInstance cs ty _) -> let argTy = head (tail (unAppsT ty)) tyNameLit = LitE (StringL (pprint ty)) in- if p argTy+ if p argTy && not (superclassHasStorable cs) then Just $ makeStoreInstance cs argTy (AppE (VarE 'sizeStorableTy) tyNameLit) (AppE (VarE 'peekStorableTy) tyNameLit) (VarE 'pokeStorable) else Nothing +-- See #143. Often Storable superclass constraints should instead be+-- Store constraints, so instead it just warns for these.+superclassHasStorable :: Cxt -> Bool+superclassHasStorable = isJust . something (mkQ Nothing justStorable `extQ` ignoreStrings)+ where+ justStorable :: Type -> Maybe ()+ justStorable (ConT n) | n == ''Storable = Just ()+ justStorable _ = Nothing+ ignoreStrings :: String -> Maybe ()+ ignoreStrings _ = Nothing+ ------------------------------------------------------------------------ -- Vector @@ -327,24 +341,36 @@ deriveManyStoreUnboxVector = do unboxes <- getUnboxInfo stores <- postprocess . instancesMap <$> getInstances ''Store- let unboxInsts =+ unboxInstances <- postprocess . instancesMap <$> getInstances ''UV.Unbox+ let dataFamilyDecls = M.fromList (map (\(preds, ty, cons) -> ([AppT (ConT ''UV.Vector) ty], (preds, cons))) unboxes) `M.difference` stores+#if MIN_VERSION_template_haskell(2,10,0)+ substituteConstraint (AppT (ConT n) arg)+ | n == ''UV.Unbox = AppT (ConT ''Store) (AppT (ConT ''UV.Vector) arg)+#else+ substituteConstraint (ClassP n [arg])+ | n == ''UV.Unbox = ClassP ''Store [AppT (ConT ''UV.Vector) arg]+#endif+ substituteConstraint x = x -- TODO: ideally this would use a variant of 'deriveStore' which -- assumes VarSize.- forM (M.toList unboxInsts) $ \case- ([ty], (preds, cons)) -> do- {-- -- While this approach is reasonable-ish, it ends up- -- requiring UndecidableInstances.- let extraPreds =- map (AppT (ConT ''Store)) $- filter (not . isMonoType) $- concatMap (map snd . dcFields) cons- -}- let extraPreds = map (storePred . AppT (ConT ''UV.Vector)) $ listify isVarT ty- deriveStore (nub (preds ++ extraPreds)) ty cons+ forM (M.toList dataFamilyDecls) $ \case+ ([ty], (_, cons)) -> do+ let headTy = getTyHead (unAppsT ty !! 1)+ (preds, ty') <- case M.lookup [headTy] unboxInstances of+ Nothing -> do+ reportWarning $ "No Unbox instance found for " ++ pprint headTy+ return ([], ty)+ Just (TypeclassInstance cs (AppT _ ty') _) -> case ty' of+ AppT (ConT conName) arg ->+ if nameBase conName `elem` doNotUnboxConstructors+ then return ([AppT (ConT ''Store) arg], AppT (ConT ''UV.Vector) ty')+ else return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty')+ _ -> return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty')+ Just _ -> fail "Impossible case"+ deriveStore preds ty' cons _ -> fail "impossible case in deriveManyStoreUnboxVector" -- TODO: Add something for this purpose to TH.ReifyDataType@@ -352,18 +378,39 @@ getUnboxInfo :: Q [(Cxt, Type, [DataCon])] getUnboxInfo = do FamilyI _ insts <- reify ''UV.Vector- return (map (everywhere (id `extT` dequalVarT) . go) insts)+ return (map (everywhere (id `extT` dequalVarT)) $ mapMaybe go insts) where-#if MIN_VERSION_template_haskell(2,11,0)- go (NewtypeInstD preds _ [ty] _ con _) = (preds, ty, conToDataCons con)- go (DataInstD preds _ [ty] _ cons _) = (preds, ty, concatMap conToDataCons cons)+#if MIN_VERSION_template_haskell(2,15,0)+ go (NewtypeInstD preds _ lhs _ con _)+ | [_, ty] <- unAppsT lhs+ = toResult preds ty [con]+ go (DataInstD preds _ lhs _ cons _)+ | [_, ty] <- unAppsT lhs+ = toResult preds ty cons+#elif MIN_VERSION_template_haskell(2,11,0)+ go (NewtypeInstD preds _ [ty] _ con _) = toResult preds ty [con]+ go (DataInstD preds _ [ty] _ cons _) = toResult preds ty cons #else- go (NewtypeInstD preds _ [ty] con _) = (preds, ty, conToDataCons con)- go (DataInstD preds _ [ty] cons _) = (preds, ty, concatMap conToDataCons cons)+ go (NewtypeInstD preds _ [ty] con _) = toResult preds ty [con]+ go (DataInstD preds _ [ty] cons _) = toResult preds ty cons #endif go x = error ("Unexpected result from reifying Unboxed Vector instances: " ++ pprint x)+ toResult :: Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon])+ toResult _ _ [NormalC conName _]+ | nameBase conName `elem` skippedUnboxConstructors = Nothing+ toResult preds ty cons+ = Just (preds, ty, concatMap conToDataCons cons)+ dequalVarT :: Type -> Type dequalVarT (VarT n) = VarT (dequalify n) dequalVarT ty = ty++-- See issue #174+skippedUnboxConstructors :: [String]+skippedUnboxConstructors = ["MV_UnboxAs", "V_UnboxAs", "MV_UnboxViaPrim", "V_UnboxViaPrim"]++-- See issue #179+doNotUnboxConstructors :: [String]+doNotUnboxConstructors = ["DoNotUnboxLazy","DoNotUnboxStrict","DoNotUnboxNormalForm"] ------------------------------------------------------------------------ -- Utilities
src/Data/Store/TypeHash.hs view
@@ -1,10 +1,7 @@--- This module provides utilities for computing hashes based on the+-- | This module provides utilities for computing hashes based on the -- structural definitions of datatypes. The purpose of this is to -- provide a mechanism for tagging serialized data in such a way that -- deserialization issues can be anticipated.------ This portion of the store package is still under development and will--- likely change in interface and behavior. module Data.Store.TypeHash ( Tagged(..) , TypeHash
src/Data/Store/TypeHash/Internal.hs view
@@ -28,7 +28,7 @@ import GHC.Generics (Generic) import Language.Haskell.TH import Language.Haskell.TH.ReifyMany (reifyMany)-import Language.Haskell.TH.Syntax (Lift(lift))+import Language.Haskell.TH.Syntax (Lift(..), unsafeTExpCoerce) import Prelude {-# DEPRECATED mkManyHasTypeHash, mkHasTypeHash@@ -63,8 +63,12 @@ instance Lift TypeHash where lift = staticByteStringExp . unStaticSize . unTypeHash+#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = Code . unsafeTExpCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif --- TODO: move into th-reify-many reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)]
src/Data/Store/Version.hs view
@@ -105,7 +105,6 @@ Nothing -> return () Just expectedHash -> do let shownType = showsQualTypeRep (vcRenames vc) 0 (typeRep proxy) ""- -- FIXME: sanitize expected and handle null path <- storeVersionedPath expectedHash if hashb64 == expectedHash then writeVersionInfo path shownType info@@ -217,7 +216,7 @@ goField = do s <- get case sFieldNames s of- [] -> fail "impossible case in getStructureInfo'"+ [] -> error "impossible case in getStructureInfo'" (name:names) -> do getStructureInfo' ignore renames (Proxy :: Proxy b) s' <- get
src/System/IO/ByteBuffer.hs view
@@ -43,6 +43,7 @@ import Control.Applicative import Control.Exception (SomeException, throwIO) import Control.Exception.Lifted (Exception, bracket, catch)+import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl) import Data.ByteString (ByteString)@@ -280,7 +281,7 @@ -- such the ones created by the @network@ package. -- -- Returns how many bytes could be read non-blockingly.-fillFromFd :: MonadIO m => ByteBuffer -> Fd -> Int -> m Int+fillFromFd :: (MonadIO m, Fail.MonadFail m) => ByteBuffer -> Fd -> Int -> m Int fillFromFd bb sock maxBytes = if maxBytes < 0 then fail ("fillFromFd: negative argument (" ++ show maxBytes ++ ")") else bbHandler "fillFromFd" bb go
store.cabal view
@@ -1,274 +1,326 @@--- This file has been generated from package.yaml by hpack version 0.18.1.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.39.5. -- -- see: https://github.com/sol/hpack name: store-version: 0.4.3.2+version: 0.7.22 synopsis: Fast binary serialization category: Serialization, Data-homepage: https://github.com/fpco/store#readme-bug-reports: https://github.com/fpco/store/issues-maintainer: Michael Sloan <sloan@fpcomplete.com>+homepage: https://github.com/mgsloan/store#readme+bug-reports: https://github.com/mgsloan/store/issues+maintainer: Michael Sloan <mgsloan@gmail.com> copyright: 2016 FP Complete license: MIT license-file: LICENSE build-type: Simple-cabal-version: >= 1.10-+tested-with:+ GHC==9.4.5+ , GHC==9.2.8+ , GHC==9.0.2+ , GHC==8.10.7+ , GHC==8.8.4+ , GHC==8.6.5+ , GHC==8.4.4 extra-source-files: ChangeLog.md README.md source-repository head type: git- location: https://github.com/fpco/store+ location: https://github.com/mgsloan/store flag comparison-bench manual: True default: False +flag integer-simple+ description: Use the [simple integer library](http://hackage.haskell.org/package/integer-simple) instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp)+ manual: False+ default: False+ flag small-bench manual: True default: False library+ exposed-modules:+ Data.Store+ Data.Store.Internal+ Data.Store.TH+ Data.Store.TH.Internal+ Data.Store.TypeHash+ Data.Store.TypeHash.Internal+ Data.Store.Version+ System.IO.ByteBuffer+ other-modules:+ Data.Store.Impl hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 build-depends:- base >=4.7 && <5- , store-core >=0.4 && <0.5- , th-utilities >=0.2- , primitive >=0.6- , th-reify-many >=0.1.6- , array >=0.5.0.0+ array >=0.5.0.0+ , async >=2.0.2+ , base >=4.7 && <5 , base-orphans >=0.4.3- , base64-bytestring >= 0.1.1+ , base64-bytestring >=0.1.1+ , bifunctors >=4.0 , bytestring >=0.10.4.0- , conduit >=1.2.3.1 , containers >=0.5.5.1- , cryptohash >=0.11.6+ , contravariant >=1.3+ , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2- , directory >= 1.2- , filepath >= 1.3+ , directory >=1.2+ , filepath >=1.3+ , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0- , integer-gmp >=0.5.1.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0+ , nats >=1+ , network >=2.6.0.2+ , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8- , semigroups >=0.8 , smallcheck >=1.1.1+ , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4- , th-orphans >= 0.12.2- , time >=1.4.2+ , th-orphans >=0.13.2+ , th-reify-many >=0.1.6+ , th-utilities >=0.2+ , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , void >=0.5.11- , free >=4.11- , network >=2.6.0.2- , streaming-commons >=0.1.10.0- , async >=2.0.2- , contravariant >=1.3- exposed-modules:- Data.Store- Data.Store.Internal- Data.Store.Streaming- Data.Store.Streaming.Internal- Data.Store.TH- Data.Store.TH.Internal- Data.Store.TypeHash- Data.Store.TypeHash.Internal- Data.Store.Version- System.IO.ByteBuffer- other-modules:- Data.Store.Impl default-language: Haskell2010+ if flag(integer-simple)+ build-depends:+ integer-simple >=0.1.1.1+ else+ cpp-options: -DINTEGER_GMP+ build-depends:+ integer-gmp >=0.5.1.0+ if impl(ghc < 8.0)+ build-depends:+ fail >=4.9+ , semigroups >=0.8 test-suite store-test type: exitcode-stdio-1.0 main-is: Spec.hs+ other-modules:+ Data.Store.UntrustedSpec+ Data.StoreSpec+ Data.StoreSpec.TH+ System.IO.ByteBufferSpec hs-source-dirs: test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends:+ hspec-discover:hspec-discover build-depends:- base >=4.7 && <5- , store-core >=0.4 && <0.5- , th-utilities >=0.2- , primitive >=0.6- , th-reify-many >=0.1.6- , array >=0.5.0.0+ array >=0.5.0.0+ , async >=2.0.2+ , base >=4.7 && <5 , base-orphans >=0.4.3- , base64-bytestring >= 0.1.1+ , base64-bytestring >=0.1.1+ , bifunctors >=4.0 , bytestring >=0.10.4.0- , conduit >=1.2.3.1+ , clock >=0.3 , containers >=0.5.5.1- , cryptohash >=0.11.6+ , contravariant >=1.3+ , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2- , directory >= 1.2- , filepath >= 1.3+ , directory >=1.2+ , filepath >=1.3+ , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0- , integer-gmp >=0.5.1.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0+ , nats >=1+ , network >=2.6.0.2+ , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8- , semigroups >=0.8 , smallcheck >=1.1.1+ , store+ , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4- , th-orphans >= 0.12.2- , time >=1.4.2+ , th-orphans >=0.13.2+ , th-reify-many >=0.1.6+ , th-utilities >=0.2+ , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , void >=0.5.11- , free >=4.11- , network >=2.6.0.2- , streaming-commons >=0.1.10.0- , async >=2.0.2- , contravariant >=1.3- , store- other-modules:- Data.Store.StreamingSpec- Data.StoreSpec- Data.StoreSpec.TH- System.IO.ByteBufferSpec default-language: Haskell2010+ if flag(integer-simple)+ build-depends:+ integer-simple >=0.1.1.1+ else+ cpp-options: -DINTEGER_GMP+ build-depends:+ integer-gmp >=0.5.1.0+ if impl(ghc < 8.0)+ build-depends:+ fail >=4.9+ , semigroups >=0.8 -test-suite store-weigh+benchmark store-bench type: exitcode-stdio-1.0- main-is: Allocations.hs+ main-is: Bench.hs+ other-modules:+ Paths_store hs-source-dirs:- test- ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2+ bench+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg build-depends:- base >=4.7 && <5- , store-core >=0.4 && <0.5- , th-utilities >=0.2- , primitive >=0.6- , th-reify-many >=0.1.6- , array >=0.5.0.0+ array >=0.5.0.0+ , async >=2.0.2+ , base >=4.7 && <5 , base-orphans >=0.4.3- , base64-bytestring >= 0.1.1+ , base64-bytestring >=0.1.1+ , bifunctors >=4.0 , bytestring >=0.10.4.0- , conduit >=1.2.3.1 , containers >=0.5.5.1- , cryptohash >=0.11.6+ , contravariant >=1.3+ , criterion+ , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2- , directory >= 1.2- , filepath >= 1.3+ , directory >=1.2+ , filepath >=1.3+ , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0- , integer-gmp >=0.5.1.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0+ , nats >=1+ , network >=2.6.0.2+ , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8- , semigroups >=0.8 , smallcheck >=1.1.1+ , store+ , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4- , th-orphans >= 0.12.2- , time >=1.4.2+ , th-orphans >=0.13.2+ , th-reify-many >=0.1.6+ , th-utilities >=0.2+ , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 , void >=0.5.11- , free >=4.11- , network >=2.6.0.2- , streaming-commons >=0.1.10.0- , async >=2.0.2- , contravariant >=1.3- , store- , weigh- , criterion- , cereal- , cereal-vector- , vector-binary-instances default-language: Haskell2010+ if flag(integer-simple)+ build-depends:+ integer-simple >=0.1.1.1+ else+ cpp-options: -DINTEGER_GMP+ build-depends:+ integer-gmp >=0.5.1.0+ if impl(ghc < 8.0)+ build-depends:+ fail >=4.9+ , semigroups >=0.8+ if flag(comparison-bench)+ cpp-options: -DCOMPARISON_BENCH+ build-depends:+ binary+ , cereal+ , cereal-vector+ , vector-binary-instances+ if flag(small-bench)+ cpp-options: -DSMALL_BENCH -benchmark store-bench+benchmark store-weigh type: exitcode-stdio-1.0- main-is: Bench.hs+ main-is: Allocations.hs hs-source-dirs:- bench- ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg+ test+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2 build-depends:- base >=4.7 && <5- , store-core >=0.4 && <0.5- , th-utilities >=0.2- , primitive >=0.6- , th-reify-many >=0.1.6- , array >=0.5.0.0+ array >=0.5.0.0+ , async >=2.0.2+ , base >=4.7 && <5 , base-orphans >=0.4.3- , base64-bytestring >= 0.1.1+ , base64-bytestring >=0.1.1+ , bifunctors >=4.0 , bytestring >=0.10.4.0- , conduit >=1.2.3.1+ , cereal+ , cereal-vector , containers >=0.5.5.1- , cryptohash >=0.11.6+ , contravariant >=1.3+ , criterion+ , cryptohash-sha1 >=0.11.6 , deepseq >=1.3.0.2- , directory >= 1.2- , filepath >= 1.3+ , directory >=1.2+ , filepath >=1.3+ , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 , hspec-smallcheck >=0.3.0- , integer-gmp >=0.5.1.0 , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0+ , nats >=1+ , network >=2.6.0.2+ , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8- , semigroups >=0.8 , smallcheck >=1.1.1+ , store+ , store-core ==0.4.* , syb >=0.4.4 , template-haskell >=2.9.0.0 , text >=1.2.0.4 , th-lift >=0.7.1 , th-lift-instances >=0.1.4- , th-orphans >= 0.12.2- , time >=1.4.2+ , th-orphans >=0.13.2+ , th-reify-many >=0.1.6+ , th-utilities >=0.2+ , time >=1.5 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3+ , vector-binary-instances , void >=0.5.11- , free >=4.11- , network >=2.6.0.2- , streaming-commons >=0.1.10.0- , async >=2.0.2- , contravariant >=1.3- , criterion- , store- if flag(comparison-bench)- cpp-options: -DCOMPARISON_BENCH- build-depends:- cereal- , binary- , vector-binary-instances- , cereal-vector- if flag(small-bench)- cpp-options: -DSMALL_BENCH+ , weigh default-language: Haskell2010+ if flag(integer-simple)+ build-depends:+ integer-simple >=0.1.1.1+ else+ cpp-options: -DINTEGER_GMP+ build-depends:+ integer-gmp >=0.5.1.0+ if impl(ghc < 8.0)+ build-depends:+ fail >=4.9+ , semigroups >=0.8
test/Allocations.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -14,6 +15,9 @@ import qualified Data.Map.Strict as Map import qualified Data.Store as Store import qualified Data.Vector as Boxed+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector as BoxedStrict+#endif import qualified Data.Vector.Serialize () import qualified Data.Vector.Storable as Storable import Text.Printf@@ -29,6 +33,9 @@ weighing = do fortype "[Int]" (\n -> replicate n 0 :: [Int]) fortype "Boxed Vector Int" (\n -> Boxed.replicate n 0 :: Boxed.Vector Int)+#if MIN_VERSION_vector(0,13,2)+ fortype "Boxed Strict Vector Int" (\n -> BoxedStrict.replicate n 0 :: BoxedStrict.Vector Int)+#endif fortype "Storable Vector Int" (\n -> Storable.replicate n 0 :: Storable.Vector Int) fortype "Set Int" (Set.fromDistinctAscList . ints)
− test/Data/Store/StreamingSpec.hs
@@ -1,206 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-module Data.Store.StreamingSpec where--import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (race, concurrently)-import Control.Concurrent.MVar-import Control.Exception (try)-import Control.Monad (void, (<=<), forM_)-import Control.Monad.Trans.Free (runFreeT, FreeF(..))-import Control.Monad.Trans.Free.Church (fromFT)-import Control.Monad.Trans.Resource-import qualified Data.ByteString as BS-import Data.Conduit ((=$=), ($$))-import qualified Data.Conduit.List as C-import Data.List (unfoldr)-import Data.Monoid-import Data.Store.Internal-import Data.Store.Streaming-import Data.Store.Streaming.Internal-import Data.Streaming.Network (runTCPServer, runTCPClient, clientSettingsTCP, serverSettingsTCP, setAfterBind)-import Data.Streaming.Network.Internal (AppData(..))-import Data.Void (absurd, Void)-import Network.Socket (Socket(..), socketPort)-import Network.Socket.ByteString (send)-import qualified System.IO.ByteBuffer as BB-import System.Posix.Types (Fd(..))-import Test.Hspec-import Test.Hspec.SmallCheck-import Test.SmallCheck--spec :: Spec-spec = do- describe "conduitEncode and conduitDecode" $ do- it "Roundtrips ([Int])." $ property roundtrip- it "Roundtrips ([Int]), with chunked transfer." $ property roundtripChunked- it "Throws an Exception on incomplete messages." conduitIncomplete- it "Throws an Exception on excess input." $ property conduitExcess- describe "peekMessage" $ do- describe "ByteString" $ do- it "demands more input when needed." $ property (askMoreBS (headerLength + 1))- it "demands more input on incomplete message magic." $ property (askMoreBS 1)- it "demands more input on incomplete SizeTag." $ property (askMoreBS (headerLength - 1))- it "successfully decodes valid input." $ property canPeekBS- describe "decodeMessage" $ do- describe "ByteString" $ do- it "Throws an Exception on incomplete messages." decodeIncomplete- it "Throws an Exception on messages that are shorter than indicated." decodeTooShort-#ifndef mingw32_HOST_OS- describe "Socket" $ do- it "Decodes data trickling through a socket." $ property decodeTricklingMessageFd-#endif--roundtrip :: [Int] -> Property IO-roundtrip xs = monadic $ do- xs' <- runResourceT $ C.sourceList xs- =$= C.map Message- =$= conduitEncode- =$= conduitDecode Nothing- =$= C.map fromMessage- $$ C.consume- return $ xs' == xs--roundtripChunked :: [Int] -> Property IO-roundtripChunked input = monadic $ do- let (xs, chunkLengths) = splitAt (length input `div` 2) input- bs <- C.sourceList xs- =$= C.map Message- =$= conduitEncode- $$ C.fold (<>) mempty- let chunks = unfoldr takeChunk (bs, chunkLengths)- xs' <- runResourceT $ C.sourceList chunks- =$= conduitDecode (Just 10)- =$= C.map fromMessage- $$ C.consume- return $ xs' == xs- where- takeChunk (x, _) | BS.null x = Nothing- takeChunk (x, []) = Just (x, (BS.empty, []))- takeChunk (x, l:ls) =- let (chunk, rest) = BS.splitAt l x- in Just (chunk, (rest, ls))--conduitIncomplete :: Expectation-conduitIncomplete =- (runResourceT (C.sourceList [incompleteInput]- =$= conduitDecode (Just 10)- $$ C.consume)- :: IO [Message Integer]) `shouldThrow` \PeekException{} -> True--conduitExcess :: [Int] -> Property IO-conduitExcess xs = monadic $ do- bs <- C.sourceList xs- =$= C.map Message- =$= conduitEncode- $$ C.fold (<>) mempty- res <- try (runResourceT (C.sourceList [bs `BS.append` "excess bytes"]- =$= conduitDecode (Just 10)- $$ C.consume) :: IO [Message Int])- case res of- Right _ -> return False- Left (PeekException _ _) -> return True---- splits an encoded message after n bytes. Feeds the first part to--- peekResult, expecting it to require more input. Then, feeds the--- second part and checks if the decoded result is the original--- message.-askMoreBS :: Int -> Integer -> Property IO-askMoreBS n x = monadic $ BB.with (Just 10) $ \ bb -> do- let bs = encodeMessage (Message x)- (start, end) = BS.splitAt n $ bs- BB.copyByteString bb start- peekResult <- runFreeT (fromFT (peekMessageBS bb))- case peekResult of- Free cont ->- runFreeT (cont end) >>= \case- Pure (Message x') -> return $ x' == x- Free _ -> return False- Pure _ -> return False--canPeekBS :: Integer -> Property IO-canPeekBS x = monadic $ BB.with (Just 10) $ \ bb -> do- let bs = encodeMessage (Message x)- BB.copyByteString bb bs- peekResult <- runFreeT (fromFT (peekMessageBS bb))- case peekResult of- Free _ -> return False- Pure (Message x') -> return $ x' == x--#ifndef mingw32_HOST_OS--socketFd :: Socket -> Fd-socketFd (MkSocket fd _ _ _ _) = Fd fd--withServer :: (Socket -> Socket -> IO a) -> IO a-withServer cont = do- sock1Var :: MVar Socket <- newEmptyMVar- sock2Var :: MVar Socket <- newEmptyMVar- portVar :: MVar Int <- newEmptyMVar- doneVar :: MVar Void <- newEmptyMVar- let adSocket ad = case appRawSocket' ad of- Nothing -> error "withServer.adSocket: no raw socket in AppData"- Just sock -> sock- let ss = setAfterBind- (putMVar portVar . fromIntegral <=< socketPort)- (serverSettingsTCP 0 "127.0.0.1")- x <- fmap (either (either absurd absurd) id) $ race- (race- (runTCPServer ss $ \ad -> do- putMVar sock1Var (adSocket ad)- void (readMVar doneVar))- (do port <- takeMVar portVar- runTCPClient (clientSettingsTCP port "127.0.0.1") $ \ad -> do- putMVar sock2Var (adSocket ad)- readMVar doneVar))- (do sock1 <- takeMVar sock1Var- sock2 <- takeMVar sock2Var- cont sock1 sock2)- putMVar doneVar (error "withServer: impossible: read from doneVar")- return x--decodeTricklingMessageFd :: Integer -> Property IO-decodeTricklingMessageFd v = monadic $ do- let bs = encodeMessage (Message v)- BB.with Nothing $ \bb ->- withServer $ \sock1 sock2 -> do- let generateChunks :: [Int] -> BS.ByteString -> [BS.ByteString]- generateChunks xs0 bs_ = case xs0 of- [] -> generateChunks [1,3,10] bs_- x : xs -> if BS.null bs_- then []- else BS.take x bs_ : generateChunks xs (BS.drop x bs_)- let chunks = generateChunks [] bs- ((), Message v') <- concurrently- (forM_ chunks $ \chunk -> do- void (send sock1 chunk)- threadDelay (10 * 1000))- (decodeMessageFd bb (socketFd sock2))- return (v == v')--#endif--decodeIncomplete :: IO ()-decodeIncomplete = BB.with (Just 0) $ \ bb -> do- BB.copyByteString bb (BS.take 1 incompleteInput)- (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Integer)))- `shouldThrow` \PeekException{} -> True--incompleteInput :: BS.ByteString-incompleteInput =- let bs = encodeMessage (Message (42 :: Integer))- in BS.take (BS.length bs - 1) bs--decodeTooShort :: IO ()-decodeTooShort = BB.with Nothing $ \bb -> do- BB.copyByteString bb (encodeMessageTooShort . Message $ (1 :: Int))- (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Int)))- `shouldThrow` \PeekException{} -> True--encodeMessageTooShort :: Message Int -> BS.ByteString-encodeMessageTooShort msg =- BS.take (BS.length encoded - (getSize (0 :: Int))) encoded- where- encoded = encodeMessage msg
+ test/Data/Store/UntrustedSpec.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Tests for untrusted data.++module Data.Store.UntrustedSpec where++import Test.Hspec++spec :: Spec+spec = return ()++{- Untrusted data spec is disabled for now. See #122 / #123 for details++import Data.Bifunctor+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Int+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Monoid+import Data.Proxy+import qualified Data.Sequence as Seq+import Data.Store+import Data.Store.Internal+import Data.String+import Data.Text (Text)+import qualified Data.Vector as V++-- | Test suite.+actualSpec :: Spec+actualSpec =+ describe+ "Untrusted input throws error"+ (do describe+ "Array-like length prefixes"+ (do let sample+ :: IsString s+ => s+ sample = "abc"+ list :: [Int]+ list = [1, 2, 3]+ it+ "ByteString"+ (shouldBeRightWrong huge (sample :: ByteString))+ it+ "Lazy ByteString"+ (shouldBeRightWrong huge (sample :: L.ByteString))+ it "Text" (shouldBeRightWrong huge (sample :: Text))+ it "String" (shouldBeRightWrong huge (sample :: String))+ it "Vector Int" (shouldBeRightWrong huge (V.fromList list))+ it+ "Vector Char"+ (shouldBeRightWrong huge (V.fromList (sample :: [Char])))+ it+ "Vector unit"+ (shouldBeRightWrong+ huge+ (V.fromList (replicate 1000 ())))+ it "Seq Int" (shouldBeRightWrong huge (Seq.fromList (sample :: [Char]))))+ describe+ "Maps are consistent"+ (do it+ "Map Int Int: with duplicates"+ (shouldBeFail+ (DuplicatedMap+ (M.fromList [(1, 2), (4, 5)] :: Map Int Int))+ (Proxy :: Proxy (Map Int Int)))+ it+ "Map Int Int: wrong order"+ (shouldBeFail+ (ReversedMap+ (M.fromList [(1, 2), (4, 5)] :: Map Int Int))+ (Proxy :: Proxy (Map Int Int)))+ it+ "IntMap Int Int: with duplicates"+ (shouldBeFail+ (DuplicatedIntMap+ (IM.fromList [(1, 2), (4, 5)] :: IntMap Int))+ (Proxy :: Proxy (IntMap Int)))+ it+ "IntMap Int Int: wrong order"+ (shouldBeFail+ (ReversedIntMap+ (IM.fromList [(1, 2), (4, 5)] :: IntMap Int))+ (Proxy :: Proxy (IntMap Int))))+ describe+ "Constructor tags"+ (do it+ "Invalid constructor tag"+ (shouldBe+ (first+ (const ())+ (decode "\2" :: Either PeekException (Maybe ())))+ (Left ()))+ it+ "Missing slots"+ (shouldBe+ (first+ (const ())+ (decode "\1" :: Either PeekException (Maybe Char)))+ (Left ()))))++huge :: Int64+huge = 2^(62::Int)++-- | Check decode.encode==id and then check decode.badencode=>error.+shouldBeRightWrong+ :: forall i.+ (Store i, Eq i, Show i)+ => Int64 -> i -> IO ()+shouldBeRightWrong len input = do+ shouldBe (decode (encode input) :: Either PeekException i) (Right input)+ shouldBe+ (first+ (const ())+ (decode (encodeWrongPrefix len input) :: Either PeekException i))+ (Left ())++-- | Check decode.encode==id and then check decode.badencode=>error.+shouldBeFail+ :: forall o i.+ (Store i, Eq o, Show o, Store o)+ => i -> Proxy o -> IO ()+shouldBeFail input _ =+ shouldBe+ (first+ (const ())+ (decode (encode input) :: Either PeekException o))+ (Left ())++-- | Encode a thing with the wrong length prefix.+encodeWrongPrefix :: Store thing => Int64 -> thing -> ByteString+encodeWrongPrefix len thing = encode len <> encodeThingNoPrefix thing++-- | Encode the thing and drop the length prefix.+encodeThingNoPrefix :: Store thing => thing -> ByteString+encodeThingNoPrefix = S.drop (S.length (encode (1 :: Int64))) . encode++--------------------------------------------------------------------------------+-- Map variants++newtype ReversedIntMap = ReversedIntMap (IntMap Int)+ deriving (Show, Eq)+instance Store ReversedIntMap where+ poke (ReversedIntMap m) = do+ poke markMapPokedInAscendingOrder+ poke (reverse (IM.toList m))+ peek = error "ReversedIntMap.peek"+ size = VarSize (\(ReversedIntMap m) -> getSize m)++newtype DuplicatedIntMap = DuplicatedIntMap (IntMap Int)+ deriving (Show, Eq)+instance Store DuplicatedIntMap where+ poke (DuplicatedIntMap m) = do+ poke markMapPokedInAscendingOrder+ poke (let xs = IM.toList m+ in take (length xs) (cycle (take 1 xs)))+ peek = error "DuplicatedIntMap.peek"+ size = VarSize (\(DuplicatedIntMap m) -> getSize m)++newtype ReversedMap = ReversedMap (Map Int Int)+ deriving (Show, Eq)+instance Store ReversedMap where+ poke (ReversedMap m) = do+ poke markMapPokedInAscendingOrder+ poke (reverse (M.toList m))+ peek = error "ReversedMap.peek"+ size = VarSize (\(ReversedMap m) -> getSize m)++newtype DuplicatedMap = DuplicatedMap (Map Int Int)+ deriving (Show, Eq)+instance Store DuplicatedMap where+ poke (DuplicatedMap m) = do+ poke markMapPokedInAscendingOrder+ poke (let xs = M.toList m+ in take (length xs) (cycle (take 1 xs)))+ peek = error "DuplicatedMap.peek"+ size = VarSize (\(DuplicatedMap m) -> getSize m)++-}
test/Data/StoreSpec.hs view
@@ -16,12 +16,15 @@ import Control.Applicative import Control.Exception (evaluate) import Control.Monad (unless)+import Control.Monad.Fail (MonadFail) import qualified Data.Array.Unboxed as A import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS import Data.Complex (Complex(..)) import Data.Containers (mapFromList, setFromList)+import Data.Fixed (Pico)+import Data.Generics (listify) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Hashable (Hashable)@@ -31,7 +34,6 @@ import qualified Data.List.NonEmpty as NE import Data.Map (Map) import Data.Monoid-import Data.Primitive.Types (Addr) import Data.Proxy (Proxy(..)) import Data.Sequence (Seq) import Data.Sequences (fromList)@@ -45,12 +47,15 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time+import qualified Data.Time.Clock.TAI as Time import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Primitive as PV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Unboxed as UV-import Data.Void (Void)+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as SCV+#endif import Data.Word import Foreign.C.Types import Foreign.Ptr@@ -58,21 +63,42 @@ import GHC.Fingerprint.Type (Fingerprint(..)) import GHC.Generics import GHC.Real (Ratio(..))+#if MIN_VERSION_base(4,15,0)+import GHC.RTS.Flags (IoSubSystem(..))+#endif import Language.Haskell.TH-import Language.Haskell.TH.ReifyMany import Language.Haskell.TH.Syntax import Network.Socket+import Numeric.Natural (Natural) import Prelude+import System.Clock (TimeSpec(..)) import System.Posix.Types import Test.Hspec hiding (runIO) import Test.SmallCheck.Series+import TH.Utilities (unAppsT) +#if !MIN_VERSION_primitive(0,7,0)+import Data.Primitive.Types (Addr)+#endif++#if MIN_VERSION_time(1,8,0)+import qualified Data.Time.Clock.System as Time+#endif+#if MIN_VERSION_time(1,9,0)+import qualified Data.Time.Format.ISO8601 as Time+#endif+#if MIN_VERSION_time(1,11,0)+import qualified Data.Time.Calendar.Quarter as Time+import qualified Data.Time.Calendar.WeekDate as Time+#endif++#if !MIN_VERSION_smallcheck(1,2,0)+import Data.Void (Void)+#endif+ ------------------------------------------------------------------------ -- Instances for base types --- TODO: should be possible to do something clever where it only defines--- instances that don't already exist. For now, just doing it manually.- addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++@@ -83,27 +109,42 @@ -- Serial instances for (Num a, Bounded a) types. Only really -- appropriate for the use here. +#if !MIN_VERSION_network(3,1,2) instance Bounded PortNumber where minBound = 0 maxBound = 65535+#endif -$(do let ns = [ ''CWchar, ''CUShort, ''CULong, ''CULLong, ''CIntMax+$(do let ns = [ ''PortNumber++#if !MIN_VERSION_smallcheck(1,2,0)+ , ''CWchar, ''CUShort, ''CULong, ''CULLong, ''CIntMax , ''CUIntMax, ''CPtrdiff, ''CSChar, ''CShort, ''CUInt, ''CLLong- , ''CLong, ''CInt, ''CChar, ''CSsize, ''CPid+ , ''CLong, ''CInt, ''CChar+#endif+ , ''CSsize, ''CPid , ''COff, ''CMode, ''CIno, ''CDev- , ''Word8, ''Word16, ''Word32, ''Word64, ''Word+#if !MIN_VERSION_smallcheck(1,1,4)+ , ''Word8, ''Word16, ''Word32, ''Word64 , ''Int8, ''Int16, ''Int32, ''Int64- , ''PortNumber+#endif+#if !MIN_VERSION_smallcheck(1,1,3)+ , ''Word+#endif #if MIN_VERSION_base(4,10,0)- , ''CBool, ''CClockId, ''CKey, ''CId+#if !MIN_VERSION_smallcheck(1,2,0)+ , ''CBool+#endif+ , ''CClockId, ''CKey, ''CId , ''CBlkSize, ''CFsBlkCnt, ''CFsFilCnt, ''CBlkCnt #endif- ] ++-#ifdef mingw32_HOST_OS- []-#else- [ ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid ]+#if MIN_VERSION_base(4,14,0)+ , ''CSocklen, ''CNfds #endif+#ifndef mingw32_HOST_OS+ , ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid+#endif+ ] f n = [d| instance Monad m => Serial m $(conT n) where series = generate (\_ -> addMinAndMaxBounds [0, 1]) |] concat <$> mapM f ns)@@ -112,14 +153,19 @@ -- Serial instances for (Num a) types. Only really appropriate for the -- use here. -$(do let ns = [ ''CUSeconds, ''CClock, ''CTime, ''CUChar, ''CSize, ''CSigAtomic+$(do let ns =+#if !MIN_VERSION_smallcheck(1,2,0)+ [ ''CUSeconds, ''CClock, ''CTime, ''CUChar, ''CSize, ''CSigAtomic , ''CSUSeconds, ''CFloat, ''CDouble ] ++-#ifdef mingw32_HOST_OS- []-#else- [ ''CSpeed, ''CCc ] #endif+#if !MIN_VERSION_smallcheck(1,1,3)+ [ ''Natural ] +++#endif+#ifndef mingw32_HOST_OS+ [ ''CSpeed, ''CCc ] +++#endif+ [] f n = [d| instance Monad m => Serial m $(conT n) where series = generate (\_ -> [0, 1]) |] concat <$> mapM f ns)@@ -129,31 +175,37 @@ $(do tys <- getAllInstanceTypes1 ''PV.Prim let f ty = [d| instance (Serial m $(return ty), Monad m) => Serial m (PV.Vector $(return ty)) where series = fmap PV.fromList series |]- concat <$> mapM f tys)---- Instance needed for generic TH instances---- Needs to be done manually because in GHC 7.8's TH, NameFlavour uses--- unboxed values and cannot use generic deriving. So we skip having an--- instance for it.-instance Monad m => Serial m Name where series = fmap mkName series---- Serial instances for (Generic a) types.+ concat <$> mapM f (filter (\ty -> length (unAppsT ty) == 1) tys)) --- FIXME: generating for TH instances is probably just adding--- unnecessary compiletime + runtime overhead.-$(do thNames <- reifyManyWithoutInstances- ''Serial- [''Info, ''Loc, ''ModName, ''PkgName, ''NameSpace, ''OccName]- (`notElem` [''NameFlavour])- let ns = [ ''Any, ''All ] ++ thNames- f n = [d| instance Monad m => Serial m $(conT n) |]+$(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ]+ f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] concat <$> mapM f ns) -$(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ]+-- Instances for DoNotUnbox types introduced in vector-0.13.2.0+#if MIN_VERSION_vector(0,13,2)+$(do let ns = [ ''UV.DoNotUnboxLazy, ''UV.DoNotUnboxStrict, ''UV.DoNotUnboxNormalForm ] f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] concat <$> mapM f ns) +deriving instance Generic (UV.DoNotUnboxLazy a)+deriving instance Generic (UV.DoNotUnboxNormalForm a)+deriving instance Generic (UV.DoNotUnboxStrict a)++deriving instance Eq a => Eq (UV.DoNotUnboxLazy a)+deriving instance Eq a => Eq (UV.DoNotUnboxNormalForm a)+deriving instance Eq a => Eq (UV.DoNotUnboxStrict a)++deriving instance Show a => Show (UV.DoNotUnboxLazy a)+deriving instance Show a => Show (UV.DoNotUnboxNormalForm a)+deriving instance Show a => Show (UV.DoNotUnboxStrict a)+#endif++instance Monad m => Serial m Any where+ series = fmap Any series++instance Monad m => Serial m All where+ series = fmap All series+ instance Monad m => Serial m Fingerprint where series = generate (\_ -> [Fingerprint 0 0, Fingerprint maxBound maxBound]) @@ -172,6 +224,11 @@ instance (Monad m, Serial m a) => Serial m (V.Vector a) where series = fmap V.fromList series +#if MIN_VERSION_vector(0,13,2)+instance (Monad m, Serial m a) => Serial m (SCV.Vector a) where+ series = fmap SCV.fromList series+#endif+ instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where series = fmap mapFromList series @@ -190,8 +247,6 @@ instance (Monad m, Serial m a) => Serial m (Seq a) where series = fmap fromList series -instance (Monad m, Serial m a) => Serial m (Complex a) where- series = uncurry (:+) <$> (series >< series) instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where series = fmap fromList series@@ -218,22 +273,32 @@ instance Monad m => Serial m Time.DiffTime where series = Time.picosecondsToDiffTime <$> series +instance Monad m => Serial m Time.NominalDiffTime where+ series = (realToFrac :: Integer -> Time.NominalDiffTime) <$> series+ instance Monad m => Serial m Time.UTCTime where series = uncurry Time.UTCTime <$> (series >< series) -instance (Monad m, Serial m a) => Serial m (NE.NonEmpty a)- instance (Monad m, Serial m a) => Serial m (Tagged a) --- Should probably get added to smallcheck :)+#if MIN_VERSION_base(4,15,0)+instance Monad m => Serial m IoSubSystem where+ series = cons0 IoPOSIX \/ cons0 IoNative+#endif++#if !MIN_VERSION_smallcheck(1,2,0)+instance (Monad m, Serial m a) => Serial m (Complex a) where+ series = uncurry (:+) <$> (series >< series)++instance (Monad m, Serial m a) => Serial m (NE.NonEmpty a)+ instance Monad m => Serial m Void where series = generate (\_ -> [])--#if !MIN_VERSION_template_haskell(2,11,0)-deriving instance Show NameFlavour-deriving instance Show NameSpace #endif +instance Monad m => Serial m TimeSpec where+ series = uncurry TimeSpec <$> (series >< series)+ -- We define our own Serial instance for 'Ratio' because of <https://github.com/feuerbach/smallcheck/pull/34> newtype SerialRatio a = SerialRatio (Ratio a)@@ -280,23 +345,65 @@ spec = do describe "Store on all monomorphic instances" $(do insts <- getAllInstanceTypes1 ''Store- omitTys <- sequence- [ [t| PV.Vector Addr |]- , [t| CUIntPtr |]+ ctimer <- maybe [] (pure . conT) <$> lookupTypeName "CTimer"+ omitTys0 <- sequence $+#if !MIN_VERSION_primitive(0,7,0)+ [t| Addr |] :+#endif+ [ [t| CUIntPtr |] , [t| CIntPtr |] , [t| IntPtr |] , [t| WordPtr |] , [t| TypeHash |] , [t| Fd |] , [t| NameFlavour |]-#if MIN_VERSION_base(4,10,0)- , [t| CTimer |]+ ]+ ++ ctimer++-- Assume the TH generated instances for Time work, to avoid defining+-- Serial instances. Also some lack Show / Eq.++ ++ [ [t| Time.AbsoluteTime |]+ , [t| Time.Day |]+ , [t| Time.LocalTime |]+ , [t| Time.TimeOfDay |]+ , [t| Time.TimeZone |]+ , [t| Time.UTCTime |]+ , [t| Time.UniversalTime |]+ , [t| Time.ZonedTime |]+ , [t| Time.TimeLocale |]+#if MIN_VERSION_time(1,8,0)+ , [t| Time.SystemTime |] #endif+#if MIN_VERSION_time(1,9,0)+ , [t| Time.FormatExtension |]+ , [t| Time.CalendarDiffDays |]+ , [t| Time.CalendarDiffTime |]+#endif+#if MIN_VERSION_time(1,11,0)+ , [t| Time.DayOfWeek |]+ , [t| Time.FirstWeekType |]+ , [t| Time.Quarter |]+ , [t| Time.QuarterOfYear |]+#endif+ ]- let f ty = isMonoType ty && ty `notElem` omitTys- smallcheckManyStore verbose 2 . map return . filter f $ insts)+ omitTys <- (omitTys0 ++) <$> mapM (\ty -> [t| PV.Vector $(pure ty) |]) omitTys0+ let f ty = isMonoType ty && ty `notElem` omitTys && null (listify isThName ty)+ filtered = filter f insts+ -- Roundtrip testing of TH instances is disabled - see issue #150.+ -- GHC 9.10+ ships template-haskell inside `ghc-internal`, so+ -- `nameModule` returns `GHC.Internal.TH.Syntax` for TH AST+ -- types (Type, TySynEqn, PkgName, SourceUnpackedness, ...).+ -- Match both module names so the filter keeps working on both+ -- old and new GHCs. See issue #182.+ isThName n = nameModule n `elem`+ [ Just "Language.Haskell.TH.Syntax"+ , Just "GHC.Internal.TH.Syntax"+ ]+ smallcheckManyStore verbose 2 $ map return filtered) it "Store on non-numeric Float/Double values" $ do- let testNonNumeric :: forall a m. (RealFloat a, Eq a, Show a, Typeable a, Store a, Monad m) => Proxy a -> m ()+ let testNonNumeric :: forall a m. (RealFloat a, Eq a, Show a, Typeable a, Store a, Monad m, MonadFail m) => Proxy a -> m () testNonNumeric _proxy = do assertRoundtrip verbose ((1/0) :: a) assertRoundtrip verbose ((-1/0) :: a)@@ -323,6 +430,12 @@ $(smallcheckManyStore verbose 4 [ [t| SV.Vector Int8 |] , [t| V.Vector Int8 |]+#if MIN_VERSION_vector(0,13,2)+ , [t| SCV.Vector Int8 |]+ , [t| UV.DoNotUnboxLazy Int8 |]+ , [t| UV.DoNotUnboxStrict Int8 |]+ , [t| UV.DoNotUnboxNormalForm Int8 |]+#endif , [t| SerialRatio Int8 |] , [t| Complex Int8 |] , [t| Dual Int8 |]@@ -334,6 +447,12 @@ , [t| Either Int8 Int8 |] , [t| SV.Vector Int64 |] , [t| V.Vector Int64 |]+#if MIN_VERSION_vector(0,13,2)+ , [t| SCV.Vector Int64 |]+ , [t| UV.DoNotUnboxLazy Int64 |]+ , [t| UV.DoNotUnboxStrict Int64 |]+ , [t| UV.DoNotUnboxNormalForm Int64 |]+#endif , [t| SerialRatio Int64 |] , [t| Complex Int64 |] , [t| Dual Int64 |]@@ -373,6 +492,9 @@ assertRoundtrip False $ BS.drop 3 $ BS.take 3 "Hello world!" assertRoundtrip False $ SV.drop 3 $ SV.take 3 (SV.fromList [1..10] :: SV.Vector Int32) assertRoundtrip False $ UV.drop 3 $ UV.take 3 (UV.fromList [1..10] :: UV.Vector Word8)+#if MIN_VERSION_vector(0,13,2)+ assertRoundtrip False $ SCV.drop 3 $ SCV.take 3 (SCV.fromList [1..10] :: SCV.Vector Word8)+#endif (return () :: IO ()) it "StaticSize roundtrips" $ do let x :: StaticSize 17 BS.ByteString@@ -415,7 +537,11 @@ (decodeEx bs :: HashMap Int ()) `shouldBe` m evaluate (decodeEx bs :: Map Int ()) `shouldThrow` isUnexpectedMarkerException evaluate (decodeEx bs :: IntMap ()) `shouldThrow` isUnexpectedMarkerException+ it "Expects decode of negative integer as a natural to throw PeekException" $ do+ evaluate (decodeEx (encode ((-5) :: Integer)) :: Natural)+ `shouldThrow` isNegativeNaturalException + isPokeException :: Test.Hspec.Selector PokeException isPokeException = const True @@ -428,3 +554,7 @@ isUnexpectedMarkerException :: Test.Hspec.Selector PeekException isUnexpectedMarkerException (PeekException _ t) = "Expected marker for ascending Map / IntMap: " `T.isPrefixOf` t++isNegativeNaturalException :: Test.Hspec.Selector PeekException+isNegativeNaturalException (PeekException _ t) =+ "Encountered negative integer when expecting a Natural" `T.isPrefixOf` t