diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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`. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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 diff --git a/src/Data/Store/Impl.hs b/src/Data/Store/Impl.hs --- a/src/Data/Store/Impl.hs +++ b/src/Data/Store/Impl.hs @@ -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, () #)) diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -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) diff --git a/src/Data/Store/Streaming.hs b/src/Data/Store/Streaming.hs --- a/src/Data/Store/Streaming.hs +++ b/src/Data/Store/Streaming.hs @@ -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. diff --git a/src/Data/Store/TH/Internal.hs b/src/Data/Store/TH/Internal.hs --- a/src/Data/Store/TH/Internal.hs +++ b/src/Data/Store/TH/Internal.hs @@ -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) diff --git a/src/Data/Store/TypeHash/Internal.hs b/src/Data/Store/TypeHash/Internal.hs --- a/src/Data/Store/TypeHash/Internal.hs +++ b/src/Data/Store/TypeHash/Internal.hs @@ -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] diff --git a/store.cabal b/store.cabal --- a/store.cabal +++ b/store.cabal @@ -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) diff --git a/test/Allocations.hs b/test/Allocations.hs new file mode 100644 --- /dev/null +++ b/test/Allocations.hs @@ -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]) diff --git a/test/Data/Store/StreamingSpec.hs b/test/Data/Store/StreamingSpec.hs --- a/test/Data/Store/StreamingSpec.hs +++ b/test/Data/Store/StreamingSpec.hs @@ -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) diff --git a/test/Data/StoreSpec.hs b/test/Data/StoreSpec.hs --- a/test/Data/StoreSpec.hs +++ b/test/Data/StoreSpec.hs @@ -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