Hello community, here is the log from the commit of package ghc-store for openSUSE:Factory checked in at 2018-07-24 17:22:04 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-store (Old) and /work/SRC/openSUSE:Factory/.ghc-store.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-store" Tue Jul 24 17:22:04 2018 rev:4 rq:623860 version:0.5.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-store/ghc-store.changes 2018-05-30 12:27:19.734231607 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-store.new/ghc-store.changes 2018-07-24 17:22:04.743276454 +0200 @@ -1,0 +2,12 @@ +Wed Jul 18 14:26:41 UTC 2018 - [email protected] + +- Cosmetic: replace tabs with blanks, strip trailing white space, + and update copyright headers with spec-cleaner. + +------------------------------------------------------------------- +Fri Jul 13 14:31:43 UTC 2018 - [email protected] + +- Update store to version 0.5.0. + * `Data.Store.Streaming` moved to a separate package, `store-streaming`. + +------------------------------------------------------------------- @@ -31 +42,0 @@ - Old: ---- store-0.4.3.2.tar.gz New: ---- store-0.5.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-store.spec ++++++ --- /var/tmp/diff_new_pack.9EIrDR/_old 2018-07-24 17:22:05.159276985 +0200 +++ /var/tmp/diff_new_pack.9EIrDR/_new 2018-07-24 17:22:05.159276985 +0200 @@ -19,7 +19,7 @@ %global pkg_name store %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.3.2 +Version: 0.5.0 Release: 0 Summary: Fast binary serialization License: MIT @@ -31,8 +31,8 @@ BuildRequires: ghc-async-devel BuildRequires: ghc-base-orphans-devel BuildRequires: ghc-base64-bytestring-devel +BuildRequires: ghc-bifunctors-devel BuildRequires: ghc-bytestring-devel -BuildRequires: ghc-conduit-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-contravariant-devel BuildRequires: ghc-cryptohash-devel @@ -54,7 +54,6 @@ BuildRequires: ghc-semigroups-devel BuildRequires: ghc-smallcheck-devel BuildRequires: ghc-store-core-devel -BuildRequires: ghc-streaming-commons-devel BuildRequires: ghc-syb-devel BuildRequires: ghc-template-haskell-devel BuildRequires: ghc-text-devel ++++++ store-0.4.3.2.tar.gz -> store-0.5.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/ChangeLog.md new/store-0.5.0/ChangeLog.md --- old/store-0.4.3.2/ChangeLog.md 2017-08-31 22:39:28.000000000 +0200 +++ new/store-0.5.0/ChangeLog.md 2018-06-01 23:11:47.000000000 +0200 @@ -1,9 +1,15 @@ # ChangeLog +## 0.5.0 + +* `Data.Store.Streaming` moved to a separate package, `store-streaming`. + ## 0.4.3.2 * Buildable with GHC 8.2 +* Fix to haddock formatting of Data.Store.TH code example + ## 0.4.3.1 * Fixed compilation on GHC 7.8 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/README.md new/store-0.5.0/README.md --- old/store-0.4.3.2/README.md 2017-06-07 10:29:25.000000000 +0200 +++ new/store-0.5.0/README.md 2018-05-31 06:35:48.000000000 +0200 @@ -33,6 +33,9 @@ * TH generation of testcases. +* Utilities for streaming encoding / decoding of Store encoded messages, via the + `store-streaming` package. + ## Blog posts * [Initial release announcement](https://www.fpcomplete.com/blog/2016/05/store-package) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/src/Data/Store/Streaming/Internal.hs new/store-0.5.0/src/Data/Store/Streaming/Internal.hs --- old/store-0.4.3.2/src/Data/Store/Streaming/Internal.hs 2016-11-16 23:02:06.000000000 +0100 +++ new/store-0.5.0/src/Data/Store/Streaming/Internal.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,26 +0,0 @@ -module Data.Store.Streaming.Internal - ( messageMagic - , magicLength - , sizeTagLength - , headerLength - , SizeTag - ) where - -import Data.Word (Word64) -import qualified Foreign.Storable as Storable - --- | Type used to store the length of a 'Message'. -type SizeTag = Int - --- | Some fixed arbitrary magic number that precedes every 'Message'. -messageMagic :: Word64 -messageMagic = 18205256374652458875 - -magicLength :: Int -magicLength = Storable.sizeOf messageMagic - -sizeTagLength :: Int -sizeTagLength = Storable.sizeOf (undefined :: SizeTag) - -headerLength :: Int -headerLength = sizeTagLength + magicLength \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/src/Data/Store/Streaming.hs new/store-0.5.0/src/Data/Store/Streaming.hs --- old/store-0.4.3.2/src/Data/Store/Streaming.hs 2017-06-07 10:29:25.000000000 +0200 +++ new/store-0.5.0/src/Data/Store/Streaming.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,223 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-| -Module: Data.Store.Streaming -Description: A thin streaming layer that uses 'Store' for serialisation. - -For efficiency reasons, 'Store' does not provide facilities for -incrementally consuming input. In order to avoid partial input, this -module introduces 'Message's that wrap values of instances of 'Store'. - -In addition to the serialisation of a value, the serialised message -also contains the length of the serialisation. This way, instead of -consuming input incrementally, more input can be demanded before -serialisation is attempted in the first place. - -Each message starts with a fixed magic number, in order to detect -(randomly) invalid data. - --} -module Data.Store.Streaming - ( -- * 'Message's to stream data using 'Store' for serialisation. - Message (..) - -- * Encoding 'Message's - , encodeMessage - -- * Decoding 'Message's - , PeekMessage - , FillByteBuffer - , peekMessage - , decodeMessage - , peekMessageBS - , decodeMessageBS -#ifndef mingw32_HOST_OS - , ReadMoreData(..) - , peekMessageFd - , decodeMessageFd -#endif - -- * Conduits for encoding and decoding - , conduitEncode - , conduitDecode - ) where - -import Control.Exception (throwIO) -import Control.Monad (unless) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource (MonadResource) -import Data.ByteString (ByteString) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as C -import Data.Store -import Data.Store.Impl (getSize) -import Data.Store.Core (decodeIOWithFromPtr, unsafeEncodeWith) -import qualified Data.Text as T -import Data.Word -import Foreign.Ptr -import Prelude -import System.IO.ByteBuffer (ByteBuffer) -import qualified System.IO.ByteBuffer as BB -import Control.Monad.Trans.Free.Church (FT, iterTM, wrap) -import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) -import Control.Monad.Trans.Class (lift) -import System.Posix.Types (Fd(..)) -import GHC.Conc (threadWaitRead) -import Data.Store.Streaming.Internal - --- | If @a@ is an instance of 'Store', @Message a@ can be serialised --- and deserialised in a streaming fashion. -newtype Message a = Message { fromMessage :: a } deriving (Eq, Show) - --- | Encode a 'Message' to a 'ByteString'. -encodeMessage :: Store a => Message a -> ByteString -encodeMessage (Message x) = - unsafeEncodeWith pokeFunc totalLength - where - bodyLength = getSize x - totalLength = headerLength + bodyLength - pokeFunc = do - poke messageMagic - poke bodyLength - poke x - --- | The result of peeking at the next message can either be a --- successfully deserialised object, or a request for more input. -type PeekMessage i m a = FT ((->) i) m a - -needMoreInput :: PeekMessage i m i -needMoreInput = wrap return - --- | Given some sort of input, fills the 'ByteBuffer' with it. --- --- The 'Int' is how many bytes we'd like: this is useful when the filling --- function is 'fillFromFd', where we can specify a max size. -type FillByteBuffer i m = ByteBuffer -> Int -> i -> m () - --- | Decode a value, given a 'Ptr' and the number of bytes that make --- up the encoded message. -decodeFromPtr :: (MonadIO m, Store a) => Ptr Word8 -> Int -> m a -decodeFromPtr ptr n = liftIO $ decodeIOWithFromPtr peek ptr n - -peekSized :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> Int -> PeekMessage i m a -peekSized fill bb n = go - where - go = do - mbPtr <- BB.unsafeConsume bb n - case mbPtr of - Left needed -> do - inp <- needMoreInput - lift (fill bb needed inp) - go - Right ptr -> decodeFromPtr ptr n - --- | Read and check the magic number from a 'ByteBuffer' -peekMessageMagic :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m () -peekMessageMagic fill bb = - peekSized fill bb magicLength >>= \case - mm | mm == messageMagic -> return () - mm -> liftIO . throwIO $ PeekException 0 . T.pack $ - "Wrong message magic, " ++ show mm - --- | Decode a 'SizeTag' from a 'ByteBuffer'. -peekMessageSizeTag :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m SizeTag -peekMessageSizeTag fill bb = peekSized fill bb sizeTagLength - --- | Decode some object from a 'ByteBuffer', by first reading its --- header, and then the actual data. -peekMessage :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m (Message a) -peekMessage fill bb = - fmap Message $ do - peekMessageMagic fill bb - peekMessageSizeTag fill bb >>= peekSized fill bb - --- | Decode a 'Message' from a 'ByteBuffer' and an action that can get --- additional inputs to refill the buffer when necessary. --- --- The only conditions under which this function will give 'Nothing', --- is when the 'ByteBuffer' contains zero bytes, and refilling yields --- 'Nothing'. If there is some data available, but not enough to --- decode the whole 'Message', a 'PeekException' will be thrown. -decodeMessage :: (Store a, MonadIO m) => FillByteBuffer i m -> ByteBuffer -> m (Maybe i) -> m (Maybe (Message a)) -decodeMessage fill bb getInp = - maybeDecode (peekMessageMagic fill bb) >>= \case - Just () -> maybeDecode (peekMessageSizeTag fill bb >>= peekSized fill bb) >>= \case - Just x -> return (Just (Message x)) - Nothing -> do - -- We have already read the message magic, so a failure to - -- read the whole message means we have an incomplete message. - available <- BB.availableBytes bb - liftIO $ throwIO $ PeekException available $ T.pack - "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message" - Nothing -> do - available <- BB.availableBytes bb - -- At this point, we have not consumed anything yet, so if bb is - -- empty, there simply was no message to read. - unless (available == 0) $ liftIO $ throwIO $ PeekException available $ T.pack - "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message" - return Nothing - where - maybeDecode m = runMaybeT (iterTM (\consumeInp -> consumeInp =<< MaybeT getInp) m) - --- | Decode some 'Message' from a 'ByteBuffer', by first reading its --- header, and then the actual 'Message'. -peekMessageBS :: (MonadIO m, Store a) => ByteBuffer -> PeekMessage ByteString m (Message a) -peekMessageBS = peekMessage (\bb _ bs -> BB.copyByteString bb bs) - -decodeMessageBS :: (MonadIO m, Store a) - => ByteBuffer -> m (Maybe ByteString) -> m (Maybe (Message a)) -decodeMessageBS = decodeMessage (\bb _ bs -> BB.copyByteString bb bs) - -#ifndef mingw32_HOST_OS - --- | We use this type as a more descriptive unit to signal that more input --- should be read from the Fd. --- --- This data-type is only available on POSIX systems (essentially, non-windows) -data ReadMoreData = ReadMoreData - deriving (Eq, Show) - --- | Peeks a message from a _non blocking_ 'Fd'. --- --- This function is only available on POSIX systems (essentially, non-windows) -peekMessageFd :: (MonadIO m, Store a) => ByteBuffer -> Fd -> PeekMessage ReadMoreData m (Message a) -peekMessageFd bb fd = - peekMessage (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb - --- | Decodes all the message using 'registerFd' to find out when a 'Socket' is --- ready for reading. --- --- This function is only available on POSIX systems (essentially, non-windows) -decodeMessageFd :: (MonadIO m, Store a) => ByteBuffer -> Fd -> m (Message a) -decodeMessageFd bb fd = do - mbMsg <- decodeMessage - (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb - (liftIO (threadWaitRead fd) >> return (Just ReadMoreData)) - case mbMsg of - Just msg -> return msg - Nothing -> liftIO (fail "decodeMessageFd: impossible: got Nothing") - -#endif - --- | Conduit for encoding 'Message's to 'ByteString's. -conduitEncode :: (Monad m, Store a) => C.Conduit (Message a) m ByteString -conduitEncode = C.map encodeMessage - --- | Conduit for decoding 'Message's from 'ByteString's. -conduitDecode :: (MonadResource m, Store a) - => Maybe Int - -- ^ Initial length of the 'ByteBuffer' used for - -- buffering the incoming 'ByteString's. If 'Nothing', - -- use the default value of 4MB. - -> C.Conduit ByteString m (Message a) -conduitDecode bufSize = - C.bracketP - (BB.new bufSize) - BB.free - go - where - go buffer = do - mmessage <- decodeMessageBS buffer C.await - case mmessage of - Nothing -> return () - Just message -> C.yield message >> go buffer diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/src/Data/Store.hs new/store-0.5.0/src/Data/Store.hs --- old/store-0.4.3.2/src/Data/Store.hs 2017-08-02 10:56:31.000000000 +0200 +++ new/store-0.5.0/src/Data/Store.hs 2018-05-31 06:35:48.000000000 +0200 @@ -7,6 +7,9 @@ -- There are some tradeoffs here - the generics instances do not require -- @-XTemplateHaskell@, but they do not optimize as well for sum types -- that only require a constant number of bytes. +-- +-- If you need streaming encode / decode of multiple store encoded +-- messages, take a look at the @store-streaming@ package. module Data.Store ( -- * Encoding and decoding strict ByteStrings. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/store.cabal new/store-0.5.0/store.cabal --- old/store-0.4.3.2/store.cabal 2017-08-31 22:39:28.000000000 +0200 +++ new/store-0.5.0/store.cabal 2018-06-01 23:18:05.000000000 +0200 @@ -1,9 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.18.1. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack +-- +-- hash: 7149f1b747c6c18109c5c6ed9bedf1a7ec37850d9a77cb9bd48cd686d3aafcd0 name: store -version: 0.4.3.2 +version: 0.5.0 synopsis: Fast binary serialization category: Serialization, Data homepage: https://github.com/fpco/store#readme @@ -14,7 +16,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: ChangeLog.md README.md @@ -32,25 +33,35 @@ default: False library + exposed-modules: + Data.Store + Data.Store.Internal + Data.Store.TH + Data.Store.TH.Internal + Data.Store.TypeHash + Data.Store.TypeHash.Internal + Data.Store.Version + System.IO.ByteBuffer + other-modules: + Data.Store.Impl hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 build-depends: - base >=4.7 && <5 - , store-core >=0.4 && <0.5 - , th-utilities >=0.2 - , primitive >=0.6 - , th-reify-many >=0.1.6 - , array >=0.5.0.0 + array >=0.5.0.0 + , async >=2.0.2 + , base >=4.7 && <5 , base-orphans >=0.4.3 - , base64-bytestring >= 0.1.1 + , base64-bytestring >=0.1.1 + , bifunctors >=4.0 , bytestring >=0.10.4.0 - , conduit >=1.2.3.1 , containers >=0.5.5.1 + , contravariant >=1.3 , cryptohash >=0.11.6 , deepseq >=1.3.0.2 - , directory >= 1.2 - , filepath >= 1.3 + , directory >=1.2 + , filepath >=1.3 + , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -59,63 +70,54 @@ , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 + , network >=2.6.0.2 + , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , semigroups >=0.8 , smallcheck >=1.1.1 + , store-core >=0.4 && <0.5 , 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 + , th-orphans >=0.12.2 + , th-reify-many >=0.1.6 + , th-utilities >=0.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 - , free >=4.11 - , network >=2.6.0.2 - , streaming-commons >=0.1.10.0 - , async >=2.0.2 - , contravariant >=1.3 - exposed-modules: - Data.Store - Data.Store.Internal - Data.Store.Streaming - Data.Store.Streaming.Internal - Data.Store.TH - Data.Store.TH.Internal - Data.Store.TypeHash - Data.Store.TypeHash.Internal - Data.Store.Version - System.IO.ByteBuffer - other-modules: - Data.Store.Impl default-language: Haskell2010 test-suite store-test type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + Data.Store.UntrustedSpec + Data.StoreSpec + Data.StoreSpec.TH + System.IO.ByteBufferSpec hs-source-dirs: test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 - , store-core >=0.4 && <0.5 - , th-utilities >=0.2 - , primitive >=0.6 - , th-reify-many >=0.1.6 - , array >=0.5.0.0 + array >=0.5.0.0 + , async >=2.0.2 + , base >=4.7 && <5 , base-orphans >=0.4.3 - , base64-bytestring >= 0.1.1 + , base64-bytestring >=0.1.1 + , bifunctors >=4.0 , bytestring >=0.10.4.0 - , conduit >=1.2.3.1 , containers >=0.5.5.1 + , contravariant >=1.3 , cryptohash >=0.11.6 , deepseq >=1.3.0.2 - , directory >= 1.2 - , filepath >= 1.3 + , directory >=1.2 + , filepath >=1.3 + , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -124,32 +126,27 @@ , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 + , network >=2.6.0.2 + , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , semigroups >=0.8 , smallcheck >=1.1.1 + , store + , store-core >=0.4 && <0.5 , 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 + , th-orphans >=0.12.2 + , th-reify-many >=0.1.6 + , th-utilities >=0.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 - , free >=4.11 - , network >=2.6.0.2 - , streaming-commons >=0.1.10.0 - , async >=2.0.2 - , contravariant >=1.3 - , store - other-modules: - Data.Store.StreamingSpec - Data.StoreSpec - Data.StoreSpec.TH - System.IO.ByteBufferSpec default-language: Haskell2010 test-suite store-weigh @@ -159,21 +156,23 @@ test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2 build-depends: - base >=4.7 && <5 - , store-core >=0.4 && <0.5 - , th-utilities >=0.2 - , primitive >=0.6 - , th-reify-many >=0.1.6 - , array >=0.5.0.0 + array >=0.5.0.0 + , async >=2.0.2 + , base >=4.7 && <5 , base-orphans >=0.4.3 - , base64-bytestring >= 0.1.1 + , base64-bytestring >=0.1.1 + , bifunctors >=4.0 , bytestring >=0.10.4.0 - , conduit >=1.2.3.1 + , cereal + , cereal-vector , containers >=0.5.5.1 + , contravariant >=1.3 + , criterion , cryptohash >=0.11.6 , deepseq >=1.3.0.2 - , directory >= 1.2 - , filepath >= 1.3 + , directory >=1.2 + , filepath >=1.3 + , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -182,56 +181,55 @@ , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 + , network >=2.6.0.2 + , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , semigroups >=0.8 , smallcheck >=1.1.1 + , store + , store-core >=0.4 && <0.5 , 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 + , th-orphans >=0.12.2 + , th-reify-many >=0.1.6 + , th-utilities >=0.2 , time >=1.4.2 , transformers >=0.3.0.0 , unordered-containers >=0.2.5.1 , vector >=0.10.12.3 + , vector-binary-instances , void >=0.5.11 - , free >=4.11 - , network >=2.6.0.2 - , streaming-commons >=0.1.10.0 - , async >=2.0.2 - , contravariant >=1.3 - , store , weigh - , criterion - , cereal - , cereal-vector - , vector-binary-instances default-language: Haskell2010 benchmark store-bench type: exitcode-stdio-1.0 main-is: Bench.hs + other-modules: + Paths_store 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 build-depends: - base >=4.7 && <5 - , store-core >=0.4 && <0.5 - , th-utilities >=0.2 - , primitive >=0.6 - , th-reify-many >=0.1.6 - , array >=0.5.0.0 + array >=0.5.0.0 + , async >=2.0.2 + , base >=4.7 && <5 , base-orphans >=0.4.3 - , base64-bytestring >= 0.1.1 + , base64-bytestring >=0.1.1 + , bifunctors >=4.0 , bytestring >=0.10.4.0 - , conduit >=1.2.3.1 , containers >=0.5.5.1 + , contravariant >=1.3 + , criterion , cryptohash >=0.11.6 , deepseq >=1.3.0.2 - , directory >= 1.2 - , filepath >= 1.3 + , directory >=1.2 + , filepath >=1.3 + , free >=4.11 , ghc-prim >=0.3.1.0 , hashable >=1.2.3.1 , hspec >=2.1.2 @@ -240,35 +238,34 @@ , lifted-base >=0.2.3.3 , monad-control >=0.3.3.0 , mono-traversable >=0.7.0 + , network >=2.6.0.2 + , primitive >=0.6 , resourcet >=1.1.3.3 , safe >=0.3.8 , semigroups >=0.8 , smallcheck >=1.1.1 + , store + , store-core >=0.4 && <0.5 , 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 + , th-orphans >=0.12.2 + , th-reify-many >=0.1.6 + , th-utilities >=0.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 - , free >=4.11 - , network >=2.6.0.2 - , streaming-commons >=0.1.10.0 - , async >=2.0.2 - , contravariant >=1.3 - , criterion - , store if flag(comparison-bench) cpp-options: -DCOMPARISON_BENCH build-depends: - cereal - , binary - , vector-binary-instances + binary + , cereal , cereal-vector + , vector-binary-instances if flag(small-bench) cpp-options: -DSMALL_BENCH default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/test/Data/Store/StreamingSpec.hs new/store-0.5.0/test/Data/Store/StreamingSpec.hs --- old/store-0.4.3.2/test/Data/Store/StreamingSpec.hs 2017-08-25 09:47:51.000000000 +0200 +++ new/store-0.5.0/test/Data/Store/StreamingSpec.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,206 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Data.Store.StreamingSpec where - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race, concurrently) -import Control.Concurrent.MVar -import Control.Exception (try) -import Control.Monad (void, (<=<), forM_) -import Control.Monad.Trans.Free (runFreeT, FreeF(..)) -import Control.Monad.Trans.Free.Church (fromFT) -import Control.Monad.Trans.Resource -import qualified Data.ByteString as BS -import Data.Conduit ((=$=), ($$)) -import qualified Data.Conduit.List as C -import Data.List (unfoldr) -import Data.Monoid -import Data.Store.Internal -import Data.Store.Streaming -import Data.Store.Streaming.Internal -import Data.Streaming.Network (runTCPServer, runTCPClient, clientSettingsTCP, serverSettingsTCP, setAfterBind) -import Data.Streaming.Network.Internal (AppData(..)) -import Data.Void (absurd, Void) -import Network.Socket (Socket(..), socketPort) -import Network.Socket.ByteString (send) -import qualified System.IO.ByteBuffer as BB -import System.Posix.Types (Fd(..)) -import Test.Hspec -import Test.Hspec.SmallCheck -import Test.SmallCheck - -spec :: Spec -spec = do - describe "conduitEncode and conduitDecode" $ do - it "Roundtrips ([Int])." $ property roundtrip - it "Roundtrips ([Int]), with chunked transfer." $ property roundtripChunked - it "Throws an Exception on incomplete messages." conduitIncomplete - it "Throws an Exception on excess input." $ property conduitExcess - describe "peekMessage" $ do - describe "ByteString" $ do - it "demands more input when needed." $ property (askMoreBS (headerLength + 1)) - it "demands more input on incomplete message magic." $ property (askMoreBS 1) - it "demands more input on incomplete SizeTag." $ property (askMoreBS (headerLength - 1)) - it "successfully decodes valid input." $ property canPeekBS - describe "decodeMessage" $ do - describe "ByteString" $ do - it "Throws an Exception on incomplete messages." decodeIncomplete - it "Throws an Exception on messages that are shorter than indicated." decodeTooShort -#ifndef mingw32_HOST_OS - describe "Socket" $ do - it "Decodes data trickling through a socket." $ property decodeTricklingMessageFd -#endif - -roundtrip :: [Int] -> Property IO -roundtrip xs = monadic $ do - xs' <- runResourceT $ C.sourceList xs - =$= C.map Message - =$= conduitEncode - =$= conduitDecode Nothing - =$= C.map fromMessage - $$ C.consume - return $ xs' == xs - -roundtripChunked :: [Int] -> Property IO -roundtripChunked input = monadic $ do - let (xs, chunkLengths) = splitAt (length input `div` 2) input - bs <- C.sourceList xs - =$= C.map Message - =$= conduitEncode - $$ C.fold (<>) mempty - let chunks = unfoldr takeChunk (bs, chunkLengths) - xs' <- runResourceT $ C.sourceList chunks - =$= conduitDecode (Just 10) - =$= C.map fromMessage - $$ C.consume - return $ xs' == xs - where - takeChunk (x, _) | BS.null x = Nothing - takeChunk (x, []) = Just (x, (BS.empty, [])) - takeChunk (x, l:ls) = - let (chunk, rest) = BS.splitAt l x - in Just (chunk, (rest, ls)) - -conduitIncomplete :: Expectation -conduitIncomplete = - (runResourceT (C.sourceList [incompleteInput] - =$= conduitDecode (Just 10) - $$ C.consume) - :: IO [Message Integer]) `shouldThrow` \PeekException{} -> True - -conduitExcess :: [Int] -> Property IO -conduitExcess xs = monadic $ do - bs <- C.sourceList xs - =$= C.map Message - =$= conduitEncode - $$ C.fold (<>) mempty - res <- try (runResourceT (C.sourceList [bs `BS.append` "excess bytes"] - =$= conduitDecode (Just 10) - $$ C.consume) :: IO [Message Int]) - case res of - Right _ -> return False - Left (PeekException _ _) -> return True - --- splits an encoded message after n bytes. Feeds the first part to --- peekResult, expecting it to require more input. Then, feeds the --- second part and checks if the decoded result is the original --- message. -askMoreBS :: Int -> Integer -> Property IO -askMoreBS n x = monadic $ BB.with (Just 10) $ \ bb -> do - let bs = encodeMessage (Message x) - (start, end) = BS.splitAt n $ bs - BB.copyByteString bb start - peekResult <- runFreeT (fromFT (peekMessageBS bb)) - case peekResult of - Free cont -> - runFreeT (cont end) >>= \case - Pure (Message x') -> return $ x' == x - Free _ -> return False - Pure _ -> return False - -canPeekBS :: Integer -> Property IO -canPeekBS x = monadic $ BB.with (Just 10) $ \ bb -> do - let bs = encodeMessage (Message x) - BB.copyByteString bb bs - peekResult <- runFreeT (fromFT (peekMessageBS bb)) - case peekResult of - Free _ -> return False - Pure (Message x') -> return $ x' == x - -#ifndef mingw32_HOST_OS - -socketFd :: Socket -> Fd -socketFd (MkSocket fd _ _ _ _) = Fd fd - -withServer :: (Socket -> Socket -> IO a) -> IO a -withServer cont = do - sock1Var :: MVar Socket <- newEmptyMVar - sock2Var :: MVar Socket <- newEmptyMVar - portVar :: MVar Int <- newEmptyMVar - doneVar :: MVar Void <- newEmptyMVar - let adSocket ad = case appRawSocket' ad of - Nothing -> error "withServer.adSocket: no raw socket in AppData" - Just sock -> sock - let ss = setAfterBind - (putMVar portVar . fromIntegral <=< socketPort) - (serverSettingsTCP 0 "127.0.0.1") - x <- fmap (either (either absurd absurd) id) $ race - (race - (runTCPServer ss $ \ad -> do - putMVar sock1Var (adSocket ad) - void (readMVar doneVar)) - (do port <- takeMVar portVar - runTCPClient (clientSettingsTCP port "127.0.0.1") $ \ad -> do - putMVar sock2Var (adSocket ad) - readMVar doneVar)) - (do sock1 <- takeMVar sock1Var - sock2 <- takeMVar sock2Var - cont sock1 sock2) - putMVar doneVar (error "withServer: impossible: read from doneVar") - return x - -decodeTricklingMessageFd :: Integer -> Property IO -decodeTricklingMessageFd v = monadic $ do - let bs = encodeMessage (Message v) - BB.with Nothing $ \bb -> - withServer $ \sock1 sock2 -> do - let generateChunks :: [Int] -> BS.ByteString -> [BS.ByteString] - generateChunks xs0 bs_ = case xs0 of - [] -> generateChunks [1,3,10] bs_ - x : xs -> if BS.null bs_ - then [] - else BS.take x bs_ : generateChunks xs (BS.drop x bs_) - let chunks = generateChunks [] bs - ((), Message v') <- concurrently - (forM_ chunks $ \chunk -> do - void (send sock1 chunk) - threadDelay (10 * 1000)) - (decodeMessageFd bb (socketFd sock2)) - return (v == v') - -#endif - -decodeIncomplete :: IO () -decodeIncomplete = BB.with (Just 0) $ \ bb -> do - BB.copyByteString bb (BS.take 1 incompleteInput) - (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Integer))) - `shouldThrow` \PeekException{} -> True - -incompleteInput :: BS.ByteString -incompleteInput = - let bs = encodeMessage (Message (42 :: Integer)) - in BS.take (BS.length bs - 1) bs - -decodeTooShort :: IO () -decodeTooShort = BB.with Nothing $ \bb -> do - BB.copyByteString bb (encodeMessageTooShort . Message $ (1 :: Int)) - (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Int))) - `shouldThrow` \PeekException{} -> True - -encodeMessageTooShort :: Message Int -> BS.ByteString -encodeMessageTooShort msg = - BS.take (BS.length encoded - (getSize (0 :: Int))) encoded - where - encoded = encodeMessage msg diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/test/Data/Store/UntrustedSpec.hs new/store-0.5.0/test/Data/Store/UntrustedSpec.hs --- old/store-0.4.3.2/test/Data/Store/UntrustedSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/store-0.5.0/test/Data/Store/UntrustedSpec.hs 2018-05-31 06:40:05.000000000 +0200 @@ -0,0 +1,186 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for untrusted data. + +module Data.Store.UntrustedSpec where + +import Test.Hspec + +spec :: Spec +spec = return () + +{- Untrusted data spec is disabled for now. See #122 / #123 for details + +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Proxy +import qualified Data.Sequence as Seq +import Data.Store +import Data.Store.Internal +import Data.String +import Data.Text (Text) +import qualified Data.Vector as V + +-- | Test suite. +actualSpec :: Spec +actualSpec = + describe + "Untrusted input throws error" + (do describe + "Array-like length prefixes" + (do let sample + :: IsString s + => s + sample = "abc" + list :: [Int] + list = [1, 2, 3] + it + "ByteString" + (shouldBeRightWrong huge (sample :: ByteString)) + it + "Lazy ByteString" + (shouldBeRightWrong huge (sample :: L.ByteString)) + it "Text" (shouldBeRightWrong huge (sample :: Text)) + it "String" (shouldBeRightWrong huge (sample :: String)) + it "Vector Int" (shouldBeRightWrong huge (V.fromList list)) + it + "Vector Char" + (shouldBeRightWrong huge (V.fromList (sample :: [Char]))) + it + "Vector unit" + (shouldBeRightWrong + huge + (V.fromList (replicate 1000 ()))) + it "Seq Int" (shouldBeRightWrong huge (Seq.fromList (sample :: [Char])))) + describe + "Maps are consistent" + (do it + "Map Int Int: with duplicates" + (shouldBeFail + (DuplicatedMap + (M.fromList [(1, 2), (4, 5)] :: Map Int Int)) + (Proxy :: Proxy (Map Int Int))) + it + "Map Int Int: wrong order" + (shouldBeFail + (ReversedMap + (M.fromList [(1, 2), (4, 5)] :: Map Int Int)) + (Proxy :: Proxy (Map Int Int))) + it + "IntMap Int Int: with duplicates" + (shouldBeFail + (DuplicatedIntMap + (IM.fromList [(1, 2), (4, 5)] :: IntMap Int)) + (Proxy :: Proxy (IntMap Int))) + it + "IntMap Int Int: wrong order" + (shouldBeFail + (ReversedIntMap + (IM.fromList [(1, 2), (4, 5)] :: IntMap Int)) + (Proxy :: Proxy (IntMap Int)))) + describe + "Constructor tags" + (do it + "Invalid constructor tag" + (shouldBe + (first + (const ()) + (decode "\2" :: Either PeekException (Maybe ()))) + (Left ())) + it + "Missing slots" + (shouldBe + (first + (const ()) + (decode "\1" :: Either PeekException (Maybe Char))) + (Left ())))) + +huge :: Int64 +huge = 2^(62::Int) + +-- | Check decode.encode==id and then check decode.badencode=>error. +shouldBeRightWrong + :: forall i. + (Store i, Eq i, Show i) + => Int64 -> i -> IO () +shouldBeRightWrong len input = do + shouldBe (decode (encode input) :: Either PeekException i) (Right input) + shouldBe + (first + (const ()) + (decode (encodeWrongPrefix len input) :: Either PeekException i)) + (Left ()) + +-- | Check decode.encode==id and then check decode.badencode=>error. +shouldBeFail + :: forall o i. + (Store i, Eq o, Show o, Store o) + => i -> Proxy o -> IO () +shouldBeFail input _ = + shouldBe + (first + (const ()) + (decode (encode input) :: Either PeekException o)) + (Left ()) + +-- | Encode a thing with the wrong length prefix. +encodeWrongPrefix :: Store thing => Int64 -> thing -> ByteString +encodeWrongPrefix len thing = encode len <> encodeThingNoPrefix thing + +-- | Encode the thing and drop the length prefix. +encodeThingNoPrefix :: Store thing => thing -> ByteString +encodeThingNoPrefix = S.drop (S.length (encode (1 :: Int64))) . encode + +-------------------------------------------------------------------------------- +-- Map variants + +newtype ReversedIntMap = ReversedIntMap (IntMap Int) + deriving (Show, Eq) +instance Store ReversedIntMap where + poke (ReversedIntMap m) = do + poke markMapPokedInAscendingOrder + poke (reverse (IM.toList m)) + peek = error "ReversedIntMap.peek" + size = VarSize (\(ReversedIntMap m) -> getSize m) + +newtype DuplicatedIntMap = DuplicatedIntMap (IntMap Int) + deriving (Show, Eq) +instance Store DuplicatedIntMap where + poke (DuplicatedIntMap m) = do + poke markMapPokedInAscendingOrder + poke (let xs = IM.toList m + in take (length xs) (cycle (take 1 xs))) + peek = error "DuplicatedIntMap.peek" + size = VarSize (\(DuplicatedIntMap m) -> getSize m) + +newtype ReversedMap = ReversedMap (Map Int Int) + deriving (Show, Eq) +instance Store ReversedMap where + poke (ReversedMap m) = do + poke markMapPokedInAscendingOrder + poke (reverse (M.toList m)) + peek = error "ReversedMap.peek" + size = VarSize (\(ReversedMap m) -> getSize m) + +newtype DuplicatedMap = DuplicatedMap (Map Int Int) + deriving (Show, Eq) +instance Store DuplicatedMap where + poke (DuplicatedMap m) = do + poke markMapPokedInAscendingOrder + poke (let xs = M.toList m + in take (length xs) (cycle (take 1 xs))) + peek = error "DuplicatedMap.peek" + size = VarSize (\(DuplicatedMap m) -> getSize m) + +-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/store-0.4.3.2/test/Data/StoreSpec.hs new/store-0.5.0/test/Data/StoreSpec.hs --- old/store-0.4.3.2/test/Data/StoreSpec.hs 2017-08-25 09:47:41.000000000 +0200 +++ new/store-0.5.0/test/Data/StoreSpec.hs 2018-05-31 06:35:48.000000000 +0200 @@ -91,19 +91,20 @@ , ''CUIntMax, ''CPtrdiff, ''CSChar, ''CShort, ''CUInt, ''CLLong , ''CLong, ''CInt, ''CChar, ''CSsize, ''CPid , ''COff, ''CMode, ''CIno, ''CDev - , ''Word8, ''Word16, ''Word32, ''Word64, ''Word + , ''Word8, ''Word16, ''Word32, ''Word64 , ''Int8, ''Int16, ''Int32, ''Int64 , ''PortNumber +#if !MIN_VERSION_smallcheck(1,1,3) + , ''Word +#endif #if MIN_VERSION_base(4,10,0) , ''CBool, ''CClockId, ''CKey, ''CId , ''CBlkSize, ''CFsBlkCnt, ''CFsFilCnt, ''CBlkCnt #endif - ] ++ -#ifdef mingw32_HOST_OS - [] -#else - [ ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid ] +#ifndef mingw32_HOST_OS + , ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid #endif + ] f n = [d| instance Monad m => Serial m $(conT n) where series = generate (\_ -> addMinAndMaxBounds [0, 1]) |] concat <$> mapM f ns)
