store 0.1.0.1 → 0.2.0.0
raw patch · 12 files changed
+582/−596 lines, 12 filesdep +store-coredep +weighdep ~arraydep ~basedep ~base-orphans
Dependencies added: store-core, weigh
Dependency ranges changed: array, base, base-orphans, bytestring, conduit, containers, cryptohash, deepseq, fail, ghc-prim, hashable, hspec, hspec-smallcheck, integer-gmp, lifted-base, monad-control, mono-traversable, primitive, resourcet, safe, semigroups, smallcheck, syb, template-haskell, text, th-lift, th-lift-instances, th-orphans, th-reify-many, th-utilities, time, transformers, unordered-containers, vector, void
Files
- ChangeLog.md +26/−0
- README.md +43/−18
- bench/Bench.hs +1/−1
- src/Data/Store/Impl.hs +83/−403
- src/Data/Store/Internal.hs +57/−20
- src/Data/Store/Streaming.hs +47/−22
- src/Data/Store/TH/Internal.hs +1/−0
- src/Data/Store/TypeHash/Internal.hs +6/−7
- store.cabal +171/−112
- test/Allocations.hs +44/−0
- test/Data/Store/StreamingSpec.hs +44/−12
- test/Data/StoreSpec.hs +59/−1
ChangeLog.md view
@@ -1,5 +1,31 @@ # ChangeLog +## 0.2.0.0++Release notes:++* Core functionality split into `store-core` package++Breaking changes:++* `combineSize'` renamed to `combineSizeWith`++* Streaming support now prefixes each Message with a magic number, intended to+ detect mis-alignment of data frames. This is worth the overhead, because+ otherwise serialization errors could be more catastrophic - interpretting some+ bytes as a length tag and attempting to consume many bytes from the source.++Other enhancements:++* [weigh](https://github.com/fpco/weigh) based allocations benchmark.++* Addition of `Array` / `UArray` instances++* Streaming support now has checks for over/undershooting buffer++Bug fixes:++ ## 0.1.0.0 * First public release
README.md view
@@ -1,24 +1,49 @@ # store -The 'store' package provides binary serialization of Haskell datatypes. It fills-quite a different niche from packages like 'binary' or 'cereal'. In particular:+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. Whenever possible, direct machine representations- are used. For numeric types (`Int`, `Double`, `Word32`, etc) and types that- use 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`. -* By using machine representations, we lose serialization compatibility between- different architectures. Store could in theory be used to describe- machine-independent serialization formats. However, this is not the usecase- it's currently designed for (though utilities might be added for this in the- future!)+ 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. -* `Store` will not work at all on architectures which lack unaligned memory- access (for example, older ARM processors). This is not a fundamental- limitation, but we do not currently require ARM support.+* Instead of implementing lazy serialization / deserialization involving+ multiple input / output buffers, `peek` an `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. -See-[this blog post](https://www.fpcomplete.com/blog/2016/03/efficient-binary-serialization)-which describes the initial motivations and benchmarks that led to the existence-of this package.+* `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 generation of testcases.++## Architecture limitations++`Store` does not currently work at all on architectures which lack efficient+unaligned memory access (for example, older ARM processors). This is not a+fundamental limitation, but we do not currently require ARM or PowerPC support.+See [#37](https://github.com/fpco/store/issues/37) and+[#47](https://github.com/fpco/store/issues/47).++## Blog posts++* [Initial release announcement](https://www.fpcomplete.com/blog/2016/05/store-package)+* [Benchmarks of the prototype](https://www.fpcomplete.com/blog/2016/03/efficient-binary-serialization)+* [New 'weigh' allocation benchmark package](https://www.fpcomplete.com/blog/2016/05/weigh-package),+ created particularly to aid optimizing `store`.
bench/Bench.hs view
@@ -29,7 +29,7 @@ #endif data SomeData = SomeData !Int64 !Word8 !Double- deriving (Eq, Show, Generic)+ deriving (Eq, Show, Generic, Typeable) instance NFData SomeData where rnf x = x `seq` () instance Store SomeData
src/Data/Store/Impl.hs view
@@ -1,22 +1,16 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UnboxedTuples #-} -- This module is not exposed. The reason that it is split out from -- "Data.Store.Internal" is to allow "Data.Store.TH" to refer to these@@ -25,30 +19,16 @@ module Data.Store.Impl where import Control.Applicative-import Control.Exception (Exception(..), throwIO) import Control.Exception (try) import Control.Monad-import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Primitive (PrimMonad (..)) import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BS-import Data.Monoid ((<>))-import Data.Primitive.ByteArray import Data.Proxy-import qualified Data.Text as T-import Data.Typeable+import Data.Store.Core+import Data.Typeable (Typeable, typeRep) import Data.Word-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr)-import Foreign.Ptr (Ptr, plusPtr, minusPtr, castPtr)-import Foreign.Storable (pokeByteOff, Storable, sizeOf)-import qualified Foreign.Storable as Storable+import Foreign.Storable (Storable, sizeOf) import GHC.Generics-import GHC.Prim ( unsafeCoerce#, RealWorld )-import GHC.Prim (copyByteArrayToAddr#, copyAddrToByteArray#)-import GHC.Ptr (Ptr(..)) import GHC.TypeLits-import GHC.Types (IO(..), Int(..)) import Prelude import System.IO.Unsafe (unsafePerformIO) @@ -94,33 +74,21 @@ peek = genericPeek {-# INLINE peek #-} - ------------------------------------------------------------------------ -- Utilities for encoding / decoding strict ByteStrings -- | Serializes a value to a 'BS.ByteString'. In order to do this, it -- first allocates a 'BS.ByteString' of the correct size (based on -- 'size'), and then uses 'poke' to fill it.+--+-- Safety of this function depends on correctness of the 'Store'+-- instance. If 'size' returns a. The good news is that this isn't an+-- issue if you use well-tested manual instances (such as those from+-- this package) combined with auomatic definition of instances. encode :: Store a => a -> BS.ByteString-encode x = BS.unsafeCreate l $ \p -> do- (o, ()) <- runPoke (poke x) p 0- checkOffset o l- where- l = getSize x+encode x = unsafeEncodeWith (poke x) (getSize x) {-# INLINE encode #-} -checkOffset :: Int -> Int -> IO ()-checkOffset o l- | o > l = throwIO $ PokeException o $- "encode overshot end of " <>- T.pack (show l) <>- " byte long buffer"- | o < l = throwIO $ PokeException o $- "encode undershot end of " <>- T.pack (show l) <>- " byte long buffer"- | otherwise = return ()- -- | Decodes a value from a 'BS.ByteString'. Returns an exception if -- there's an error while decoding, or if decoding undershoots / -- overshoots the end of the buffer.@@ -129,63 +97,91 @@ {-# INLINE decode #-} -- | Decodes a value from a 'BS.ByteString', potentially throwing--- exceptions, and taking a 'Peek' to run. It is an exception to not--- consume all input.-decodeWith :: Peek a -> BS.ByteString -> Either PeekException a-decodeWith mypeek = unsafePerformIO . try . decodeIOWith mypeek-{-# INLINE decodeWith #-}---- | Decodes a value from a 'BS.ByteString', potentially throwing -- exceptions. It is an exception to not consume all input. decodeEx :: Store a => BS.ByteString -> a decodeEx = unsafePerformIO . decodeIO {-# INLINE decodeEx #-} -- | Decodes a value from a 'BS.ByteString', potentially throwing--- exceptions, and taking a 'Peek' to run. It is an exception to not--- consume all input.-decodeExWith :: Peek a -> BS.ByteString -> a-decodeExWith f = unsafePerformIO . decodeIOWith f-{-# INLINE decodeExWith #-}---- | Similar to 'decodeExWith', but it allows there to be more of the--- buffer remaining. The 'Offset' of the buffer contents immediately--- after the decoded value is returned.-decodeExPortionWith :: Peek a -> BS.ByteString -> (Offset, a)-decodeExPortionWith f = unsafePerformIO . decodeIOPortionWith f-{-# INLINE decodeExPortionWith #-}---- | Decodes a value from a 'BS.ByteString', potentially throwing -- exceptions. It is an exception to not consume all input. decodeIO :: Store a => BS.ByteString -> IO a decodeIO = decodeIOWith peek {-# INLINE decodeIO #-} --- | Decodes a value from a 'BS.ByteString', potentially throwing--- exceptions, and taking a 'Peek' to run. It is an exception to not--- consume all input.-decodeIOWith :: Peek a -> BS.ByteString -> IO a-decodeIOWith mypeek bs = do- (offset, x) <- decodeIOPortionWith mypeek bs- let remaining = BS.length bs - offset- if remaining > 0- then throwIO $ PeekException remaining "Didn't consume all input."- else return x-{-# INLINE decodeIOWith #-}+------------------------------------------------------------------------+-- Size --- | Similar to 'decodeExPortionWith', but runs in the 'IO' monad.-decodeIOPortionWith :: Peek a -> BS.ByteString -> IO (Offset, a)-decodeIOPortionWith mypeek (BS.PS x s len) =- withForeignPtr x $ \ptr0 ->- let ptr = ptr0 `plusPtr` s- end = ptr `plusPtr` len- in do- (ptr2, x') <- runPeek mypeek end ptr- if ptr2 > end- then throwIO $ PeekException (end `minusPtr` ptr2) "Overshot end of buffer"- else return (ptr2 `minusPtr` ptr, x')-{-# INLINE decodeIOPortionWith #-}+-- | Info about a type's serialized length. Either the length is known+-- independently of the value, or the length depends on the value.+data Size a+ = VarSize (a -> Int)+ | ConstSize !Int+ deriving Typeable +-- | Get the number of bytes needed to store the given value. See+-- 'size'.+getSize :: Store a => a -> Int+getSize = getSizeWith size+{-# INLINE getSize #-}++-- | Given a 'Size' value and a value of the type @a@, returns its 'Int'+-- size.+getSizeWith :: Size a -> a -> Int+getSizeWith (VarSize f) x = f x+getSizeWith (ConstSize n) _ = n+{-# INLINE getSizeWith #-}++-- | This allows for changing the type used as an input when the 'Size'+-- is 'VarSize'.+contramapSize :: (a -> b) -> Size b -> Size a+contramapSize f (VarSize g) = VarSize (g . f)+contramapSize _ (ConstSize n) = ConstSize n+{-# INLINE contramapSize #-}++-- | Create an aggregate 'Size' by providing functions to split the+-- input into two pieces.+--+-- If both of the types are 'ConstSize', the result is 'ConstSize' and+-- the functions will not be used.+combineSize :: forall a b c. (Store a, Store b) => (c -> a) -> (c -> b) -> Size c+combineSize toA toB = combineSizeWith toA toB size size+{-# INLINE combineSize #-}++-- | Create an aggregate 'Size' by providing functions to split the+-- input into two pieces, as well as 'Size' values to use to measure the+-- results.+--+-- If both of the input 'Size' values are 'ConstSize', the result is+-- 'ConstSize' and the functions will not be used.+combineSizeWith :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c+combineSizeWith toA toB sizeA sizeB =+ case (sizeA, sizeB) of+ (VarSize f, VarSize g) -> VarSize (\x -> f (toA x) + g (toB x))+ (VarSize f, ConstSize m) -> VarSize (\x -> f (toA x) + m)+ (ConstSize n, VarSize g) -> VarSize (\x -> n + g (toB x))+ (ConstSize n, ConstSize m) -> ConstSize (n + m)+{-# INLINE combineSizeWith #-}++-- | Adds a constant amount to a 'Size' value.+addSize :: Int -> Size a -> Size a+addSize x (ConstSize n) = ConstSize (x + n)+addSize x (VarSize f) = VarSize ((x +) . f)+{-# INLINE addSize #-}++-- | A 'size' implementation based on an instance of 'Storable' and+-- 'Typeable'.+sizeStorable :: forall a. (Storable a, Typeable a) => Size a+sizeStorable = sizeStorableTy (show (typeRep (Proxy :: Proxy a)))+{-# INLINE sizeStorable #-}++-- | A 'size' implementation based on an instance of 'Storable'. Use this+-- if the type is not 'Typeable'.+sizeStorableTy :: forall a. Storable a => String -> Size a+sizeStorableTy ty = ConstSize (sizeOf (error msg :: a))+ where+ msg = "In Data.Store.storableSize: " ++ ty ++ "'s sizeOf evaluated its argument."+{-# INLINE sizeStorableTy #-}+ ------------------------------------------------------------------------ -- Generics @@ -255,7 +251,7 @@ {-# INLINE gpeek #-} instance (GStoreSize a, GStoreSize b) => GStoreSize (a :*: b) where- gsize = combineSize' (\(x :*: _) -> x) (\(_ :*: y) -> y) gsize gsize+ gsize = combineSizeWith (\(x :*: _) -> x) (\(_ :*: y) -> y) gsize gsize {-# INLINE gsize #-} instance (GStorePoke a, GStorePoke b) => GStorePoke (a :*: b) where gpoke (a :*: b) = gpoke a >> gpoke b@@ -326,319 +322,3 @@ where cur = fromInteger (natVal (Proxy :: Proxy n)) {-# INLINE gpeekSum #-}----------------------------------------------------------------------------- Utilities for defining 'Store' instances based on 'Storable'---- | A 'size' implementation based on an instance of 'Storable' and--- 'Typeable'.-sizeStorable :: forall a. (Storable a, Typeable a) => Size a-sizeStorable = sizeStorableTy (show (typeRep (Proxy :: Proxy a)))-{-# INLINE sizeStorable #-}---- | A 'size' implementation based on an instance of 'Storable'. Use this--- if the type is not 'Typeable'.-sizeStorableTy :: forall a. Storable a => String -> Size a-sizeStorableTy ty = ConstSize (sizeOf (error msg :: a))- where- msg = "In Data.Store.storableSize: " ++ ty ++ "'s sizeOf evaluated its argument."-{-# INLINE sizeStorableTy #-}---- | A 'poke' implementation based on an instance of 'Storable'.-pokeStorable :: Storable a => a -> Poke ()-pokeStorable x = Poke $ \ptr offset -> do- y <- pokeByteOff ptr offset x- let !newOffset = offset + sizeOf x- return (newOffset, y)-{-# INLINE pokeStorable #-}---- FIXME: make it the responsibility of the caller to check this.---- | A 'peek' implementation based on an instance of 'Storable' and--- 'Typeable'.-peekStorable :: forall a. (Storable a, Typeable a) => Peek a-peekStorable = peekStorableTy (show (typeRep (Proxy :: Proxy a)))-{-# INLINE peekStorable #-}---- | A 'peek' implementation based on an instance of 'Storable'. Use--- this if the type is not 'Typeable'.-peekStorableTy :: forall a. Storable a => String -> Peek a-peekStorableTy ty = Peek $ \end ptr ->- let ptr' = ptr `plusPtr` needed- needed = sizeOf (undefined :: a)- remaining = end `minusPtr` ptr- in do- when (ptr' > end) $- tooManyBytes needed remaining ty- x <- Storable.peek (castPtr ptr)- return (ptr', x)-{-# INLINE peekStorableTy #-}----------------------------------------------------------------------------- Helpful Type Synonyms---- | Total byte size of the given Ptr-type Total = Int---- | How far into the given Ptr to look-type Offset = Int----------------------------------------------------------------------------- Poke monad--newtype Poke a = Poke- { runPoke :: forall byte. Ptr byte -> Offset -> IO (Offset, a)- -- ^ Run the 'Poke' action, with the 'Ptr' to the buffer where- -- data is poked, and the current 'Offset'. The result is the new- -- offset, along with a return value.- }- deriving Functor--instance Applicative Poke where- pure x = Poke $ \_ptr offset -> pure (offset, x)- {-# INLINE pure #-}- Poke f <*> Poke g = Poke $ \ptr offset1 -> do- (offset2, f') <- f ptr offset1- (offset3, g') <- g ptr offset2- return (offset3, f' g')- {-# INLINE (<*>) #-}- Poke f *> Poke g = Poke $ \ptr offset1 -> do- (offset2, _) <- f ptr offset1- g ptr offset2- {-# INLINE (*>) #-}--instance Monad Poke where- return = pure- {-# INLINE return #-}- (>>) = (*>)- {-# INLINE (>>) #-}- Poke x >>= f = Poke $ \ptr offset1 -> do- (offset2, x') <- x ptr offset1- runPoke (f x') ptr offset2- {-# INLINE (>>=) #-}- fail = Fail.fail- {-# INLINE fail #-}--instance Fail.MonadFail Poke where- fail = pokeException . T.pack- {-# INLINE fail #-}--instance MonadIO Poke where- liftIO f = Poke $ \_ offset -> (offset, ) <$> f- {-# INLINE liftIO #-}---- | Exception thrown while running 'poke'. Note that other types of--- exceptions could also be thrown. Invocations of 'fail' in the 'Poke'--- monad causes this exception to be thrown.------ 'PokeException's are not expected to occur in ordinary circumstances,--- and usually indicate a programming error.-data PokeException = PokeException- { pokeExByteIndex :: Offset- , pokeExMessage :: T.Text- }- deriving (Eq, Show, Typeable)--instance Exception PokeException where-#if MIN_VERSION_base(4,8,0)- displayException (PokeException offset msg) =- "Exception while poking, at byte index " ++- show offset ++- " : " ++- T.unpack msg-#endif--pokeException :: T.Text -> Poke a-pokeException msg = Poke $ \_ off -> throwIO (PokeException off msg)----------------------------------------------------------------------------- Peek monad--newtype Peek a = Peek- { runPeek :: forall byte. Ptr byte -> Ptr byte -> IO (Ptr byte, a)- -- ^ Run the 'Peek' action, with a 'Ptr' to the end of the buffer- -- where data is poked, and a 'Ptr' to the current position. The- -- result is the 'Ptr', along with a return value.- }- deriving Functor--instance Applicative Peek where- pure x = Peek (\_ ptr -> return (ptr, x))- {-# INLINE pure #-}- Peek f <*> Peek g = Peek $ \end ptr1 -> do- (ptr2, f') <- f end ptr1- (ptr3, g') <- g end ptr2- return (ptr3, f' g')- {-# INLINE (<*>) #-}- Peek f *> Peek g = Peek $ \end ptr1 -> do- (ptr2, _) <- f end ptr1- g end ptr2- {-# INLINE (*>) #-}--instance Monad Peek where- return = pure- {-# INLINE return #-}- (>>) = (*>)- {-# INLINE (>>) #-}- Peek x >>= f = Peek $ \end ptr1 -> do- (ptr2, x') <- x end ptr1- runPeek (f x') end ptr2- {-# INLINE (>>=) #-}- fail = Fail.fail- {-# INLINE fail #-}--instance Fail.MonadFail Peek where- fail = peekException . T.pack- {-# INLINE fail #-}--instance PrimMonad Peek where- type PrimState Peek = RealWorld- primitive action = Peek $ \_ ptr -> do- x <- primitive (unsafeCoerce# action)- return (ptr, x)- {-# INLINE primitive #-}--instance MonadIO Peek where- liftIO f = Peek $ \_ ptr -> (ptr, ) <$> f- {-# INLINE liftIO #-}---- | Exception thrown while running 'peek'. Note that other types of--- exceptions can also be thrown. Invocations of 'fail' in the 'Poke'--- monad causes this exception to be thrown.------ 'PeekException' is thrown when the data being decoded is invalid.-data PeekException = PeekException- { peekExBytesFromEnd :: Offset- , peekExMessage :: T.Text- } deriving (Eq, Show, Typeable)--instance Exception PeekException where-#if MIN_VERSION_base(4,8,0)- displayException (PeekException offset msg) =- "Exception while peeking, " ++- show offset ++- " bytes from end: " ++- T.unpack msg-#endif--peekException :: T.Text -> Peek a-peekException msg = Peek $ \end ptr -> throwIO (PeekException (end `minusPtr` ptr) msg)--tooManyBytes :: Int -> Int -> String -> IO void-tooManyBytes needed remaining ty =- throwIO $ PeekException remaining $ T.pack $- "Attempted to read too many bytes for " ++- ty ++- ". Needed " ++- show needed ++ ", but only " ++- show remaining ++ " remain."----------------------------------------------------------------------------- Size type---- | Info about a type's serialized length. Either the length is known--- independently of the value, or the length depends on the value.-data Size a- = VarSize (a -> Int)- | ConstSize !Int- deriving Typeable--getSize :: Store a => a -> Int-getSize = getSizeWith size-{-# INLINE getSize #-}--getSizeWith :: Size a -> a -> Int-getSizeWith (VarSize f) x = f x-getSizeWith (ConstSize n) _ = n-{-# INLINE getSizeWith #-}---- TODO: depend on contravariant package? The ConstSize case is a little--- wonky due to type conversion--contramapSize :: (a -> b) -> Size b -> Size a-contramapSize f (VarSize g) = VarSize (g . f)-contramapSize _ (ConstSize n) = ConstSize n-{-# INLINE contramapSize #-}--combineSize :: forall a b c. (Store a, Store b) => (c -> a) -> (c -> b) -> Size c-combineSize toA toB = combineSize' toA toB size size-{-# INLINE combineSize #-}--combineSize' :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c-combineSize' toA toB sizeA sizeB =- case (sizeA, sizeB) of- (VarSize f, VarSize g) -> VarSize (\x -> f (toA x) + g (toB x))- (VarSize f, ConstSize m) -> VarSize (\x -> f (toA x) + m)- (ConstSize n, VarSize g) -> VarSize (\x -> n + g (toB x))- (ConstSize n, ConstSize m) -> ConstSize (n + m)-{-# INLINE combineSize' #-}--scaleSize :: Int -> Size a -> Size a-scaleSize s (ConstSize n) = ConstSize (s * n)-scaleSize s (VarSize f) = VarSize ((s *) . f)-{-# INLINE scaleSize #-}--addSize :: Int -> Size a -> Size a-addSize x (ConstSize n) = ConstSize (x + n)-addSize x (VarSize f) = VarSize ((x +) . f)-{-# INLINE addSize #-}----------------------------------------------------------------------------- Utilities for implementing 'Store' instances via memcpy--pokeFromForeignPtr :: ForeignPtr a -> Int -> Int -> Poke ()-pokeFromForeignPtr sourceFp sourceOffset len =- Poke $ \targetPtr targetOffset -> do- withForeignPtr sourceFp $ \sourcePtr ->- BS.memcpy (targetPtr `plusPtr` targetOffset)- (sourcePtr `plusPtr` sourceOffset)- len- let !newOffset = targetOffset + len- return (newOffset, ())--peekToPlainForeignPtr :: String -> Int -> Peek (ForeignPtr a)-peekToPlainForeignPtr ty len =- Peek $ \end sourcePtr -> do- let ptr2 = sourcePtr `plusPtr` len- when (ptr2 > end) $- tooManyBytes len (end `minusPtr` sourcePtr) ty- fp <- BS.mallocByteString len- withForeignPtr fp $ \targetPtr ->- BS.memcpy targetPtr (castPtr sourcePtr) len- return (ptr2, castForeignPtr fp)--pokeFromPtr :: Ptr a -> Int -> Int -> Poke ()-pokeFromPtr sourcePtr sourceOffset len =- Poke $ \targetPtr targetOffset -> do- BS.memcpy (targetPtr `plusPtr` targetOffset)- (sourcePtr `plusPtr` sourceOffset)- len- let !newOffset = targetOffset + len- return (newOffset, ())--pokeFromByteArray :: ByteArray# -> Int -> Int -> Poke ()-pokeFromByteArray sourceArr sourceOffset len =- Poke $ \targetPtr targetOffset -> do- let target = targetPtr `plusPtr` targetOffset- copyByteArrayToAddr sourceArr sourceOffset target len- let !newOffset = targetOffset + len- return (newOffset, ())--peekToByteArray :: String -> Int -> Peek ByteArray-peekToByteArray ty len =- Peek $ \end sourcePtr -> do- let ptr2 = sourcePtr `plusPtr` len- when (ptr2 > end) $- tooManyBytes len (end `minusPtr` sourcePtr) ty- marr <- newByteArray len- copyAddrToByteArray sourcePtr marr 0 len- x <- unsafeFreezeByteArray marr- return (ptr2, x)--copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()-copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) =- IO (\s -> (# copyByteArrayToAddr# arr offset addr len s, () #))--copyAddrToByteArray :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO ()-copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) =- IO (\s -> (# copyAddrToByteArray# addr arr offset len s, () #))
src/Data/Store/Internal.hs view
@@ -39,13 +39,17 @@ -- ** Size type , Size(..) , getSize, getSizeWith- , contramapSize, combineSize, combineSize', scaleSize, addSize+ , contramapSize, combineSize, combineSizeWith, addSize -- ** Store instances in terms of IsSequence , sizeSequence, pokeSequence, peekSequence -- ** Store instances in terms of IsSet , sizeSet, pokeSet, peekSet -- ** Store instances in terms of IsMap , sizeMap, pokeMap, peekMap+ -- ** Store instances in terms of IArray+ , sizeArray, pokeArray, peekArray+ -- ** Store instances in terms of Generic+ , genericSize, genericPoke, genericPeek -- ** Peek utilities , skip, isolate -- ** Static Size type@@ -53,7 +57,7 @@ -- This portion of the library is still work-in-progress. -- 'IsStaticSize' is only supported for strict ByteStrings, in order -- to support the use case of 'Tagged'.- , IsStaticSize(..), StaticSize(..), toStaticSizeEx, liftStaticSize+ , IsStaticSize(..), StaticSize(..), toStaticSizeEx, liftStaticSize, staticByteStringExp ) where import Control.Applicative@@ -61,6 +65,7 @@ import Control.Exception (throwIO) import Control.Monad (when) import Control.Monad.IO.Class (liftIO)+import qualified Data.Array.Unboxed as A import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as LBS@@ -68,7 +73,7 @@ import Data.Containers (IsMap, ContainerKey, MapValue, mapFromList, mapToList, IsSet, setFromList) import Data.Data (Data) import Data.Fixed (Fixed (..), Pico)-import Data.Foldable (forM_)+import Data.Foldable (forM_, foldl') import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Hashable (Hashable)@@ -85,6 +90,7 @@ import Data.Sequences (IsSequence, Index, replicateM) import Data.Set (Set) import Data.Store.Impl+import Data.Store.Core import Data.Store.TH.Internal import qualified Data.Text as T import qualified Data.Text.Array as TA@@ -105,6 +111,7 @@ 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@@ -373,17 +380,6 @@ {-# INLINE peek #-} {-# INLINE poke #-} -{---- Gets a little tricky to compute size due to size of storing indices.--instance (Store i, Store e) => Store (Array i e) where- size = combineSize' () () () $- VarSize $ \t ->- case size :: Size e of- ConstSize n -> n * length x- VarSize f -> foldl' (\acc x -> acc + f x) 0--}- ------------------------------------------------------------------------ -- Known size instances @@ -417,7 +413,7 @@ pokeFromForeignPtr sourceFp sourceOffset sourceLength peek = do let len = fromInteger (natVal (Proxy :: Proxy n))- fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString") len+ fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len return (StaticSize (BS.PS fp 0 len)) {-# INLINE size #-} {-# INLINE peek #-}@@ -431,6 +427,12 @@ let numTy = litT $ numTyLit $ natVal (Proxy :: Proxy n) [| StaticSize $(lift x) :: StaticSize $(numTy) $(tyq) |] +staticByteStringExp :: BS.ByteString -> ExpQ+staticByteStringExp bs =+ [| StaticSize bs :: StaticSize $(litT (numTyLit (fromIntegral len))) BS.ByteString |]+ where+ len = BS.length bs+ ------------------------------------------------------------------------ -- containers instances @@ -500,11 +502,46 @@ {-# INLINE peek #-} {-# INLINE poke #-} --- FIXME: implement------ instance (Ix i, Bounded i, Store a) => Store (Array ix a) where------ instance (Ix i, Bounded i, Store a) => Store (UA.UArray ix a) where+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+ {-# INLINE size #-}+ {-# INLINE peek #-}+ {-# INLINE poke #-}++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+ {-# INLINE size #-}+ {-# INLINE peek #-}+ {-# INLINE poke #-}++sizeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Size (a i e)+sizeArray = VarSize $ \arr ->+ let bounds = A.bounds arr+ in getSize bounds ++ case size of+ ConstSize n -> n * A.rangeSize bounds+ VarSize f -> foldl' (\acc x -> acc + f x) 0 (A.elems arr)+{-# INLINE sizeArray #-}++pokeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => a i e -> Poke ()+pokeArray arr = do+ poke (A.bounds arr)+ forM_ (A.elems arr) poke+{-# INLINE pokeArray #-}++peekArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Peek (a i e)+peekArray = do+ bounds <- peek+ let len = A.rangeSize bounds+ elems <- replicateM len peek+ return (A.listArray bounds elems)+{-# INLINE peekArray #-} instance Store Integer where #if MIN_VERSION_integer_gmp(1,0,0)
src/Data/Store/Streaming.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-| Module: Data.Store.Streaming Description: A thin streaming layer that uses 'Store' for serialisation.@@ -13,6 +14,9 @@ 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.@@ -28,7 +32,7 @@ , conduitDecode ) where -import Control.Exception (assert)+import Control.Exception (assert, throwIO) import Control.Monad (liftM) import Control.Monad.IO.Class import Control.Monad.Trans.Resource (MonadResource)@@ -37,7 +41,9 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as C import Data.Store-import Data.Store.Impl (Peek (..), Poke (..), tooManyBytes, getSize)+import Data.Store.Impl (getSize)+import Data.Store.Core (Poke(..), tooManyBytes, decodeIOWithFromPtr)+import qualified Data.Text as T import Data.Word import Foreign.Ptr import qualified Foreign.Storable as Storable@@ -52,18 +58,30 @@ -- | Type used to store the length of a 'Message'. type SizeTag = Int -tagLength :: Int-tagLength = Storable.sizeOf (undefined :: SizeTag)-{-# INLINE tagLength #-}+-- | 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 = magicLength + sizeTagLength+ -- | Encode a 'Message' to a 'ByteString'. encodeMessage :: Store a => Message a -> ByteString encodeMessage (Message x) = let l = getSize x- totalLength = tagLength + l+ totalLength = headerLength + l in BS.unsafeCreate totalLength- (\p -> do (offset, ()) <- runPoke (poke l >> poke x) p 0+ (\p -> do (offset, ()) <- runPoke (do poke messageMagic+ poke l+ poke x+ ) p 0 assert (offset == totalLength) (return ())) {-# INLINE encodeMessage #-} @@ -81,16 +99,24 @@ >> peekSized bb n) {-# INLINE peekSized #-} --- | Decode a 'SizeTag' from a 'ByteBuffer'.-peekSizeTag :: MonadIO m => ByteBuffer -> m (PeekMessage m SizeTag)-peekSizeTag bb = peekSized bb tagLength-{-# INLINE peekSizeTag #-}+-- | Decode a header (magic number and 'SizeTag') from a 'ByteBuffer'.+peekMessageHeader :: MonadIO m => ByteBuffer -> m (PeekMessage m SizeTag)+peekMessageHeader bb = do+ available <- BB.availableBytes bb+ if available < headerLength+ then return $ NeedMoreInput (\bs -> BB.copyByteString bb bs+ >> peekMessageHeader bb)+ else peekSized bb magicLength >>= \case+ Done (Message x) | x == messageMagic -> peekSized bb sizeTagLength+ Done (Message x) -> liftIO . throwIO $ PeekException 0 . T.pack $ "Wrong message magic, " ++ show x+ NeedMoreInput _ -> fail "Internal error in peekMessageHeader."+{-# INLINE peekMessageHeader #-} -- | Decode some 'Message' from a 'ByteBuffer', by first reading its--- size, and then the actual 'Message'.+-- header, and then the actual 'Message'. peekMessage :: (MonadIO m, Store a) => ByteBuffer -> m (PeekMessage m a) peekMessage bb =- peekSizeTag bb >>= \case+ peekMessageHeader bb >>= \case (Done (Message n)) -> peekSized bb n NeedMoreInput _ -> return $ NeedMoreInput (\ bs -> BB.copyByteString bb bs@@ -107,24 +133,24 @@ decodeMessage :: (MonadIO m, Store a) => ByteBuffer -> m (Maybe ByteString) -> m (Maybe (Message a)) decodeMessage bb getBs =- decodeSizeTag bb getBs >>= \case+ decodeHeader bb getBs >>= \case Nothing -> return Nothing Just n -> decodeSized bb getBs n {-# INLINE decodeMessage #-} -decodeSizeTag :: MonadIO m+decodeHeader :: MonadIO m => ByteBuffer -> m (Maybe ByteString) -> m (Maybe SizeTag)-decodeSizeTag bb getBs =- peekSizeTag bb >>= \case+decodeHeader bb getBs =+ peekMessageHeader bb >>= \case (Done (Message n)) -> return (Just n) (NeedMoreInput _) -> getBs >>= \case- Just bs -> BB.copyByteString bb bs >> decodeSizeTag bb getBs+ Just bs -> BB.copyByteString bb bs >> decodeHeader bb getBs Nothing -> BB.availableBytes bb >>= \case 0 -> return Nothing- n -> liftIO $ tooManyBytes tagLength n "Data.Store.Message.SizeTag"-{-# INLINE decodeSizeTag #-}+ n -> liftIO $ tooManyBytes headerLength n "Data.Store.Message.SizeTag"+{-# INLINE decodeHeader #-} decodeSized :: (MonadIO m, Store a) => ByteBuffer@@ -143,8 +169,7 @@ -- | 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 (liftM snd $ runPeek peek (ptr `plusPtr` n) ptr)+decodeFromPtr ptr n = liftIO $ decodeIOWithFromPtr peek ptr n {-# INLINE decodeFromPtr #-} -- | Conduit for encoding 'Message's to 'ByteString's.
src/Data/Store/TH/Internal.hs view
@@ -30,6 +30,7 @@ import Data.Maybe (fromMaybe) import Data.Primitive.ByteArray import Data.Primitive.Types+import Data.Store.Core import Data.Store.Impl import qualified Data.Text as T import Data.Traversable (forM)
src/Data/Store/TypeHash/Internal.hs view
@@ -25,7 +25,6 @@ import Data.Store.Internal import Data.Typeable (Typeable) import GHC.Generics (Generic)-import Instances.TH.Lift () import Language.Haskell.TH import Language.Haskell.TH.ReifyMany (reifyMany) import Language.Haskell.TH.Syntax (Lift(lift))@@ -58,7 +57,7 @@ instance NFData TypeHash instance Lift TypeHash where- lift = liftStaticSize [t| BS.ByteString |] . unTypeHash+ lift = staticByteStringExp . unStaticSize . unTypeHash -- TODO: move into th-reify-many reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name]))@@ -79,21 +78,21 @@ -- Not only does this cover the datatypes themselves, but also all -- transitive dependencies. ----- The resulting expression is a literal of type 'Int'.+-- The resulting expression is a literal of type 'TypeHash'. typeHashForNames :: [Name] -> Q Exp typeHashForNames ns = do infos <- getTypeInfosRecursively ns- [| TypeHash (BS.pack $(lift (BS.unpack (SHA1.hash (encode infos))))) |]+ [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |] -- | At compiletime, this yields a cryptographic hash of the specified 'Type', -- including the definition of things it references (transitively). ----- The resulting expression is a literal of type 'Int'.+-- The resulting expression is a literal of type 'TypeHash'. hashOfType :: Type -> Q Exp hashOfType ty = do unless (null (getVarNames ty)) $ fail $ "hashOfType cannot handle polymorphic type " <> pprint ty infos <- getTypeInfosRecursively (getConNames ty)- lift $ TypeHash $ toStaticSizeEx $ SHA1.hash $ encode (ty, infos)+ [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |] getTypeInfosRecursively :: [Name] -> Q [(Name, Info)] getTypeInfosRecursively names = do@@ -117,7 +116,7 @@ mkHasTypeHash :: Type -> Q [Dec] mkHasTypeHash ty = [d| instance HasTypeHash $(return ty) where- typeHash _ = TypeHash $(hashOfType ty)+ typeHash _ = $(hashOfType ty) |] mkManyHasTypeHash :: [Q Type] -> Q [Dec]
store.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: store-version: 0.1.0.1+version: 0.2.0.0 synopsis: Fast binary serialization homepage: https://github.com/fpco/store#readme bug-reports: https://github.com/fpco/store/issues@@ -46,139 +46,198 @@ other-modules: Data.Store.Impl build-depends:- base >= 4.7 && < 5- , array- , base-orphans- , bytestring- , containers- , cryptohash- , deepseq- , fail- , ghc-prim- , hashable- , hspec- , hspec-smallcheck- , integer-gmp- , mono-traversable- , primitive- , safe- , smallcheck- , syb- , template-haskell- , text- , th-lift- , th-lift-instances >= 0.1.6- , th-utilities >= 0.1.1.0- , th-reify-many- , time- , transformers- , unordered-containers- , vector- , conduit- , lifted-base- , monad-control- , resourcet- , semigroups- , void- , th-orphans+ base >=4.7 && <5+ , store-core >=0.2 && <0.3+ , th-utilities >=0.1.1.0+ , primitive >=0.6+ , th-reify-many >=0.1.6+ , array >=0.5.0.0+ , base-orphans >=0.4.3+ , bytestring >=0.10.4.0+ , conduit >=1.2.3.1+ , containers >=0.5.5.1+ , cryptohash >=0.11.6+ , deepseq >=1.3.0.2+ , fail >=4.9.0.0+ , 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+ , resourcet >=1.1.3.3+ , safe >=0.3.8+ , semigroups >=0.8+ , smallcheck >=1.1.1+ , 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+ , transformers >=0.3.0.0+ , unordered-containers >=0.2.5.1+ , vector >=0.10.12.3+ , void >=0.5.11+ if (!arch(I386) && !arch(X86_64) && !arch(IA64) && !impl(ghcjs))+ buildable: False default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 test-suite store-test type: exitcode-stdio-1.0+ main-is: Spec.hs hs-source-dirs: test- main-is: Spec.hs+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , store-core >=0.2 && <0.3+ , th-utilities >=0.1.1.0+ , primitive >=0.6+ , th-reify-many >=0.1.6+ , array >=0.5.0.0+ , base-orphans >=0.4.3+ , bytestring >=0.10.4.0+ , conduit >=1.2.3.1+ , containers >=0.5.5.1+ , cryptohash >=0.11.6+ , deepseq >=1.3.0.2+ , fail >=4.9.0.0+ , 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+ , resourcet >=1.1.3.3+ , safe >=0.3.8+ , semigroups >=0.8+ , smallcheck >=1.1.1+ , 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+ , transformers >=0.3.0.0+ , unordered-containers >=0.2.5.1+ , vector >=0.10.12.3+ , void >=0.5.11+ , store other-modules: Data.Store.StreamingSpec Data.StoreSpec Data.StoreSpec.TH System.IO.ByteBufferSpec+ default-language: Haskell2010++test-suite store-weigh+ type: exitcode-stdio-1.0+ main-is: Allocations.hs+ 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 build-depends:- base >= 4.7 && < 5- , array- , base-orphans- , bytestring- , containers- , cryptohash- , deepseq- , fail- , ghc-prim- , hashable- , hspec- , hspec-smallcheck- , integer-gmp- , mono-traversable- , primitive- , safe- , smallcheck- , syb- , template-haskell- , text- , th-lift- , th-lift-instances >= 0.1.6- , th-utilities >= 0.1.1.0- , th-reify-many- , time- , transformers- , unordered-containers- , vector- , conduit- , lifted-base- , monad-control- , resourcet- , semigroups- , void- , th-orphans- , hspec- , smallcheck- , hspec-smallcheck+ base >=4.7 && <5+ , store-core >=0.2 && <0.3+ , th-utilities >=0.1.1.0+ , primitive >=0.6+ , th-reify-many >=0.1.6+ , array >=0.5.0.0+ , base-orphans >=0.4.3+ , bytestring >=0.10.4.0+ , conduit >=1.2.3.1+ , containers >=0.5.5.1+ , cryptohash >=0.11.6+ , deepseq >=1.3.0.2+ , fail >=4.9.0.0+ , 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+ , resourcet >=1.1.3.3+ , safe >=0.3.8+ , semigroups >=0.8+ , smallcheck >=1.1.1+ , 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+ , transformers >=0.3.0.0+ , unordered-containers >=0.2.5.1+ , vector >=0.10.12.3+ , void >=0.5.11 , store- ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N+ , weigh+ , criterion+ , cereal+ , cereal-vector+ , vector-binary-instances+ other-modules:+ Data.Store.StreamingSpec+ Data.StoreSpec+ Data.StoreSpec.TH+ Spec+ System.IO.ByteBufferSpec default-language: Haskell2010 benchmark store-bench type: exitcode-stdio-1.0+ main-is: Bench.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- main-is: Bench.hs build-depends:- base >= 4.7 && < 5- , array- , base-orphans- , bytestring- , containers- , cryptohash- , deepseq- , fail- , ghc-prim- , hashable- , hspec- , hspec-smallcheck- , integer-gmp- , mono-traversable- , primitive- , safe- , smallcheck- , syb- , template-haskell- , text- , th-lift- , th-lift-instances >= 0.1.6- , th-utilities >= 0.1.1.0- , th-reify-many- , time- , transformers- , unordered-containers- , vector- , conduit- , lifted-base- , monad-control- , resourcet- , semigroups- , void- , th-orphans+ base >=4.7 && <5+ , store-core >=0.2 && <0.3+ , th-utilities >=0.1.1.0+ , primitive >=0.6+ , th-reify-many >=0.1.6+ , array >=0.5.0.0+ , base-orphans >=0.4.3+ , bytestring >=0.10.4.0+ , conduit >=1.2.3.1+ , containers >=0.5.5.1+ , cryptohash >=0.11.6+ , deepseq >=1.3.0.2+ , fail >=4.9.0.0+ , 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+ , resourcet >=1.1.3.3+ , safe >=0.3.8+ , semigroups >=0.8+ , smallcheck >=1.1.1+ , 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+ , transformers >=0.3.0.0+ , unordered-containers >=0.2.5.1+ , vector >=0.10.12.3+ , void >=0.5.11 , criterion , store if flag(comparison-bench)
+ test/Allocations.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++-- | Weigh Store's operations.++module Main where++import Control.DeepSeq+import Data.List+import qualified Data.Serialize as Cereal+import qualified Data.Store as Store+import qualified Data.Vector as Boxed+import qualified Data.Vector.Serialize ()+import qualified Data.Vector.Storable as Storable+import Text.Printf+import Weigh++-- | Main entry point.+main :: IO ()+main =+ mainWith encoding++-- | Weigh encoding with Store vs Cereal.+encoding :: Weigh ()+encoding =+ do fortype "[Int]" (\n -> replicate n 0 :: [Int])+ fortype "Boxed Vector Int" (\n -> Boxed.replicate n 0 :: Boxed.Vector Int)+ fortype "Storable Vector Int"+ (\n -> Storable.replicate n 0 :: Storable.Vector Int)+ where fortype label make =+ scale (\(n,nstr) ->+ do let title :: String -> String+ title for = printf "%12s %-20s %s" nstr (label :: String) for+ action (title "Allocate")+ (return (make n))+ action (title "Encode: Store")+ (return (Store.encode (force (make n))))+ action (title "Encode: Cereal")+ (return (Cereal.encode (force (make n)))))+ scale func =+ mapM_ func+ (map (\x -> (x,commas x))+ [1000000,2000000,10000000])
test/Data/Store/StreamingSpec.hs view
@@ -2,14 +2,18 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Store.StreamingSpec where +import Control.Exception (try)+import Control.Monad (void) import Control.Monad.Trans.Resource-import Control.Exception (try) import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS import Data.Conduit ((=$=), ($$)) import qualified Data.Conduit.List as C+import Data.Int import Data.List (unfoldr) import Data.Monoid-import Data.Store (PeekException (..))+import Data.Store.Core (Poke(..))+import Data.Store.Internal import Data.Store.Streaming import qualified System.IO.ByteBuffer as BB import Test.Hspec@@ -24,11 +28,14 @@ it "Throws an Exception on incomplete messages." conduitIncomplete it "Throws an Exception on excess input." $ property conduitExcess describe "peekMessage" $ do- it "demands more input when needed." $ property (askMore 8)- it "demands more input on incomplete SizeTag." $ property (askMore 1)- it "successfully decodes valid input." $ property peek- describe "decodeMessage" $+ it "demands more input when needed." $ property (askMore 17)+ it "demands more input on incomplete message magic." $ property (askMore 1)+ it "demands more input on incomplete SizeTag." $ property (askMore 9)+ it "successfully decodes valid input." $ property canPeek+ describe "decodeMessage" $ do it "Throws an Exception on incomplete messages." decodeIncomplete+ it "Throws an Exception on messages that are shorter than indicated." decodeTooShort+ it "Throws an Exception on messages that are longer than indicated." decodeTooLong roundtrip :: [Int] -> Property IO roundtrip xs = monadic $ do@@ -65,7 +72,7 @@ (runResourceT (C.sourceList [incompleteInput] =$= conduitDecode (Just 10) $$ C.consume)- :: IO [Message Integer]) `shouldThrow` peekException+ :: IO [Message Integer]) `shouldThrow` \PeekException{} -> True conduitExcess :: [Int] -> Property IO conduitExcess xs = monadic $ do@@ -97,8 +104,8 @@ _ -> return False _ -> return False -peek :: Integer -> Property IO-peek x = monadic $ BB.with (Just 10) $ \ bb -> do+canPeek :: Integer -> Property IO+canPeek x = monadic $ BB.with (Just 10) $ \ bb -> do let bs = encodeMessage (Message x) BB.copyByteString bb bs peekResult <- peekMessage bb :: IO (PeekMessage IO Integer)@@ -110,12 +117,37 @@ decodeIncomplete = BB.with (Just 0) $ \ bb -> do BB.copyByteString bb (BS.take 1 incompleteInput) (decodeMessage bb (return Nothing) :: IO (Maybe (Message Integer)))- `shouldThrow` peekException+ `shouldThrow` \PeekException{} -> True incompleteInput :: BS.ByteString incompleteInput = let bs = encodeMessage (Message (42 :: Integer)) in BS.take (BS.length bs - 1) bs -peekException :: Selector PeekException-peekException = const True+decodeTooLong :: IO ()+decodeTooLong = BB.with Nothing $ \bb -> do+ BB.copyByteString bb (encodeMessageTooLong . Message $ (1 :: Int))+ (decodeMessage bb (return Nothing) :: IO (Maybe (Message Int)))+ `shouldThrow` \PeekException{} -> True++decodeTooShort :: IO ()+decodeTooShort = BB.with Nothing $ \bb -> do+ BB.copyByteString bb (encodeMessageTooShort . Message $ (1 :: Int))+ (decodeMessage bb (return Nothing) :: IO (Maybe (Message Int)))+ `shouldThrow` (== PeekException 8 "Attempted to read too many bytes for Data.Store.Message.SizeTag. Needed 16, but only 8 remain.")++encodeMessageTooLong :: Store a => Message a -> BS.ByteString+encodeMessageTooLong (Message x) =+ let l = 8 + getSize x+ totalLength = 8 + l+ in BS.unsafeCreate+ totalLength+ (\p -> void $ runPoke (poke l >> poke x >> poke (0::Int64)) p 0)++encodeMessageTooShort :: Store a => Message a -> BS.ByteString+encodeMessageTooShort (Message x) =+ let l = 0+ totalLength = 8 + l+ in BS.unsafeCreate+ totalLength+ (\p -> void $ runPoke (poke l >> poke x) p 0)
test/Data/StoreSpec.hs view
@@ -8,10 +8,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Data.StoreSpec where import Control.Applicative+import Control.Exception (evaluate) import Control.Monad (unless)+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@@ -27,6 +30,7 @@ import Data.Map (Map) import Data.Monoid import Data.Primitive.Types (Addr)+import Data.Proxy (Proxy(..)) import Data.Sequence (Seq) import Data.Sequences (fromList) import Data.Set (Set)@@ -39,6 +43,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time 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@@ -65,7 +70,7 @@ -- 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, Num a) => [a] -> [a]+addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++ (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs)@@ -174,6 +179,16 @@ instance (Monad m, Serial m a, Hashable a, Eq a) => Serial m (HashSet a) where series = fmap setFromList series +instance (Monad m, A.Ix i, Serial m i, Serial m e) => Serial m (A.Array i e) where+ series = seriesArray++instance (Monad m, A.IArray A.UArray e, A.Ix i, Serial m i, Serial m e) => Serial m (A.UArray i e) where+ series = seriesArray++seriesArray :: (Monad m, A.Ix i, A.IArray a e, Serial m i, Serial m e) => Series m (a i e)+seriesArray = cons2 $ \bounds (NonEmpty xs) ->+ A.listArray bounds (take (A.rangeSize bounds) (cycle xs))+ instance Monad m => Serial m Time.Day where series = Time.ModifiedJulianDay <$> series @@ -191,8 +206,10 @@ 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 ------------------------------------------------------------------------ -- Test datatypes for generics support@@ -212,6 +229,20 @@ instance Monad m => Serial m X instance Store X ++-- Datatypes with faulty instances+newtype BadIdea = BadIdea Int64+instance Store BadIdea where+ poke (BadIdea x) = poke x+ peek = BadIdea <$> peek+ size = ConstSize 1 -- too small++newtype BadIdea2 = BadIdea2 Int64+instance Store BadIdea2 where+ poke (BadIdea2 x) = poke x+ peek = BadIdea2 <$> peek+ size = ConstSize 12 -- too large+ spec :: Spec spec = do describe "Store on all monomorphic instances"@@ -228,6 +259,25 @@ ] let f ty = isMonoType ty && ty `notElem` omitTys smallcheckManyStore verbose 2 . map return . filter f $ insts)+ 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 ()+ testNonNumeric _proxy = do+ assertRoundtrip verbose ((1/0) :: a)+ assertRoundtrip verbose ((-1/0) :: a)+ -- -0 == 0, so we check if the infinity sign is the same+ case decode (encode ((-0) :: a)) of+ Right (x :: a) -> unless (-1/0 == 1/x) (fail "Could not roundtrip negative 0")+ _ -> fail "Could not roundtrip negative 0"+ assertRoundtrip verbose ((-0) :: a)+ -- 0/0 /= 0/0, so we check for NaN explicitly+ case decode (encode ((0/0) :: a)) of+ Right (x :: a) -> unless (isNaN x) (fail "Could not roundtrip NaN")+ _ -> fail "Could not roundtrip NaN"+ testNonNumeric (Proxy :: Proxy Double)+ testNonNumeric (Proxy :: Proxy Float)+ testNonNumeric (Proxy :: Proxy CDouble)+ testNonNumeric (Proxy :: Proxy CFloat)+ (return () :: IO ()) describe "Store on all custom generic instances" $(smallcheckManyStore verbose 2 [ [t| Test |]@@ -279,6 +329,8 @@ , [t| NE.NonEmpty Int8 |] , [t| NE.NonEmpty Int64 |] , [t| Tagged Int32 |]+ , [t| A.Array (Int, Integer) Integer |]+ , [t| A.UArray Char Bool |] ]) it "Slices roundtrip" $ do assertRoundtrip False $ T.drop 3 $ T.take 3 "Hello world!"@@ -302,3 +354,9 @@ mapM_ putStrLn $(do insts <- getAllInstanceTypes1 ''Store lift $ map pprint $ filter (not . isMonoType) insts)+ it "Faulty implementations of size lead to PokeExceptions" $ do+ evaluate (encode (BadIdea 0)) `shouldThrow` isPokeException+ evaluate (encode (BadIdea2 0)) `shouldThrow` isPokeException++isPokeException :: Test.Hspec.Selector PokeException+isPokeException = const True