store 0.4.3.2 → 0.5.0

raw patch · 9 files changed

+298/−557 lines, 9 filesdep +bifunctorsdep −conduitdep −streaming-commonsPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors

Dependencies removed: conduit, streaming-commons

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• README.md +3/−0
• src/Data/Store.hs +3/−0
• src/Data/Store/Streaming.hs +0/−223
• src/Data/Store/Streaming/Internal.hs +0/−26
• store.cabal +93/−96
• test/Data/Store/StreamingSpec.hs +0/−206
• test/Data/Store/UntrustedSpec.hs +186/−0
• test/Data/StoreSpec.hs +7/−6

@@ -1,8 +1,14 @@ # 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 

@@ -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)

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)++-}

@@ -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)